symlink-tool

#!/usr/bin/perl -w
# This code is a part of Slash, and is released under the GPL.
# Copyright 1997-2005 by Open Source Technology Group. See README
# and COPYING for more information, or see http://slashcode.com/.
# $Id$

# By Jamie McCarthy, jamie@slashdot.org
# Based on template-tool, by Cliff Wood, Patrick Galbraith, Brian Aker
#
# STILL UNDER TESTING -- handles plugins now -- for now,
# be sure to use -T on any production site just in case this
# screws something up!!!

use strict;
use File::Basename;
use File::Path;
use File::Spec::Functions qw( :DEFAULT splitpath splitdir);
use Slash;
use Slash::Utility;
use Slash::DB;
use Slash::Install;
use Template;
use Getopt::Std;
use JavaScript::Minifier 0.02;

(my $VERSION) = ' $Revision$ ' =~ /\$Revision:\s+([^\s]+)/;
my $PROGNAME = basename($0);
my %opts;

my $symlink_exists = eval { symlink("",""); 1 };
if (!$symlink_exists) {
	print STDERR "Sorry - symlink() not implemented on your system,\n";
	print STDERR "so (duh!) symlink-tool cannot run.\n";
	exit 1;
}

# Remember to doublecheck these match usage()!
usage('Options used incorrectly')
	unless getopts('hvu:TtUV', \%opts);
usage() if $opts{h} || !keys %opts;
version() if $opts{v};
usage('Right now only -U does anything') if !$opts{U};
my $testing = $opts{T} ? 1 : ($opts{t} ? 1 : 0);
my $verbose = $opts{V} ? 1 : 0;

my $virtuser = $opts{u} || 'slash';
createEnvironment($virtuser);
my @dotfiles = ( );
my $slashdb = getCurrentDB();
my $constants = getCurrentStatic();
my $install = Slash::Install->new($virtuser);

# This will read all the themes and all the plugins available for this
# installation.
my $get_theme = $install->get("theme");
die "cannot get theme, DB probably unreachable" if !$get_theme;
my $site_theme = $get_theme->{value};
my $site_plugins = $install->get("plugin");
my @site_plugins = sort
	map { $site_plugins->{$_}{value} }
	keys %$site_plugins;

# What one theme, and what subset of the available plugins, is this
# site using?
my $theme_hr = $install->_getList(
	$constants->{slashdir}, "themes", "THEME", 1
)->{$site_theme};
my $plugin_list = $install->_getList(
	$constants->{slashdir}, "plugins", "PLUGIN", 1
);

############################################################
# Handle globbing and minifying/tidying, do this first so results can be linked
for my $theme_or_plugin ($theme_hr, values %$plugin_list) {
	for my $glob (keys %{$theme_or_plugin->{'glob'}}) {
		my $destpath = canonpath(
			catfile($theme_or_plugin->{dir},
				$theme_or_plugin->{'glob'}{$glob})
		);
		my @filelist = ( );
		for my $file (@{$theme_or_plugin->{$glob}}) {
			push @filelist, canonpath(catfile($theme_or_plugin->{dir}, $file));
		}

		my $glob_template = Template->new({
			INCLUDE_PATH	=> $theme_or_plugin->{dir},
			PROCESS				=> \@filelist,
			OUTPUT				=> \$destpath,
			ABSOLUTE			=> 1,
			RELATIVE			=> 1,
			INTERPOLATE		=> 0,
		}) || die "$Template::ERROR\n";
		
		$glob_template->process($filelist[0], $constants, $destpath) || die $glob_template->error(), "\n";

		# system("cat $filelist > $destpath");
		my($name, $path, $suffix) = fileparse($destpath, qr/\.[^.]*/);

		# you can glob any kinds of files you like, even mixing them...
		# ...but if the globbed destination claims to be JavaScript, I'll also make a `minified' version
		# (JavaScript::Minifier is a requirement in the Slash bundle)
		if ($suffix eq '.js') {
			my($min_src, $min_dest);
			open $min_src, '<', $destpath;
			open $min_dest, '>', "${path}${name}-minified.js";
			if (JavaScript::Minifier->can('jsmin')) {
				JavaScript::Minifier::jsmin($min_src, $min_dest);
			} elsif (JavaScript::Minifier->can('minify')) {
				&JavaScript::Minifier::minify(
					input => $min_src, outfile => $min_dest
				);
			} else {
				die "I give up, how does JavaScript::Minifier $JavaScript::Minifier::VERSION do its thing?";
			}
		}

		# ...similarly for CSS, I'll also make a `csstidied' version
		# (CSSTidy is _not_ a requirement in the Slash bundle, so we have to check)
 		elsif ($suffix eq '.css') {
 		  my $tidiedpath = "${path}${name}-tidied.css";
 		  # create a `tidied' version of css globs if csstidy is available,
 		  #   else the tidied version is just a link to the original concatenation
 		  # consider: allow custom install dir for csstidy? a la sbindir, datadir, hc_fontpath, et al
 			if ( system("csstidy $destpath --silent=true --template=high $tidiedpath") != 0 ) {
 			  link("$destpath", "$tidiedpath");
 			}
 		}
	}
}


############################################################
# Set up the %theme_subdir_files and %plugin_subdir_files hashes,
# to have a list of all the files that our theme references.
my %theme_subdir_files = ( );
my %plugin_subdir_files = ( );
my %theme_css_translate = ();
my %plugin_css_translate = ();
# First, pull in the files referenced by the theme.
my @theme_htdocs_keys = grep /^(htdoc|image|topic|css)/, keys %$theme_hr;
for my $key (@theme_htdocs_keys) {
	next unless $key && $theme_hr->{$key};
	if ($key eq "css" and $constants->{css_use_imagedir}) {		
		if (ref($theme_hr->{$key}) && ref($theme_hr->{$key}) eq "ARRAY") {
			$theme_css_translate{$_} = 1 foreach @{$theme_hr->{$key}};
		} else {
			$theme_css_translate{$theme_hr->{$key}} = 1;
		}
	}
	push @{$theme_subdir_files{htdocs}},
		ref($theme_hr->{$key}) && ref($theme_hr->{$key}) eq 'ARRAY'
			? @{$theme_hr->{$key}}
			: $theme_hr->{$key};
}

for my $key (qw( tasks misc )) {
	my $src_key = $key;
	$src_key =~ s/s$//; # theme "task" becomes theme_subdir_files "tasks"
	next unless $theme_hr->{$src_key};
	@{$theme_subdir_files{$key}} =
		ref($theme_hr->{$src_key}) && ref($theme_hr->{$src_key}) eq 'ARRAY'
			? @{$theme_hr->{$src_key}}
			: $theme_hr->{$src_key};
}

# Then, pull in the files referenced by each plugin used.
my %plugin_htdocs_keys = ( );
my @plugin_htdocs_keys = ( );
for my $plugin (keys %$plugin_list) {
	for my $key (grep /^(htdoc|image|topic|css)/, keys %{$plugin_list->{$plugin}}) {
		$plugin_htdocs_keys{$key} = 1;
	}
}
@plugin_htdocs_keys = sort keys %plugin_htdocs_keys;
for my $plugin (keys %$plugin_list) {
	my $plugin_hr = $plugin_list->{$plugin};
	for my $key (@plugin_htdocs_keys) {
		next unless $key && $plugin_hr->{$key};
		if ($key eq "css" and $constants->{css_use_imagedir}) {		
			if (ref($plugin_hr->{$key}) && ref($plugin_hr->{$key}) eq "ARRAY") {
				$plugin_css_translate{$plugin}{$_} = 1 foreach @{$plugin_hr->{$key}};
			} else {
				$plugin_css_translate{$plugin}{$_} = $plugin_hr->{$key};
			}
		}
		push @{$plugin_subdir_files{$plugin}{htdocs}},
			ref($plugin_hr->{$key}) && ref($plugin_hr->{$key}) eq 'ARRAY'
				? @{$plugin_hr->{$key}}
				: $plugin_hr->{$key};
	}
	for my $key (qw( tasks misc )) {
		my $src_key = $key;
		$src_key =~ s/s$//; # plugin "task" becomes "tasks"
		next unless $plugin_hr->{$src_key};
		@{$plugin_subdir_files{$plugin}{$key}} =
			ref($plugin_hr->{$src_key}) && ref($plugin_hr->{$src_key}) eq 'ARRAY'
				? @{$plugin_hr->{$src_key}}
				: $plugin_hr->{$src_key};
	}
}
#use Data::Dumper;
#print "theme_hr: " . Dumper($theme_hr);
#print "plugin_list: " . Dumper($plugin_list);
#print "theme_subdir_files: " . Dumper(\%theme_subdir_files);
#print "plugin_subdir_files: " . Dumper(\%plugin_subdir_files);
#print "theme css translate: " . Dumper(\%theme_css_translate);
#print "plugin css translate: " . Dumper(\%plugin_css_translate);

my $theme_dir = $theme_hr->{dir};
my $site_dir = $constants->{datadir};

if (!$testing && !-w $site_dir) {
	print STDERR "No write access to '$site_dir'\n";
	print STDERR "for EUID $>, cannot write any files\n";
	exit 1;
}

my %processed = ( );
my $num_changes = 0;
for my $subdir (sort keys %theme_subdir_files) {
	my @files = sort @{$theme_subdir_files{$subdir}};
	for my $target_file (@files) {
		# Strip off "../slashcode/" from front to find
		# where the symlink was installed in the
		# "site/foo" tree.
		my $theme_file_abs = canonpath(catfile($theme_dir, $target_file));
		1 while $theme_file_abs =~ s{/[^/]+/\.\.}{};
		my $site_rel_file = $target_file;
		1 while $site_rel_file =~ s{^\.\.\/[^/]+/}{};
		my $site_file_abs = canonpath(catfile($site_dir, $site_rel_file));

		$site_file_abs 	= css_translate($site_file_abs) if ($theme_css_translate{$target_file});

		if ($processed{$site_file_abs}) {
			if ($verbose) {
				print "Skipping file in theme, already processed: '$site_file_abs'\n";
			}
			next;
		}
		my $site_file_abs_dot = dotfile($site_file_abs);
		my $site_file_abs_dot_short = dotfile($site_rel_file);
		# At this point, $site_file_abs is e.g.
		# '/usr/local/slash/site/mysite/tasks/spamarmor.pl'
		# $site_file_abs_dot is e.g.
		# '/usr/local/slash/site/mysite/tasks/.spamarmor.pl'
		# $theme_file_abs is e.g.
		# '/usr/local/slash/theme/slashcode/tasks/spamarmor.pl'


		$num_changes += handle_file($site_file_abs, $theme_file_abs,
			$site_file_abs_dot, $site_file_abs_dot_short);
		$processed{$site_file_abs} = 1;
	}
}
for my $plugin (sort keys %plugin_subdir_files) {
	my $plugin_hr = $plugin_subdir_files{$plugin};
	my $plugin_dir = $plugin_list->{$plugin}{dir};
	for my $subdir (sort keys %$plugin_hr) {
		my @files = sort @{$plugin_hr->{$subdir}};
#print "plugin '$plugin' subdir '$subdir' files '@files'\n";
		for my $target_file (@files) {
			my $plugin_file_abs = canonpath(catfile($plugin_dir, $target_file));
			1 while $plugin_file_abs =~ s{/[^/]+/\.\.}{};
			my $site_rel_file = $target_file;
			1 while $site_rel_file =~ s{^\.\.\/[^/]+/}{};
			# Plugins don't get the type prepended so we need to
			# do that here.
			$site_rel_file =~ s{^(?:$subdir/)?}{$subdir/};
			my $site_file_abs = canonpath(catfile($site_dir, $site_rel_file));
			
			$site_file_abs 	= css_translate($site_file_abs) if ($plugin_css_translate{$plugin}{$target_file});

#print "plugin '$plugin' subdir '$subdir' site_rel_file '$site_rel_file' site_file_abs '$site_file_abs'\n";
			if ($processed{$site_file_abs}) {
				if ($verbose) {
					print "Skipping file in '$plugin' plugin, already processed: '$site_file_abs'\n";
				}
				next;
			}
			my $site_file_abs_dot = dotfile($site_file_abs);
			my $site_file_abs_dot_short = dotfile($site_rel_file);
			# At this point, $site_file_abs is e.g.
			# '/usr/local/slash/site/mysite/tasks/adminmail.pl'
			# $site_file_abs_dot is e.g.
			# '/usr/local/slash/site/mysite/tasks/.adminmail.pl
			# $plugin_file_abs is e.g.
			# '/usr/local/slash/plugin/Stats/adminmail.pl'
			
			$num_changes += handle_file($site_file_abs, $plugin_file_abs,
				$site_file_abs_dot, $site_file_abs_dot_short);
			$processed{$site_file_abs} = 1;
		}
	}
}
if ($num_changes == 0) {
	print "symlink-tool -U: no symlink changes necessary\n";
}

if (@dotfiles) {
	print "symlink-tool: found dotfiles: @dotfiles\n";
}

###############################################
sub handle_file {
	my($symlink_file, $target_file, $symlink_file_dot, $symlink_file_dot_short) = @_;

	if (!-e $target_file) {
		print "Target file '$target_file' missing, can't create symlink\n";
		return 1;
	}

	if (!-e $symlink_file && -e $symlink_file_dot) {
		# The symlink file is missing and in its place is a
		# dotfile.  The site admin must have disabled that file,
		# perhaps temporarily.  Make sure it's correct;  do
		# what we were doing to do on the real file, on the
		# dotfile instead.
		$symlink_file = $symlink_file_dot;
		push @dotfiles, $symlink_file_dot_short;
		if ($verbose) {
			print "Checking dotfile replacement at '$symlink_file'\n";
		}
	}

	if (-e $symlink_file && !-l $symlink_file) {
		# The file in place is not a symlink; compare it to
		# what it should be and only replace it with a symlink
		# if the two are identical.
		my $diff;
		if ($verbose) {
			$diff = system("diff $target_file $symlink_file");
		} else {
			$diff = system("diff $target_file $symlink_file > /dev/null");
		}
		if ($diff) {
			print "File should be symlink, but is not, and differs from intended target: '$symlink_file' '$target_file'; difference needs to be resolved or symlink-tool will not touch it\n";
			return 1;
		} else {
			print "File at '$symlink_file' is not a symlink, but is identical to what it should be; ";
			if ($testing) {
				print "file would be unlinked and allowed to be recreated.\n";
				return 1;
			} else {
				print "unlinking; will be created next.\n";
				unlink $symlink_file;
			}
		}
	}

	lstat($symlink_file);
	if (!-e _) {
		print "Symlink at '$symlink_file' missing, ";
		if ($testing) {
			print "would create: '$target_file'\n";
			return 1;
		}
		my $success = symlink($target_file, $symlink_file);
		if (!$success) {
			print "attempt to create FAILED: $!\n";
			return 1;
		}
		print "successfully added link to '$target_file'\n";
		return 1;
	}
	my $cur_target_file = readlink($symlink_file);
	if ($cur_target_file eq $target_file) {
		if ($verbose) {
			print "Correct: $symlink_file -> $target_file\n";
		}
		return 0;
	}
	print "Symlink at '$symlink_file' mispointed at '$cur_target_file', ";
	if ($testing) {
		print "would repoint to '$target_file'\n";
		return 1;
	}
	my $success = unlink $symlink_file;
	if (!$success) {
		print "attempt to unlink FAILED: $!\n";
		return 1;
	}
	$success = symlink($target_file, $symlink_file);
	if (!$success) {
		print "original unlinked, attempt to link properly FAILED: $!\n";
		return 1;
	}
	print "successfully relinked to '$target_file'\n";
	return 1;
}

###############################################
sub css_translate {
	my ($file_abs) = @_;
	my $seen_htdocs = 0;
	my ($volume, $dirs, $file) = splitpath($file_abs);
	my @dirs = splitdir($dirs);
	push @dirs, "images";
	return catfile(@dirs, $file);
	
}
###############################################
sub dotfile {
	my($file_abs) = @_;
	my($volume, $dirs, $file) = splitpath($file_abs);
	return "$dirs.$file";
}

###############################################
sub usage {
	print "*** $_[0] \n" if $_[0];
	print <<EOT;

Usage: $PROGNAME [OPTIONS] <template templateN>

Main options:
	-h	Help (this message)
	-v	Version
	-u	Virtual user (default is "slash")
	-t	Test run, report but don't do anything
	-T	Synonym for -t
	-U	Upgrade your symlinks to the latest for your theme and plugins

Debugging options:
	-V	Increases verbosity.

EOT
	exit 0;
}

###############################################
sub version {
	print <<EOT;

$PROGNAME $VERSION

This code is a part of Slash, and is released under the GPL.
Copyright 1997-2005 by Open Source Technology Group. See README
and COPYING for more information, or see http://slashcode.com/.

EOT
	exit 0;
}