File Coverage

blib/lib/Apache/Voodoo/Install/Updater.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

###############################################################################
#
# Apache::Voodoo::Install::Updater - Update xml processor
#
# This package provides the internal methods use by voodoo-control that do
# pre/post/upgrade commands as specified by the various .xml files in an
# application.  It's not intended to be use directly by end users.
#
###############################################################################
package Apache::Voodoo::Install::Updater;

$VERSION = "3.0200";

use strict;
use warnings;

use base("Apache::Voodoo::Install");

use Apache::Voodoo::Constants;

use CPAN;
use DBI;
use Digest::MD5;
use Sys::Hostname;
use XML::Checker::Parser;
use File::Find;
use Config::General qw(ParseConfig);

# make CPAN download dependancies
$CPAN::Config->{'prerequisites_policy'} = 'follow';

################################################################################
# Creates a new updater object with given configuration options.  It assumes
# that the files for the application have already been installed or exist in
# appropriate location.  A good database security setup would not allow the
# user the application connects as to have alter, create or drop privileges; thus
# the need for the database root password.  If pretend is set to a true value,
# the operations are stepped through, but nothing actually happens.
#
# usage:
#    Apache::Voodoo::Install::Updater->new(
#		dbroot   => $database_root_password,
#		app_name => $application_name,
#		verbose  => $output_verbosity_level,
#		pretend  => $boolean
#	);
################################################################################
sub new {
	my $class = shift;
	my %params = @_;

	my $self = {%params};

	my $ac = Apache::Voodoo::Constants->new();
	$self->{'_md5_'} = Digest::MD5->new;

	$self->{'install_path'} = $ac->install_path()."/".$self->{'app_name'};

	$self->{'conf_file'}    = $self->{'install_path'}."/".$ac->conf_file();
	$self->{'conf_path'}    = $self->{'install_path'}."/".$ac->conf_path();
	$self->{'updates_path'} = $self->{'install_path'}."/".$ac->updates_path();
	$self->{'apache_uid'}   = $ac->apache_uid();
	$self->{'apache_gid'}   = $ac->apache_gid();

	unless (-e $self->{'conf_file'}) {
		die "Can't open configuration file: $self->{'conf_file'}\n";
	}

	bless $self, $class;

	return $self;
}

# Causes the update chain to execute:  pre-setup.xml, unapplied updates, post-setup.xml
sub do_update      { $_[0]->_do_all(0); }

# Causes the new install chain to execute:  pre-setup.xml, setup.xml,
# post-setup.xml, mark all updates applied.  If this is executed on an
# existing system, Bad Things(tm) can happen depending on what commands
# are present in setup.xml
sub do_new_install { $_[0]->_do_all(1); }

# Wizard mode function.  This performs a replace into on the _updates table
# of a system to have entries and correct checksums for each update file
# without actually executing them.  If something went wrong with an install or
# upgrade and manual tinkering was required to get things back in order, this
# method can be used to ensure that the _updates table appears current.
sub mark_updates_applied {
	my $self = shift;

	my %conf = ParseConfig($self->{'conf_file'});

	$self->mesg("- Connection to database");
	$self->{'dbh'} = DBI->connect($conf{'database'}->{'connect'},'root',$self->{'dbroot'}) || die DBI->errstr;

	$self->mesg("- Looking for update command xml files");

	$self->_record_updates($self->_find_updates());

	$self->mesg("- All updates marked as applied");
}

sub _do_all {
	my $self = shift;
	my $new  = shift;

	my %conf = ParseConfig($self->{'conf_file'});

	if ($new) {
		$self->mesg("- Creating database");

		# FIXME create a factory structure to support multiple database types.
		my $c = $conf{'database'}->{'connect'};
		my ($dbname) = ($c =~/database=([^;]+)/);
		$c =~ s/database=[^;]+/database=test/;

		$self->{'dbh'} = DBI->connect($c,'root',$self->{'dbroot'}) || die DBI->errstr;
		$self->{'dbh'}->do("CREATE DATABASE $dbname"); # allowed to silently fail, db may already exist
		$self->{'dbh'}->disconnect;

		$self->{'dbh'} = DBI->connect($conf{'database'}->{'connect'},'root',$self->{'dbroot'}) || die DBI->errstr;

		$self->mesg("- Looking for setup command xml files");
	}
	else {
		$self->mesg("- Connection to database");
		$self->{'dbh'} = DBI->connect($conf{'database'}->{'connect'},'root',$self->{'dbroot'}) || die DBI->errstr;

		$self->mesg("- Looking for update command xml files");
	}

	# even if this is a new installation, we still need a list of the update files that came with
	# this distribution so that we'll know what updates to *not* perform in the event of an upgrade
	my @updates = $self->_find_updates();

	my @files;
	push(@files,$self->_find('pre-setup'));

	if ($new) {
		push(@files,$self->_find('setup'));
	}
	else {
		push(@files,@updates);
	}

	push(@files,$self->_find('post-setup'));

	# remove any "gaps".  There might not have been a pre/post/setup file.
	@files = grep { defined($_) } @files;

	my @commands = $self->_parse_commands(@files);

	$self->_execute_commands(@commands);

	# as noted above.  even for new installs we need to keep track of what updates
	# were part of this distro so we don't do them on the next update.
	$self->_record_updates(@updates);
}

sub _find {
	my $self = shift;
	my $file = shift;

	my $path = $self->{'conf_path'};
	if (-e "$path/$file.xml") {
		$self->debug("    $file.xml");
		return "$path/$file.xml";
	}

	return undef;
}

sub _find_updates {
	my $self = shift;

	return () unless (-e $self->{'updates_path'});

	my @updates;
	find({
			wanted => sub {
				my $file = $_;
				if ($file =~ /\d+\.\d+\.\d+(-[a-z\d]+)?\.xml$/) {
					push(@updates,$file);
				}
			},
			no_chdir => 1,
			follow   => 1
		},
		$self->{'updates_path'}
	);

	# Swartzian transform
	@updates = map {
		$_->[0]
	}
	sort {
		$a->[1] <=> $b->[1] ||
		$a->[2] <=> $b->[2] ||
		$a->[3] <=> $b->[3] ||
		defined($b->[4]) <=> defined($a->[4]) ||
		$a->[4] cmp $b->[4]
	}
	map {
		my $f = $_;
		s/.*\///;
		s/\.xml$//;
		[ $f , split(/[\.-]/,$_) ]
	}
	@updates;

	$self->_touch_updates_table();

	return grep { ! $self->_is_applied($_) } @updates;
}

sub _touch_updates_table {
	my $dbh = $_[0]->{'dbh'};

	my $res = $dbh->selectall_arrayref("SHOW TABLES LIKE '_updates'");
	unless (defined($res->[0]) && $res->[0]->[0] eq "_updates") {
		# not there.  create it.
		$dbh->do("
			CREATE TABLE _updates (
				file VARCHAR(255) NOT NULL PRIMARY KEY,
				checksum VARCHAR(32) NOT NULL
			)") || die DBI->errstr;
	}
}

sub _record_updates {
	my $self  = shift;
	my @files = @_;

	$self->_touch_updates_table();

	my $dbh = $self->{'dbh'};

	foreach my $file (@files) {
		my $sum = $self->_md5_checksum($file);
		$file =~ s/.*\///;
		$file =~ s/\.xml//;
		$dbh->do("REPLACE INTO _updates(file,checksum) VALUES(?,?)",undef,$file,$sum) || die DBI->errstr;
	}
}

sub _is_applied {
	my $self = shift;
	my $file = shift;

	my $dbh = $self->{'dbh'};

	my $f = $file;
	$f =~ s/.*\///;
	$f =~ s/\.xml//;

	my $res = $dbh->selectall_arrayref("
		SELECT
			checksum
		FROM
			_updates
		WHERE
			file = ?",undef,
		$f) || die DBI->errstr;

	if (defined($res->[0]->[0])) {
		if ($res->[0]->[0] ne $self->_md5_checksum($file)) {
			# YIKES!!! this update file doesn't match the one
			# we think we've already ran.
			print "MD5 checksum of $f doesn't match the one store in the DB.  aborting\n";
			exit;
		}
		else {
			return 1;
		}
	}
	else {
		return 0;
	}
}

sub _md5_checksum {
	my $self = shift;
	my $file = shift;

	my $md5 = $self->{'_md5_'};
	$md5->reset;

	open(F,$file) || die "Can't md5 file $file: $!";
	$md5->add();
	close(F);

	return $md5->hexdigest;
}

sub _parse_commands {
	my $self  = shift;

	my @commands;
	foreach my $file (@_) {
		my $data = $self->_parse_xml($file);

		if (!defined($data)) {
			print "\n* Parse of $file failed. Aborting *\n";
			exit;
		}
		print "    parsed $file\n";
		push(@commands,[$file,$data]);
	}
	return @commands;
}

sub _parse_xml {
	my $self    = shift;
	my $xmlfile = shift;

	my $parser = new XML::Checker::Parser(
		'Style' => 'Tree',
		'SkipInsignifWS' => 1
	);

	my $dtdpath = $INC{'Apache/Voodoo/Install/Updater.pm'};
	$dtdpath =~ s/Install\/Updater\.pm$//;

	$parser->set_sgml_search_path($dtdpath);

	my $data;
	eval {
			# parser checker only dies on catastrophic errors.  Adding this handler
			# makes it die on ALL errors.
			local $XML::Checker::FAIL = sub {
				my $errcode = shift;

				print "\n ** Parse of $xmlfile failed **\n";
				die XML::Checker::error_string ($errcode, @_) if $errcode < 200;
				XML::Checker::print_error ($errcode, @_);
			};

			$data = $parser->parsefile($xmlfile);
	};
	if ($@) {
			print $@;
			return undef;
	}
	return $data;

}

sub _execute_commands {
	my $self = shift;
	my @set  = @_;

	my $pretend      = $self->{'pretend'};
	my $install_path = $self->{'install_path'};

	chdir($install_path);

	# find out what our hostname is
	my $hostname = Sys::Hostname::hostname();

	$self->info("- Running setup/update commands");
	foreach (@set) {
		my $file = $_->[0];
		my @commands = @{$_->[1]->[1]};

		$self->debug("    $file");
		for (my $i=1; $i < $#commands; $i+=2) {
			my $type = $commands[$i];
			my $data = $commands[$i+1]->[2];

			if (defined($commands[$i+1]->[0]->{'onhosts'})) {
				next unless grep { /^$hostname$/ } split(/\s*,\s*/,$commands[$i+1]->[0]->{'onhosts'});
			}

			# Reset the current working directory back to the install path
			chdir($install_path);

			$data =~ s/^\s*//;
			$data =~ s/\s*$//;

			if ($type eq "shell") {
				$self->debug("        SHELL: ", $data);
				unless ($self->{pretend}) {
					if (system($data)) {
						$self->{ignore} or die "Shell command failed: $!";
					}
				}
			}
			elsif ($type eq "sql") {
				$self->_execute_sql($data);
			}
			elsif ($type eq "mkdir") {
				$self->debug("        MKDIR: ", $data);
				$self->make_writeable_dirs("$install_path/$data");
			}
			elsif ($type eq "mkfile") {
				$self->debug("        TOUCH/CHMOD: ", $data);
				$self->make_writeable_files("$install_path/$data");
			}
			elsif ($type eq "install") {
				$self->debug("        CPAN Install: ", $data);
				unless ($pretend) {
					CPAN::Shell->install($data);
				}
			}
			else {
				print "\n* Unsupported command type ($type). Aborting *\n";
				exit;
			}
		}
	}
}

sub _execute_sql {
	my $self = shift;
	my $data = shift;

	$self->debug("        SQL: ", $data);
	return if $self->{'pretend'};

	my $path = $self->{'install_path'};
	my $dbh  = $self->{'dbh'};

	if ($data =~ /^source\s/i) {
		$data =~ s/^source\s*//i;

		my ($query,$in_quote,$close_quote);
		open(SQL,"$path/$data") || die "Can't open $path/$data: $!";
		while (!eof(SQL)) {
			my $c = getc SQL;
			if (!$in_quote && $c eq ';') {
				$query =~ s/^\s*//;
				$query =~ s/\s$//;
				next if ($query =~ /^[\s;]*$/);        # an empty query turns a do into a don't
				next if ($query =~ /^(UN)?LOCK /i);    # do yacks on these too

				unless ($dbh->do($query)) {
					$self->{ignore} or die "sql source failed $query: " . DBI->errstr;
				}

				$query = '';
				$c = getc SQL;
			}

			if ($c eq '\\') {
				$query .= $c;
				$c = getc SQL;  # automatically add the next character
			}
			elsif ($c eq "'") {
				if ($in_quote && $close_quote eq "'") {
					$in_quote = 0;
					$close_quote = '';
				}
				elsif (!$in_quote) {
					$in_quote = 1;
					$close_quote = "'";
				}
			}
			elsif ($c eq '"') {
				if ($in_quote && $close_quote eq '"') {
					$in_quote = 0;
					$close_quote = '';
				}
				elsif (!$in_quote) {
					$in_quote = 1;
					$close_quote = '"';
				}
			}

			$query .= $c;
		}
		close(SQL);
	}
	else {
		unless ($dbh->do($data)) {
			$self->{ignore} or die "sql failed: DBI->errstr\n\n$data";
		}
	}
}

1;

################################################################################
# Copyright (c) 2005-2010 Steven Edwards ([e-mail]).
# All rights reserved.
#
# You may use and distribute Apache::Voodoo under the terms described in the
# LICENSE file include in this package. The summary is it's a legalese version
# of the Artistic License :)
#
################################################################################