=pod ###########################################################################

=head1 NAME

Apache::Voodoo::Install::Updater - Update xml processor

=head1 SYNOPSIS

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.

=cut ###########################################################################
package Apache::Voodoo::Install::Updater;

use strict;
use warnings;

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

use Apache::Voodoo::Constants;

use CPAN::Config;
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';

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;
}


sub do_update      { $_[0]->_do_all(0); }
sub do_new_install { $_[0]->_do_all(1); }

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

=pod

=head1 USAGE

=head2 new( %options )

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

=head2 do_update()

Causes the update chain to execute:  pre-setup.xml, unapplied updates, post-setup.xml

=head2 do_new_install()

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

=head2 mark_updates_applied()

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.

=head1 AUTHOR

Maverick, /\/\averick@smurfbaneDOTorg

=head1 COPYRIGHT

Copyright (c) 2005 Steven Edwards.  All rights reserved.

You may use and distribute Voodoo under the terms described in the LICENSE file include
in this package or L<Apache::Voodoo::license>.  The summary is it's a legalese version
of the Artistic License :)

=cut