xfer_catalog.coretag

UserTag xfer-catalog Order file
UserTag xfer-catalog addAttr
UserTag xfer-catalog Routine <<EOR
sub {
	my ($file, $opt) = @_;
	my %dsn;
	my %db;
	my %export;
	my %dbtype;
	my %dbname;
	my %user;
	my %pass;
	my $now = time();

	my $root = $Vend::Cfg->{VendRoot};
	my $catname = $Vend::Cfg->{CatalogName};

	my @exclude = ("./$catname.tar.gz", './products/existing.site.txt');

	my %exclude = (
		tmp	=> ['./tmp/*'],
		session	=> ['./session/*'],
		usertrack	=> ["./$Vend::Cfg->{TrackFile}"],
		orders	=> ["./logs/tracking.asc", './orders/*'],
		survey	=> ["./logs/survey"],
		logs	=> ['./logs/log', './error.log'],
		backup	=> ['./backup/*'],
		config	=> ['./config/*'],
		upload	=> ['./upload/*'],
	);

	my $export_and_exclude = sub {
		my ($t, $o) = @_;
		my $dbo = dbref($t);
		$dbo = $dbo->ref() if $dbo;
		$export{$t} = $o->{file};
		my $dir = $o->{DIR};
		my $dbf = $o->{db_file};
		if($dbf =~ m{^/}) {
			$dbf =~ s{^$root}{.};
		}
		elsif($dir =~ s{^$root}{.}) {
			$dbf = "$dir/$dbf";
		}
		else {
			::logDebug("Unrecognized db file $dbf");
		}
		push @exclude, $dbf;
	};
	my @restore = (<<'EOF');
#!/bin/sh

DIR=$1

USAGE="ic_restore.sh [directory]";
if test -n "$DIR"
then
	cd $DIR || (echo "$DIR: does not exist"; echo $USAGE; exit 1);
fi

if test ! -d xfer/exports
then
	echo "Not a restore directory for Interchange."
	echo $USAGE
	exit 1;
fi

cp -r xfer/exports/* products
EOF
	my %maptype = (
		mysql => {
			restore => $::Variable->{RESTORE_COMMAND_MYSQL} || 'mysql',
			create => $::Variable->{CREATE_COMMAND_MYSQL} || 'mysqladmin create %s',
			command => $::Variable->{DUMP_COMMAND_MYSQL} || 'mysqldump --add-drop-table',
			host => '-h %s',
			port => '-p %s',
			user => '-u %s',
			pass => '-p%s',
		},
		Pg => {
			restore => $::Variable->{RESTORE_COMMAND_PG} || 'psql -q',
			create => $::Variable->{CREATE_COMMAND_PG} || 'createdb %s',
			command => $::Variable->{DUMP_COMMAND_PG} || 'pg_dump -c -O',
			host => '-h %s',
			port => '-p %s',
			user => '-U %s',
		},
	);

	my %usermap = (
		mysql => {
			USER => '-u %s',
			PASS => '-p%s',
		},
		Pg => {
			USER => '-U %s',
		},
	);

	my %dbparm = (
		mysql => {
			database => 1,
		},
		Pg => {
			dbname => 1,
		},
	);

	my $date = POSIX::strftime('%Y%m%d%H%M%S', localtime());
	if(-e 'xfer') {
		unless($opt->{backup_old}) {
			File::Path::rmtree('xfer');
		}
		else {
			rename 'xfer', "xfer.backup.$date";
		}
	}
	File::Path::mkpath('xfer');
	File::Path::mkpath('xfer/exports');
	File::Path::mkpath('xfer/dumps');

	while( my ($t, $o) = each %{$Vend::Cfg->{Database}} ) {
		next if $t eq 'site';
#::logDebug("Parsing $t");
		if(! $o) {
			::logDebug("bad object=$o table=$t");
			next;
		}

#::logDebug("$t type=$o->{type}");
		if($o->{type} != 8) {
			$export_and_exclude->($t, $o);
			next;
		}

		my $dsn = $o->{DSN};
#::logDebug("$t DSN=$o->{DSN}");
		next if $dsn{$dsn};
		my $dbstring = $dsn;
		$dbstring =~ s/^dbi://i;
		$dbstring =~ s/^(\w+)://i;
		my $driver = $1;
#::logDebug("$t driver=$driver");

		my $map = $maptype{$driver};
		if(! $map) {
			$export_and_exclude->($t, $o);
			next;
		}
		
		$dbtype{$dsn} = $driver;

		my $dbname;
		my @pieces = split /\s*;\s*/, $dbstring;

		my @args;

		for(@pieces) {
#::logDebug("checking piece=$_");
			if(/=/) {
				my ($k, $v) = split /\s*=\s*/, $_;
				$k = lc $k;
				if(my $tpl = $map->{$k}) {
					$tpl =~ s/\%s/$v/g;
					push @args, $tpl;
				}
				elsif($dbparm{$driver}->{$k}) {
					$dbname = $v;
				}
				else {
					Vend::Tags->warnings("Unrecognized DSN atom '$_'");
					next;
				}
			}
			else {
				$dbname = $_;
			}
		}
		if(! $dbname) {
			my $msg = "Unable to find dbname for $dsn.";
			logError($msg);
			return $msg if $opt->{show_error};
			return;
		}

		$dbname{$dsn} = $dbname;

		$dsn{$dsn} = join " ", $map->{command}, @args, $dbname;
		if (my $user = $o->{USER}) {
			$user{$dsn} = $user;
			my $tpl = $map->{user};
			$tpl =~ s/\%s/$user/g
					and $dsn{$dsn} .= " $tpl";
		}
		if (my $pass = $o->{PASS}) {
			$pass{$dsn} = $pass;
			my $tpl = $map->{pass};
			$tpl =~ s/\%s/$pass/g
					and $dsn{$dsn} .= " $tpl";
		}
	}

	for my $t (keys %export) {
		$export{$t} =~ m{(.*)/}
			and do {
				my $dircomp = $1;
				File::Path::mkpath("$root/xfer/exports/$dircomp");
			};
		Vend::Data::export_database($t, "$root/xfer/exports/$export{$t}", undef, {})
			or logError("Failed to export table $t in xfer-catalog.");
	}
	for(keys %dsn) {
		my $ext = $_ eq $::Variable->{SQLDSN} ? 'maindump' : 'dump';
		my $cmd = "$dsn{$_} > xfer/dumps/$dbname{$_}.$dbtype{$_}.$ext";
#::logDebug("executing $cmd");
		system $cmd;
		if($?) {
			my $status = $?;
			my $err = $status >> 8;
			my $msg = errmsg("error=%s, status=%s execuding dump '%s': %s", $err, $status, $cmd, $!);
			::logDebug($msg);
			::logError($msg);
			return $msg if $opt->{show_error};
			return;
		}
	}

	if($opt->{keep_together} ||= $CGI::values{keep_together}) {
		my @keys = grep /\w/, split /[\s,\0]+/, $opt->{keep_together};
		for(@keys) {
#::logDebug("Setting keepname keep_$_");
			$opt->{"keep_$_"} = 1;
		}
	}
	for my $name (keys %exclude) {
		my $kname = "keep_$name";
		if(exists $opt->{$kname}) {
			next if $opt->{$kname};
		}
		if ($CGI::values{$kname}) {
			next;
		}
		push @exclude, @{$exclude{$name}};
	}
	my $excludestring =  join("\n", @exclude, '');
#::logDebug("exclude:\n$excludestring");
	unlink 'exclude-files';
	Vend::File::writefile('exclude-files', $excludestring);

	my @vars = qw/
		CGI_URL
		DOCROOT
		IMAGE_DIR
		ORDERS_TO
		SAMPLEHTML
		SAMPLEURL
		SECURE_SERVER
		SERVER_NAME
		SQLDSN
		SQLPASS
		SQLUSER
		IC_DIR
		CGI_DIR
		CGIWRAP
		LINKMODE
		LINKHOST
		LINKPORT
		LINKPORT
	/;
	if(defined $opt->{variables}) {
		@vars = grep /\S/, split /[\s,\0+]/, $opt->{variables};
	}

	my $vdb = dbref('variable');
	my @vdb = "code\tVariable\tpref_group";

	my $imagebase;

	## Don't really care if this fails
	rename 'products/site.txt', 'products/existing.site.txt';

	my @backups = '.';
	my $newdriver;
	my %restore;
	for(@vars) {
		my $val = $CGI::values{$_} || $::Variable->{$_};
		my $pref = $val, tag_data('variable', 'pref_group', $_);
		push @vdb, join("\t", $_, $val, $pref);
		if($_ eq 'SQLDSN') {
			my $thing = $restore{sqldsn} = $val;
			$thing =~ s/^dbi:(\w+)://i
				and $newdriver = $1;
			if($thing =~ /\bdatabase=(\w+)/ or $thing =~ /\bdbname=(\w+)/) {
				$thing = $1;
			}
			$restore{dbname} = $thing;
		}
		elsif($_ eq 'DOCROOT') {
			$restore{docroot} = $val;
			$imagebase = $val if $val;
		}
		elsif($_ eq 'IMAGE_DIR') {
			my $add = $val;
			if($add =~ m{^http:}) {
				undef $imagebase;
			}
			else {
				$add =~ s{^/\~[^/]+}{};
				$imagebase .= $add if $imagebase;
			}
		}
		else {
			$restore{lc $_} = $val;
		}
	}
#::logDebug("imagebase=$imagebase");

	RESTOREBUILD: {
		if($imagebase) {
			push @backups, './images/*';
			push @restore, <<EOF;
mkdir -p $imagebase
cp -r images/* $imagebase
rm -rf images
ln -s $imagebase images
EOF
		}
		last RESTOREBUILD unless $newdriver;
		my @possible = glob('xfer/dumps/*.maindump');
		if(@possible) {
			my $m = $maptype{$newdriver}
				or last RESTOREBUILD;
			if(! $opt->{restore_command}) {
				$opt->{restore_command} = $m->{restore}
					or last RESTOREBUILD;
				if($restore{sqluser}) {
					my $tpl = $m->{user};
					$tpl =~ s/\%s/$restore{sqluser}/g
						and $opt->{restore_command} .= " $tpl";
				}
				if($restore{sqlpass}) {
					my $tpl = $m->{pass};
					$tpl =~ s/\%s/$restore{sqlpass}/g
						and $opt->{restore_command} .= " $tpl";
				}
				$opt->{restore_command} .= ' %s';
				$opt->{restore_command} .= ' < %f';
			}
			if($opt->{create_db} || $CGI::values{create_db}) {
				$opt->{create_command} ||= $m->{create};
				$opt->{create_command} =~ s/\%s/$restore{dbname}/g;
				$opt->{create_command} .= ' 2> /dev/null'
					unless $opt->{create_command} =~ /2\s*>/;
				push @restore, $opt->{create_command};
			}
			else {
				undef $opt->{create_command};
			}
			$opt->{restore_command} =~ s/\%s/$restore{dbname}/g;
			$opt->{restore_command} =~ s/\%f/$possible[0]/g;
			push @restore, $opt->{restore_command};
		}
		else {
			undef $opt->{create_command};
			undef $opt->{restore_command};
		}
	}

	my $did_link;
	my $did_catline;
	RESTORECGI: {
		last RESTORECGI if $restore{linkmode} =~ /none/i;
		my $dest = $restore{cgi_dir};
		my $progname = $restore{cgi_url};
		$progname =~ s:.*/::;
		$dest .= "/$progname";
		my @args = "$restore{ic_dir}/bin/compile_link";
		if($restore{linkmode} =~ /^u/i) {
			push @args, '-u';
			push @args, '-nosuid' if $restore{cgiwrap};
		}
		else {
			push @args, '-i';
			push @args, "-h $restore{linkhost}" if $restore{linkhost};
			push @args, "-p $restore{linkport}" if $restore{linkport};
		}
		push @args, "-o $dest";
		my $cstring = join " ", @args;
		push @restore, "\n$cstring\n";
		$did_link = 1;
	}

	my $newname = $CGI::values{rename} || $catname;
	$restore{newname} = $newname;

	ADDCATLINE: {
		last ADDCATLINE unless $opt->{addcatline} ||= $CGI::values{addcatline};
		$restore{perl} = $^X;
		my $script = <<'EOScript';
#!__PERL__

	use File::Copy;
	use Cwd;

	my $vendroot = '__IC_DIR__';
	my $catalogname = '__NEWNAME__';
	my $cgiurl = '__CGI_URL__';
	my $aliases = '__CGI_ALIASES__';
	my $targfile = "$vendroot/interchange.cfg";
	unless ($vendroot and $catalogname and $cgiurl) {
		die "xfer/modic_cfg.pl: Not all information necessary to add Catalog line.\n";
	}

	my $cur = cwd();

	my $newcfgline = sprintf "%-10s %s %s %s %s\n", 'Catalog',
				$catalogname, $cur, $cgiurl, $aliases;

	my ($mark, @out);
	my $tmpfile;

	$tmpfile= "$targfile.$$";
	if (-f $targfile) {
		File::Copy::copy ($targfile, $tmpfile)
			or die "\nCouldn't copy $targfile: $!\n";
	}	
	else {
		my @cf = ("$targfile.dist", "$vendroot/interchange.cfg.dist");
		my $cf;
		for(@cf) {
			$cf = $_ if -f $_;
		}

		File::Copy::copy($cf, $tmpfile)
			or die "\nCouldn't copy $cf: $!\n";
	}	

	open(CFG, "< $tmpfile")
		or die "\nCouldn't open $tmpfile: $!\n";
	while(<CFG>) {
		$mark = $. if /^#?catalog\s+/i;
		print "\nDeleting old configuration $catalogname.\n"
			if s/^(catalog\s+$catalogname\s+)/#$1/io;
		
		push @out, $_;
	}
	close CFG;

	if ($targfile) {
		open(NEWCFG, ">$targfile")
			or die "\nCouldn't write $targfile: $!\n";
	} else {
		open(NEWCFG, ">$targfile")
			or die "\nCouldn't write $targfile: $!\n";
	}

	$newcfgline = sprintf "%-13s %s %s %s %s\n", 'Catalog',
			$catalogname, $cur, $cgiurl, $aliases;

	if (defined $mark) {
		print NEWCFG @out[0..$mark-1];
		print NEWCFG $newcfgline;
		print NEWCFG @out[$mark..$#out];
	}
	else { 
		print "\nNo catalog previously defined. Adding $catalogname at top.\n";
		print NEWCFG $newcfgline;
		print NEWCFG @out;
	}

	close NEWCFG || die "close: $!\n";
	unlink $tmpfile;

EOScript
		$script =~ s/__([A-Z]\w+?)__/$restore{lc $1}/eg;
		Vend::File::writefile('>xfer/addcatline.pl', $script );
		push @restore, "\nperl xfer/addcatline.pl\n";
		$did_catline = 1;
	}

	my $finmsg = <<EOThis;
Finished the restore script.

You should inspect the output above (if any) in case of errors.
EOThis

	$finmsg .= <<EOThis unless $did_catline;
You will need to add the following line to interchange.cfg if
you haven't done so already:

	Catalog  $newname \$CURDIR $restore{cgi_url}
EOThis

	$finmsg .= <<EOThis unless $did_link;
You will also need to copy an appropriate link program if it is
not already in place. 
EOThis

	push @restore, <<EOThis;
CURDIR=`pwd`
cat <<EOF
$finmsg
And of course you need to restart Interchange.
EOF
EOThis

	Vend::File::writefile('>xfer/restore.sh', join ("\n", @restore, '') );
	Vend::File::writefile('>products/site.txt', join("\n", @vdb, ""));
	chmod 0755, 'xfer/restore.sh';

	my $fstring = join " ", @backups;

	my $cmdstring = "tar -X exclude-files -c -z -f $catname.tar.gz .";
#::logDebug("executing $cmdstring");
	eval {
		system $cmdstring;
	};

	## Don't really care if this fails
	unlink 'products/site.txt';
	rename 'products/existing.site.txt', 'products/site.txt';

	if($?) {
		my $status = $?;
		my $err = $status >> 8;
		my $msg = errmsg("error=%s, status=%s executing dump '%s': %s", $err, $status, $cmdstring, $!);
		::logDebug($msg);
		::logError($msg);
		return $msg if $opt->{show_error};
		return;
	}
	#return join("\n###\n", ::uneval(\%dsn), ::uneval(\%export), $excludestring);
	return 1;
}
EOR