Show install.pl syntax highlighted
#!/usr/bin/perl
BEGIN { use FindBin; use lib "$FindBin::Bin"; }
$| = 1; # do not buffer output on STDOUT
our $VERSION = '1.00';
use strict;
use warnings;
no strict 'refs';
use install::Wizard;
use util;
use Carp;
use Cwd;
use File::Copy;
use File::Path;
use File::Spec::Functions qw(:ALL);
use Getopt::Long;
use Data::Dumper;
use LoadConfig;
# -- INITIALIZE -----------------------------------------------------------------------------
LoadConfig->ADDPATH($FindBin::Bin);
no warnings; # turn off warnings for this block or perl 5.6.0 will complain
our ($wiz, $conf, $args, $lang, $steps, %order, $conffile);
our ($DBH, $FTP, $FTPROOT);
our $FATAL = 0; # if set to true, no more steps will be processed
our $OS = $^O;
our $perlver = sprintf("%vd", $^V);
our @PVER = split(/\./, $perlver);
our $PPMBASE = "http://www.psychostats.com/ppm/" . $PVER[0] . '.' . $PVER[1] . '/'; # windows only
our $inpath = catfile($FindBin::Bin, 'install'); # install path
our $modfile = 'modules_' . ($OS ne 'MSWin32' ? 'linux' : $OS) . '.cfg'; # module in-file
use warnings; # turn them back on ...
GetOptions(
'language=s' => \$args->{lang},
'listlanguages' => \$args->{listlang},
'liststeps' => \$args->{liststeps},
'config=s' => \$args->{config}, # specify a different config to use
'nopause' => \$args->{nopause}, # calls to pause() will not wait for input
'nopaths' => \$args->{nopaths}, # step_theme
'nourls' => \$args->{nourls}, # step_theme
'options|opts=s' => \$args->{options}, # special options that a step might want
'step=s' => \@{$args->{step}}, # valid steps: pm, db, conf, core, theme
'theme=s' => \$args->{theme}, # step_theme
'themeinfoonly' => \$args->{themeinfo}, # step_conf
'useconfonly' => \$args->{useconfonly},
'updateurls' => \$args->{confupdateurls}, # step_web
'updateroots' => \$args->{confupdateroots}, # step_web
'upgrade' => \$args->{upgrade},
'verify' => \$args->{verify}, # step_init
'version' => \$args->{version},
'quick' => \$args->{quick}, # step_theme
'yes' => \$args->{yes},
'no' => \$args->{no},
'reset' => \$args->{reset},
'resetdb' => \$args->{resetdb},
'profiles:s' => \$args->{dbprofiles},
);
if ($args->{reset}) {
$args->{useconfonly} = $args->{nopause} = $args->{yes} = 1;
}
if ($args->{resetdb}) {
$args->{useconfonly} = $args->{nopause} = $args->{yes} = 1;
$args->{step} = [ 'db' ];
}
# if we're performing an upgrade we want to make sure the theme and web files are updated.
if ($args->{upgrade}) {
$args->{useconfonly} = $args->{nopause} = $args->{yes} = 1;
$args->{step} = [ qw(web theme) ];
}
# initialize the wizard
$wiz = new install::Wizard($args);
$conffile = $wiz->{data}{statscfg} = $args->{config} || 'stats.cfg';
if ($args->{version}) {
print "Install version: $VERSION\n";
exit(0);
}
print STDOUT ($OS ne 'MSWin32' ? "Linux/Unix" : "Windows") . " detected (Perl v" . $perlver . ")\n";
{
if ($args->{listlang}) { # we can't use a 'language' string here, so a normal 'print' statement is used
my @langs = map { s/^lang_([^\.]+).+/$1/; $_ } validfiles('install', 'lang_.*\\.cfg');
print "\nValid languages: " . join(', ', sort @langs) . "\n\n";
exit(0);
}
# load language file, prompt the user for a language if there's more then 1
my @langs = $args->{lang} ? ( $args->{lang} ) : map { s/^lang_([^\.]+).+/$1/; $_ } validfiles('install', 'lang_.*\\.cfg');
die("*** FATAL *** No language files found! Aborting installation!") unless @langs; # no language files?
my $l = $langs[0];
my $langstr = "Languages available: " . join(", ", @langs);
if (@langs > 1) {
while (1) {
wraptext($langstr);
$l = lc(promptfor("Choose your language [$l]: ", $l));
last if grep { /^\Q$l\E$/ } @langs; # make sure user response is a valid language name
print "\n** Invalid response, please choose from the list below\n";
}
}
$wiz->{data}->{language} = $wiz->{data}->{lang} = $l;
$lang = loadconfig(filename => catfile("install", "lang_$l.cfg"));
wraptext($lang->{languageloaded});
}
$conf = LoadConfig->load( location => $wiz->{data}->{statscfg}, fatal => 0, warning => 0 );
if (!$conf or !scalar keys %$conf) {
wraptext($lang->{nostatscfg});
exit(1);
}
# initialize the 'install' section of the config ...
$conf->{install} = {} unless defined $conf->{install};
$conf->{install}{IDX} = 99999999;
$conf->{install}{SECTION} = "INSTALL";
$wiz->{conf} = $conf;
$wiz->{lang} = $lang;
# -- gather all valid install modules (steps) ------------------------------------------------
{
%$steps = map { ((/^step_(.+?)\.inc$/)[0] => catfile('install',"$_")) } validfiles('install', '^step_.+?\\.inc$');
if ($args->{liststeps}) {
$wiz->{data}->{steplist} = join(', ', sort keys %$steps);
wraptext($lang->{liststeps});
exit(0);
}
# combine steps specified as '-step step1,step2' (instead of just: -step step1 -step step2)
my @steps = ();
foreach my $s (@{$args->{step}}) {
push(@steps, split(/,/, $s));
}
$args->{step} = [ @steps ];
if (@{$args->{step}}) { # remove all steps that are not specified on the command line
my %valid = map { lc($_), 1 } @{$args->{step}};
foreach my $k (keys %$steps) {
delete $steps->{$k} unless $valid{$k};
}
}
delete $steps->{cgi}; # explicitly delete this step, as it will cause problems if people upgrade 2.0.1 over 2.0
foreach (keys %$steps) {
$wiz->{data}->{step} = $_;
if (do $steps->{$_}) {
my $o;
eval { my $init = "step_${_}_init"; $o = &$init; };
if ($@) {
$wiz->{data}->{steperror} = $wiz->{data}->{steperr} = $@;
wraptext($lang->{err_stepinit});
delete $steps->{$_}; # remove step
# exit(1);
} else {
$o++ while (exists $order{$o}); # increment the order value until we find the next unique value
$order{$o} = $_; # set the order of the step
}
} else {
$wiz->{data}->{step} = $_;
$wiz->{data}->{error} = $@;
wraptext($lang->{err_stepload});
exit(1);
}
}
if (!scalar keys %$steps) {
wraptext($lang->{err_nosteps});
exit(1)
}
if (not scalar @{$args->{step}}) {
print "\n", hline(), "\n";
wraptext($lang->{installinit});
print hline(), "\n\n";
$wiz->pause(1);
}
}
# -- MAIN -----------------------------------------------------------------------------------
# We simply loop through all of the steps in order
my $total = scalar keys %order;
my $cur = 0;
foreach my $o (sort { $a <=> $b } keys %order) {
$cur++;
my $func = sprintf("step_%s", $order{$o});
my $res = &$func;
# pause after each step
if (!$args->{nopause} and (!$res or $res != -1)) { # do not pause if the step returned -1
$wiz->pause(1, ($cur<$total and !$FATAL) ? "\nPress enter to continue with next step" : "\nPress enter to exit installation." );
}
exit(1) if $FATAL;
}
wraptext($lang->{done});
# --- support functions ---------------------------------------------------------------------
# Since I seem to mistype this a lot, this sub is here simply as an alias
sub wraptext {
return $wiz->wraptext(@_);
}
# -----------------------------------------------------------------
sub hline {
my $pat = shift || '- ';
my $width = shift || $wiz->{SCREENWIDTH};
return $pat x int( $width / length($pat) );
}
# -----------------------------------------------------------------
# Any 'step' that requires a DB connection should call this first to initialize the DB
# This only makes sure the DBI is present and is 'required' into our namespace.
sub initdb {
return 1 if defined $DBH; # we're already inialized, return current handle
eval "require DBI";
if ($@) {
wraptext($lang->{err_dbi});
return undef;
}
return 1;
}
# -----------------------------------------------------------------
sub validdirs {
my ($path) = @_;
my @list = ();
$path = catfile($FindBin::Bin, $path, '');
if (opendir(D, $path)) {
@list = grep { !/^\./ and -d catfile($path, $_) } readdir(D);
closedir(D);
};
return wantarray ? @list : [ @list ];
}
# -----------------------------------------------------------------
sub validfiles {
my ($path, $filepattern) = @_;
my @list = ();
$path = catfile($FindBin::Bin, $path, '');
$filepattern ||= '.';
# print "Searching: $path\n";
if (opendir(D, $path)) {
@list = grep { /$filepattern/ and -e catfile($path, $_) } readdir(D);
closedir(D);
};
return wantarray ? @list : [ @list ];
}
# -----------------------------------------------------------------
sub trim {
my ($str) = @_;
$str =~ s/^\s+//;
$str =~ s/\s+$//;
return $str;
}
# -----------------------------------------------------------------
# not a very effiecent sorting routine, but it does its purpose and is only used once on a small set of files
sub pathsort($$) {
my ($a,$b) = @_;
my ($apath, $afile) = (splitpath($a))[1,2];
my ($bpath, $bfile) = (splitpath($b))[1,2];
return lc $apath cmp lc $bpath || lc $afile cmp lc $bfile;
}
# -----------------------------------------------------------------
sub processpath {
my ($path, $nosubdir) = @_;
my @list = ();
foreach my $f (glob($path)) {
if (-d $f) {
push(@list, processpath("$f/*")) unless $nosubdir;
} else {
push(@list, $f) if -e $f;
}
}
return @list;
}
# -----------------------------------------------------------------
sub writeconfig {
my ($c, $filename) = @_;
my ($sub, $key, $value, @list, @sublist);
$filename ||= $conffile;
# my $filename = $conffile; # $conffile is a global var (every programming teachers' nightmare)
my $length = 0;
if (open(F, ">$filename")) {
# first we write all global variables ...
@list = sort grep { ref $c->{$_} ne 'HASH' } keys %$c;
foreach (@list) { # get longest length of variables
$length = length($_) if length($_) > $length;
}
foreach $key (@list) {
print F _writevar($key, $c->{$key}, '', $length);
}
# now we write all non-global variables ...
@list = sort { ($c->{$a}{IDX} || 0) <=> ($c->{$b}{IDX} || 0) } grep { ref $c->{$_} eq 'HASH' } keys %$c;
foreach $key (@list) {
print F "\n[" . (defined $c->{$key}{SECTION} ? $c->{$key}{SECTION} : $key) . "]\n";
@sublist = sort keys %{$c->{$key}};
$length = 0;
foreach (@sublist) { # get longest length of variables
$length = length($_) if length($_) > $length;
}
foreach $sub (@sublist) {
next if uc $sub eq $sub;
print F _writevar($sub, $c->{$key}{$sub}, ' ', $length);
}
}
close(F);
# $wiz->{conf} = $c;
} else {
return 0;
}
return 1;
}
# -----------------------------------------------------------------
# internal func for writeconfig(), do not call directly
sub _writevar {
my ($key, $value, $prefix, $length) = @_;
my $line = "";
if (ref $value eq 'ARRAY') {
$line .= _writevar($key, $_, $prefix, $length) foreach @$value; # write each array element seperately
} else {
$line = $length ? sprintf("%-${length}s ", $key) : "$key ";
if ($value =~ /\n/) { # if there are newlines, we treat the variable as a var >> END block
$value .= "\n" unless $value =~ /\n$/; # add newline if its not present
$line .= ">> END\n" . $value . "END\n";
} elsif ($value =~ /^\s+/ or $value =~ /\s+$/) { # if there are leading/trailing spaces we surround it with quotes
$line .= "= \"$value\"\n";
} else { # just print it out normally
$line .= "= $value\n";
}
}
return defined $prefix ? $prefix . $line : $line;
}
# -----------------------------------------------------------------
sub confupdate {
my ($c,$doupload,$silent) = @_;
# return if $args->{useconfonly};
$wiz->wraptext($lang->{updateconf}) unless $silent;
writeconfig($c);
# if ($doupload and $wiz->ftpconnect) {
# my $ftp = $wiz->{ftp};
# my $pwd = $ftp->pwd;
# $wiz->ftpcwdroot;
# $ftp->cwd($c->{install}{installdir}) if $c->{install}{installdir};
# $wiz->ftpuploadfiles([ 'stats.cfg' ]);
# $wiz->{ftp}->site('chmod', '644', 'stats.cfg');
# }
}
# ----------------------------------------------------------------------------------------------------
sub uploadfiles {
my ($themeopt, $pathprefix, $list) = @_;
my %created = (); # keep track of what directories were created already
my $total = 0;
my $ftp = $wiz->{ftp};
$total += -s $_ || 0 foreach @$list;
my $sum = 0;
my $destroot = $conf->{theme}{$themeopt}; # 'itemroot'
$destroot =~ s|\\|/|g;
$destroot .= '/' unless $destroot =~ m|/$|;
$wiz->{data}{destroot} = $destroot;
$wiz->wraptext($lang->{web_ftpdestroot});
select(undef, undef, undef, 1.0);
$wiz->wraptext($lang->{nofiles}) unless @$list;
$ftp->binary;
foreach my $file (@$list) {
my ($vol, $path, $filename) = splitpath($file);
my (@parts, $echofile, $dest);
$file =~ s|\\|/|g; # convert all \ to /
$path =~ s|\\|/|g;
@parts = split(/\/+/, $path); # split parts by '/'
1 while @parts and shift(@parts) ne $pathprefix; # remove "/web/images/prefix"
$echofile = join('/', @parts, $filename);
$path = join('/', $destroot, @parts);
$dest = join('/', $path, $filename);
$dest =~ s|/+|/|g;
$sum += -s $file;
if ($path and !$created{$path}) {
$created{$path} = 1;
$ftp->mkdir($path, 1);
chomp($wiz->{data}{error} = $ftp->message);
}
# upload the file ....
$wiz->{data}{file} = $echofile;
$wiz->{data}{filesize} = sprintf("%10s", abbrnum(-s $file,2));
$wiz->{data}{pct} = sprintf("%6s", calcpct($sum, $total));
$wiz->wraptext($lang->{ulfile}, {trimtail => 1});
my $ok = $ftp->put($file, $dest);
chomp($wiz->{data}{error} = $ftp->message) if !$ok;
$wiz->wraptext( $ok ? $lang->{ok} : $lang->{ulfileerr} );
}
$wiz->wraptext($lang->{uploaddone});
}
# ----------------------------------------------------------------------------------------------------
sub copyfiles {
my ($themeopt, $pathprefix, $list) = @_;
my $total = 0;
$total += -s $_ || 0 foreach @$list;
my $sum = 0;
my $destroot = $conf->{theme}{$themeopt}; # 'itemroot'
$destroot =~ s|\\|/|g;
$destroot .= '/' unless $destroot =~ m|/$|;
$wiz->{data}{destroot} = $destroot;
$wiz->wraptext($lang->{web_destroot});
$wiz->wraptext($lang->{nofiles}) unless @$list;
select(undef, undef, undef, 1.0);
foreach my $file (@$list) {
my ($vol, $path, $filename) = splitpath($file);
my (@parts, $echofile, $dest);
$file =~ s|\\|/|g; # convert all \ to /
$path =~ s|\\|/|g;
@parts = split(/\/+/, $path); # split parts by '/'
1 while @parts and shift(@parts) ne $pathprefix; # remove "/web/images/prefix"
$echofile = join('/', @parts, $filename);
$path = join('/', $destroot, @parts);
$dest = join('/', $path, $filename);
$dest =~ s|/+|/|g;
$sum += -s $file;
if ($path and !-d $path) {
eval { mkpath($path) };
chomp($wiz->{data}{error} = $@);
}
# copy the file ....
$wiz->{data}{file} = $echofile;
$wiz->{data}{filesize} = sprintf("%10s", abbrnum(-s $file,2));
$wiz->{data}{pct} = sprintf("%6s", calcpct($sum, $total));
$wiz->wraptext($lang->{copyfile}, {trimtail => 1});
my $ok = copy($file, $dest);
chomp($wiz->{data}{error} = $!) if !$ok;
$wiz->wraptext( $ok ? $lang->{ok} : $lang->{copyfileerr} );
}
$wiz->wraptext($lang->{copydone});
}
# -----------------------------------------------------------------
1;
See more files for this project here