symlink-tool

#!/usr/bin/perl -w
# This code is a part of Slash, and is released under the GPL.
# Copyright 1997-2004 by Open Source Development Network. 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 );
use Slash;
use Slash::Utility;
use Slash::DB;
use Slash::Install;
use Getopt::Std;

(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
);

############################################################
# 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 = ( );

# First, pull in the files referenced by the theme.
my @theme_htdocs_keys = grep /^(htdoc|image|topic)/, keys %$theme_hr;
for my $key (@theme_htdocs_keys) {
	next unless $key && $theme_hr->{$key};
	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)/, 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};
		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);

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));
		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));
#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 $symlink_file && -e $symlink_file_dot) {
		# The symlink file is missing and in its place is a
		# dotfile.  This site must have that file disabled,
		# 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 -U3 $target_file $symlink_file");
		} else {
			$diff = system("diff -U3 $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 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-2004 by Open Source Development Network. See README
and COPYING for more information, or see http://slashcode.com/.

EOT
	exit 0;
}