#!/usr/bin/perl -w

# NOTE: If you are trying to download this script, please press your
# browser's "Back" button, and right-click on the link, selecting "Save
# Link As..." or "Save Target As..." to save this script to your disk.

# NOTE: If you have installed this script in your CGI area and see this
# displayed in your web browser, it means your web server does not
# recognize this as a script to be executed. Try adding a .cgi or .pl
# extension to the filename, then give it another shot. (And on unix-like
# systems (e.g. linux, Mac OS X, Solaris), make sure the file has execute
# permission set.)



# Upgrade Calcium Demo to registered version
# If no write perm in current dir, just warn and exit.

# Present form to get info from user:
#  - location of installation dir, if default 'CalciumDirXXX' not found
#  - registration information

# If tar file not present, use LWP to access the download script at BBSW.
# Download file depends on registration information.

# Extract it into the Calcium 'upgrades' dir.

use strict;
use CGI::Carp qw(fatalsToBrowser);
use 5.004;
use CGI 2.42;
use File::Copy;
use Cwd;

$|++;

my $bbswURL = 'http://www.brownbearsoftware.com/cgi-bin/4.0/upgrade/getFiles.pl';
my $thisDir = cwd || '.';
my $instDir = 'CalciumDir40';
my $tarFile = 'CalciumUpgrade.tar';

my $styles = <<ENDCSS;
body {background-color: #d9d2d9;
      background-image: url(http://brownbearsw.com/images/background-paw.jpg);
      font-family:      verdana,arial,helvetica;
      margin:           50px;
      margin-top:       10px;}
.formLabel {font-weight: bold;}
.bottomNotes {font-size: smaller;}
.ServerResponse {font-weight: bold; margin-left: 50px}
ENDCSS

my $cgi = CGI->new;
print $cgi->header;
print $cgi->start_html (-title   => 'Calcium 4.0 Upgrade',
                        -style   => {-code => $styles});
print $cgi->h1 ('<center>Upgrade Calcium 4.0</center>');

my ($perlTar, $tarCommand, $haveZlib, $gzCommand) = checkTarStuff();

# Look for installation directory
my $defaultInstDir = -d $instDir ? $instDir : undef;


if ($cgi->param ('Retrieve')) {
    my $upgradeDir = $cgi->param ('upgradeDir');

    $upgradeDir = "$upgradeDir/upgrades";
    if (!-d $upgradeDir) {
        quit ('<b>Problem:</b>' .
              " The upgrade directory '$upgradeDir' does not exist.");
    }
    if (!-w $upgradeDir) {
        my $uname;
        eval {$uname = getpwuid ($>)};
        $uname = $uname ? "('$uname')" : '';
        quit (qq {<b>Problem:</b> Not allowed to write to the upgrade directory
                  on the web server: <b>$upgradeDir</b>

              <p>This script needs to be able to write files to the
              Calcium 'upgrades' directory. The user that the web server
              runs as $uname needs write permission.</p>

              <p><b>Solution:</b> Change file permissions on the directory.});
    }

    my $regName = $cgi->param ('regName');
    my $regPass = $cgi->param ('regPass');
    getAndInstallAndExit ($regName, $regPass, $upgradeDir);
}


# Display form
unless (eval {require LWP::Simple}) {
    quit (qq {Sorry, this server doesn\'t have the
              library that\'s needed to download the upgrade package.
              <p>You can get the package here:<br>
              <a href=$bbswURL>$bbswURL.</a> </p>},
          'hideBack');
}

print qq {<p>This procedure will upgrade your Calcium demo installation to
          the licensed version you\'ve purchased. Any data and settings you
          already have will not be affected.</p> <p>Fill out the form and
          press the "Do Upgrade" button; the necessary upgrade files will
          be downloaded from the Brown Bear Software web site and installed
          on this server.</p>};
print $cgi->startform;
my %labels = (regName    => 'Registration Name',
              regPass    => 'Registration Password',
              upgradeDir => 'Calcium installation directory');
my %defaults = (upgradeDir => $defaultInstDir);
my @rows;
foreach (qw /regName regPass upgradeDir/) {
    push @rows, $cgi->Tr ($cgi->td ({-class => 'formLabel'},
                                    $labels{$_} . ':'),
                          $cgi->td ($cgi->textfield (-name    => $_,
                                                     -default =>
                                                            $defaults{$_})));
}
print $cgi->table (@rows);

print qq {<p><b>Note:</b> couldn\'t find the default Calcium installation
          directory named "$instDir".</p><p>You need to specify the
          path to the installation directory containing the Calcium
          'Calendar', 'Operation', 'upgrades' (etc.) directories. Also, the
          user the web server runs as must be able to write there. </p>}
    unless ($defaultInstDir);

print '<br>';
print $cgi->submit (-name  => 'Retrieve',
                    -Value => 'Do Upgrade');
print $cgi->endform;
print '<br><br>';

print '<hr width="90%">';

print qq {<div class="bottomNotes"><p>Or, you can install the upgrade files
          yourself. First, follow this link to download the upgrade
          package; you'll need to enter your username and password:</p>

          <p style="margin-left: 20px;"><a href=$bbswURL>$bbswURL</a></p>
          <p>Once you have the package, you'll need to extract the files
          from it into the "upgrades" directory of your Calcium
          installation.</p></div>};

print $cgi->end_html;
exit;


# ----------------------------------------------------------------------
sub quit {
    my ($message, $hideBack) = @_;
    print $message;
    print qq (<br><p>Use your browser\'s "Back" button to try again.<p>)
        unless ($hideBack);
    print $cgi->end_html;
    exit;
}

sub checkTarStuff {
    # First, see if we've got Tar, (and Zlib)
    my ($perlTar, $tarCommand);
    if (eval {require Archive::Tar}) {
        $perlTar++;
    } elsif (-x '/bin/tar' or -x '/usr/bin/tar') {
        $tarCommand = (-x '/bin/tar') ? '/bin/tar' : '/usr/bin/tar';
    } else {
        quit (qq {<p>Sorry, your server can\'t seem to handle 'tar' files;
                  you can\'t use this script to do the upgrade.</p>

                  <p>Instead, you can follow the simple instructions here:
                  <a href="$bbswURL">upgrade instructions</a></p>},
             'hideBack');
    }

    my ($haveZlib, $gzCommand);
    if ($perlTar) {
        if (eval {require Compress::Zlib}) {
            $haveZlib = 1;
        }
    } else {
        foreach ('/bin/gunzip', '/usr/bin/gunzip', '/usr/local/bin/gunzip') {
            next unless -x $_;
            $haveZlib = 1;
            $gzCommand = $_;
            last;
        }
    }
    return ($perlTar, $tarCommand, $haveZlib, $gzCommand);
}

sub getAndInstallAndExit {
    my ($name, $pass, $localDir) = @_;

    $name = _escape ($name);
    $pass = _escape ($pass);

    my $localFile = "$localDir/$tarFile";

    my $url = "$bbswURL?regName=$name;regPass=$pass";

    # Retrieve file from BBSW
    print "<p>Retrieving upgrade package from Brown Bear Software; " .
          "please wait...</p>\n";

    require LWP::Simple;
    my $status = LWP::Simple::getstore ($url, "$localFile");
    if (HTTP::Status::is_error ($status)) {
        quit ("Sorry, couldn't retrieve the file. Response from server: " .
              '<div class="ServerResponse">' .
               HTTP::Status::status_message ($status) . '</div>');
    }
    my $size = -s $localFile;
    if ($size < 1000) {         # if small, it's a message, e.g. "bad passwd"
        open (MESSAGE, $localFile)
            or quit ("Sorry, couldn't retrieve the file.");
        my @message = <MESSAGE>;
        my $message = join '<br>', @message;
        quit ("Sorry, couldn't retrieve the file. Response from server: " .
              '<div class="ServerResponse">' .
              "<p>$message</p>" . '</div>');
    }

    chdir $localDir or quit ("Couldn't cd to dir $localDir: $!");

    if ($perlTar) {
        # Need to ensure dirs are writable, or extraction fails...
        my $tar = Archive::Tar->new ($tarFile);
        my @filenames = $tar->list_files;
        foreach (@filenames) {
            $tar->extract ($_);
            chmod 0755, $_ if (-d $_);
        }
    } else {
        system ("$tarCommand", "xf", "$tarFile");
        quit ("<p>Sorry, extracting '$tarFile' into '$localDir' failed.</p>" .
              '<p>Perhaps a file permissions problem?</p>') if $?;
    }

    chdir $thisDir;
    my $message = '<p>OK, upgrade complete!</p>';
    foreach ('Calcium40.pl', 'Calcium.pl', 'Calcium40.cgi', 'Calcium.cgi') {
        next unless (-f and -x );
        $message .= qq (<p>Go back to <a href="$_">$_</a>.</p>);
    }
    quit ($message, 'noback');
}

sub _escape {
    my $arg = shift;
    return $arg unless $arg;
    $arg=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
    return $arg;
}