# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Update
#   Author: Jason Rhinelander
#   CVS Info : 087,071,086,086,085      
#   $Id: Update.pm,v 1.13 2005/12/08 03:45:39 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   Module to interact with Gossamer Threads update server.
#

package GT::Update;
use strict;
use vars qw/$VERSION @ISA @EXPORT_OK %EXPORT_TAGS %ERRORS/;
use Carp qw/croak/;
use GT::WWW;
use GT::TempFile;
use GT::File::Tools qw/mkpath copy move/;
use Exporter();
use Symbol qw/gensym/;
use constants
    OPTIONAL => 1,
    RECOMMENDED => 2,
    CRITICAL => 3,
    VERSION => 4,

    GTUPDATE => 'http://www.gossamer-threads.com/perl/updates/update.cgi',
    GTUPDATES => 'https://www.gossamer-threads.com/perl/updates/update.cgi';

$VERSION = 1.1;
@ISA = qw/Exporter/;
@EXPORT_OK = qw/OPTIONAL RECOMMENDED CRITICAL VERSION %ERRORS/;
%EXPORT_TAGS = (
    severity => [qw/OPTIONAL RECOMMENDED CRITICAL VERSION/]
);
%ERRORS = (
    100 => 'Success; update information follows',
    101 => 'Success, update file follows',

    200 => 'Invalid registration number',
    201 => 'Registration number already in use',
    202 => 'Registration number not enabled',
    203 => 'Admin path does not match path stored on update server; the stored admin path can be reset from the Gossamer Threads license download area',
    204 => 'Admin path does not match path stored on update server',

    300 => 'Invalid product',
    301 => 'Invalid product version',
    302 => 'Invalid update file requested',
    303 => 'Insufficient update information',
    304 => 'Requested update does not exist',

    400 => 'Internal update server error; please try again later',
    401 => 'Update system down temporarily for upgrades; please try again later'
);

my $https = eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1; };

sub new {
    my ($class, %opts) = @_;
    bless my $self = {}, $class;

    for (keys %opts) {
        croak "Invalid option $_" unless /^[a-z][a-z_]+$/ and $self->can($_);
        $self->$_(ref $opts{$_} eq 'HASH' ? %{$opts{$_}} : ref $opts{$_} eq 'ARRAY' ? @{$opts{$_}} : $opts{$_});
    }
    $self;
}

sub debug_level {
    my $self = shift;
    if (@_) {
        $self->{debug} = shift;
    }
    $self->{debug};
}

sub reg_number {
    my $self = shift;
    if (@_) {
        $self->{reg_number} = shift;
    }
    $self->{reg_number};
}

# Sets the program initialization path - typically the same path passed to
# Product::init("...").
sub init_path {
    my $self = shift;
    if (@_) {
        $self->{init_path} = shift;
    }
    $self->{init_path};
}

# Sets the product name - i.e. Links for Gossamer Links, GMail for Gossamer
# Mail, GForum for Gossamer Forum, etc.  This correlates to the main .pm file,
# typically located in the admin or private lib path, and will be passed to the
# server as the product name to check for updates.  It is also used for the
# package in the Product::init() line added to CGI scripts.
sub product {
    my $self = shift;
    if (@_) {
        $self->{product} = shift;
    }
    $self->{product};
}

# Sets/retrieves the current product version.
sub version {
    my $self = shift;
    if (@_) {
        $self->{version} = shift;
    }
    $self->{version};
}

# Sets the installed updates.  The installed updates should be in the form of a
# hash with the version as the key, and a hash reference of { ID => update
# information hash reference } pairs as the value.  Not required for checking
# updates, required for downloading.  Will only return installed updates when
# called in list context, otherwise installed updates are set (even if no
# update pairs are passed in - to nothing).
#
# Note that after installing updates, you must retrieve and store this value as
# it changes when updates are installed.
sub installed {
    my ($self, %installed) = @_;
    if (wantarray) {
        return %{$self->{installed}};
    }
    else {
        $self->{installed} = \%installed;
    }
}

# Sets the path to perl - this will be used as the first line of CGI scripts,
# and is required to install updates.
sub perl_path {
    my $self = shift;
    if (@_) {
        $self->{perl_path} = shift;
    }
    $self->{perl_path};
}

# Takes a hash of one or more of the following keys:
#
# script, library, template, static, fixed, version
#
# The individual meanings are described below.
#
# Each of the above can take either a single path, or a hash reference of named
# paths.  For example:
#
# $updater->paths(
#     script => '/path/to/cgis',
#     library => { products => '/path/to/product/libs', gt => '/path/to/gt/libs' },
#     template => { '' => '/path/to/product/templates' }
# );
#
# The names of the directories aren't important, so long as they match up with
# the named paths on the update server.  Using the single path form is
# equivelant to using a hash reference with a key of '' for the path - the
# script_path value in the above example could instead be written as
# C<{ '' =E<gt> '/path/to/product/templates' }> with no change in
# functionality.  Each of the three paths settings (script, library, and
# template) are as follows:
#
# script
# ------
# Replacements for files listed in C<script> will be replaced, but four things
# will be read from the replaced file and substituted into the new file:
# - the first #! line (typically #!/usr/bin/perl)
# - any 'use lib' lines
# - any 'Product::init(...)' line, where 'Product' comes from the
#   ->product_package setting.
#
# library
# -------
# Replacements for C<library> files are replaced without any special
# substitutions.
#
# template
# --------
# C<template> replacements will be replaced without any substitutions.  An
# attempt to automatically merge template changes into local templates may be
# added in the future.
#
# static
# ------
# C<static> replacements are used for static content (i.e. .js, .css,
# images, etc.) that will be replaced.
#
# fixed
# -----
# C<fixed> content is like C<static>, except that fixed files will only be
# added if not already present, never replaced.  Both C<fixed> and C<static>
# can contain the same value(s).
#
# version
# -------
# C<version> is the single location where the installer .tar.gz contents will
# be extracted for a version upgrade.  Typically, this should be a
# password-protected path, such as the 'admin' script_path.
#
sub paths {
    my ($self, %opts) = @_;

    while (my ($which, $path) = each %opts) {
        croak "Invalid path setting '$_'" unless $which =~ /^(script|library|template|static|fixed|version)$/;
        if (ref $path eq 'HASH') {
            $self->{paths}->{$1} = { %$path };
        }
        elsif (not ref $path) {
            $self->{paths}->{$1} = { '' => $path };
        }
        else {
            croak "Invalid path setting: $path";
        }
    }

    $self->{paths};
}

# This handles file replacements that need to be made.  For example, Gossamer
# Links replaces <%VERSION%> in Links.pm with the Gossamer Links version.  It
# takes a hash that looks like:
#     pathtype => {
#         subpath => {
#             filepath => {
#                 'STRING' => 'REPLACEMENT'
#             }
#         }
#     }
# pathtype is script, library, etc. as above, subpath is one of the subpath
# names passed to paths(), filepath is the path relative to the subpath, and
# the STRING and REPLACEMENT are ordinary Perl strings.
#
# For example, to replace '!!FOO!!' in Gossamer Links's Links/Test.pm with
# 'BAR', you would use:
#     library => { '' => { 'Links/Test.pm' => { '!!FOO!!' => 'BAR' } } }
sub replacements {
    my ($self, %opts) = @_;

    $self->{replacements} = \%opts if keys %opts;

    $self->{replacements};
}
# Sets the path in which to store backup files before overwriting them.  Files
# will be stored in the format:
# $updateid-$time-$filetype-$filesubtype-relative-path-to-filename.backup
# So, for a "script" -> "admin" file update with ID 117 to cron/abc.cgi that
# occurs at unix time 1234567890, the original file will be backed up in this
# directory as:
# 117-1234567890-script-admin-cron-abc.cgi.backup
sub backup_path {
    my $self = shift;

    $self->{backup_path} = shift if @_;

    $self->{backup_path};
}

# If set, testing updates will be displayed.  This is only for internal
# Gossamer Threads use - enabling this will list updates that may be broken.
sub testing {
    my $self = shift;

    $self->{testing} = !!shift if @_;

    $self->{testing};
}

# With no arguments:
#   Connects to the GT update server, checks for updates.  Returns undef if a
#   server connection couldn't be established, or if the server returns an
#   unrecognized response.  Returns 0 if the server connection was established
#   and the server returned an error code (check ->server_status in that case).
#   Returns a list of hash references containing update information otherwise.
#
#   Normally, if a check has already been performed, the data is returned
#   without actually checking the server again.  To force a recheck, pass a
#   single true argument to this method.
#
# With a single argument - a version:
#   Looks at the currently installed updates for the given version, returns
#   information on all installed updates without using the update server.
#
sub check {
    my ($self, $version) = @_;

    return @{$self->{updates}} if $self->{updates} and not $version;

    my @must_have = qw/reg_number init_path product version/;
    for (my $i = 0; $i < @must_have; $i++) {
        splice @must_have, $i--, 1 if $self->{$must_have[$i]};
    }
    croak "The following must be set before calling ->check: @must_have" if @must_have;

    my @updates;
    if ($version) {
        my %installed = %{$self->{installed}->{$version} ||= {}};
        my (%updates, %revdeps);
        for (keys %installed) {
            my %info = %{$installed{$_}};
            $info{id} = $_;
            for my $dep (@{$info{deps}}) {
                push @{$revdeps{$dep}}, $_;
            }
            $updates{$_} = \%info;
            $info{restore_possible} = 1;
            for (@{$info{files}}) {
                if ($_->{backup} and !-r $_->{backup}) {
                    $info{restore_possible} = undef;
                    $info{reversible} = undef;
                    last;
                }
            }
        }

        # - if A depends on B, and A is irreversible, B is also irreversible.
        # - if A depends on B, and A is unique, B cannot be uninstalled (yet).
        for (keys %updates) {
            my @revdeps = @{$revdeps{$_} || []};
            $updates{$_}->{revdeps} = \@revdeps;
            next unless @revdeps and $updates{$_}->{reversible};
            my %checked = map { $_ => 1 } @revdeps;
            for my $revdep (@revdeps) {
                push @revdeps, grep !$checked{$revdep}++, @{$revdeps{$revdep}} if $revdeps{$revdep};
                if (!$updates{$revdep}->{reversible}) {
                    $updates{$_}->{reversible} = undef;
                    $updates{$_}->{irreversible_dep} = 1;
                    last;
                }
                elsif ($updates{$revdep}->{unique}) {
                    $updates{$_}->{revdeps_first} = 1;
                }
            }
        }
        @updates = map GT::Update::Update->new(%{$updates{$_}}, paths => $self->paths), sort { $a <=> $b } keys %updates;
    }
    else {
        @updates = $self->_download_update_info();
        return undef if @updates == 1 and not defined $updates[0];

        my %available = map { $_->{id} => $_ } @updates;

        my %revdeps;
        for my $update (@updates) {
            for my $dep (@{$update->{deps}}) {
                push @{$revdeps{$dep}}, $update->{id};
            }
        }

        for my $update (@updates) {
            my $id = $update->{id};
            $update->{revdeps} = $revdeps{$update->{id}} || [];
            if ($self->{installed}->{$self->{version}}->{$id} and $update->{severity} != VERSION) {
                $update->{installed} = 1;
                next;
            }

            my @deps = @{$update->{deps}};

            # @req tracks the dependencies that must be installed before this update
            my @req;
            for (@deps) {
                if (!exists $self->{installed}->{$self->{version}}->{$_}) {
                    push @req, $_;
                    $update->{deps_first}++ if $update->{unique};
                }
            }

            if ($update->{deps_first}) {
                for ($id, @{$update->{revdeps}}) {
                    $available{$_}->{deps_first} = 1;
                }
            }
            $update->{requires} = \@req;
        }

        @updates = map GT::Update::Update->new(%$_, paths => $self->paths), @updates;
    }

    # Future operations that read more data items could go here; $response has
    # had the update data removed.


    $self->{updates} = \@updates;
    return @updates;
}

sub _download_update_info {
    my $self = shift;
    my $www = GT::WWW->new;
    $www->debug_level($self->{debug}) if $self->{debug};

    $www->url($https ? GTUPDATES : GTUPDATE);
    $www->parameters(
        reg_number => $self->{reg_number},
        init_path => $self->{init_path},
        product => $self->{product},
        product_version => $self->{version},
        update_version => $VERSION,
        $self->{testing} ? (testing => 1) : ()
    );

    my $response = $www->get or return $self->error("Unable to connect to update server: " . $www->error);
    $response->status or return $self->error("Received invalid response from update server: " . $response->status);

    $response = "$response";

=for comment

The server response structure is expected as follows:

The first line must be:
GTUPDATE

The next line starts with a number indicating the status followed by a space
and status message, such as:
100 Success

1xx codes indicate success, 2xx codes indicate a problem with the registration
data, 3xx indicate a problem with the system data (such as an unknown product
or product version), 4xx indicate a server-side error.  See the %ERRORS hash
for the precise error responses.

Following a 1xx response are a series of updates, explain below.

=cut
    $response =~ s/^GTUPDATE\n(\d{3}) (.+)\n// or return $self->error("Received invalid data from update server");

    my ($code, $message) = ($1, $2);
    $self->{server_status} = $code;
    $self->{server_status_message} = $message;

    if ($code < 100) {
        return $self->error("Received invalid status code from server: $code $message");
    }
    elsif ($code >= 200) {
        return $self->error("Server returned error code: $code $message");
    }

=for comment

The server has responded with a success message, and data regarding available
updates follows.  That data is as follows:

    RESPONSE = ( <UPDATE SIZE> <UPDATE> )* 4xNULL

    UPDATE SIZE = 4-byte big-endian packed integer, indicating size of update

    UPDATE = <ID> <SEVERITY> <REVERSIBLE> <UNIQUE> ( <REQ ID> )* 4xNULL
             <TITLE SIZE> <TITLE> ( <FILE INFO SIZE> <FILE INFO> )* NULL
             <DESCRIPTION SIZE> <DESCRIPTION>

    ID = 4-byte packed update ID in "network" (big-endian) order
    SEVERITY = 1-byte packed update severity value
    REVERSIBLE = 1 or 0, packed in 1 byte, indicating a reversible update
    UNIQUE = 1 or 0, packed in 1 byte, indicating a unique update
    REQ ID = 4-byte big-endian packed integer indicating that this update depends on another having been installed
    TITLE SIZE = 1-byte integer value indicating length of title (0 - 255)
    TITLE = the update title
    FILE INFO SIZE = 1-byte packed integer indicating the length of the file info (technically 1-255, though really more like 12-255)
    FILE INFO = Updated file information, in format below
    NULL = a null (0) byte
    DESCRIPTION SIZE = 2-byte packed big-endian integer
    DESCRIPTION = description of update

    FILE INFO = <FILE ID> ':' <TYPE> ':' <LOCATION> ':' <MODE> ':' <RELATIVE PATH>

    FILE ID = A unique file ID assigned by the server OR the constant string 'code', for the 'code' TYPE below.
    TYPE = The path type, one of 'script', 'library', 'template', 'static', 'fixed', 'version', or 'code'.
    LOCATION = The application-specific subpath of the above TYPE - for example 'user' might go with a 'script' type.  Can be empty.
    MODE = The mode in octal representation (e.g. 0644)
    RELATIVE PATH = The path, relative to the TYPE->LOCATION path, of the file

The severity value can (currently) be one of:

    1 - an "optional" update
    2 - a "recommended" update
    3 - a "critical" update
    4 - a version upgrade

Other values maybe used in the future.  C<ID> is a numeric value guaranteed to
be constant and unique for every update.  Reversible is a 1/0 value indicating
whether or not the update can be reversed.  Generally, this is 0 for version
upgrades and updates that make database changes, and 0 for regular code
updates.  Unique is also a 1/0 value indicating whether or not this update
should be applied by itself - this is generally 1 for version upgrades and 0
for everything else.

So, with a paths argument of:

$updater->paths(
    script_path => { user => '/path/u', admin => '/path/a', cron => '/path/c', tools => '/path/t' },
    template_path => '/path/tpl',
    library_path => '/path/admin'
);

The following data (<4-..> indicates a packed 4-byte number, <2-..> indicates a
packaged 2-byte integer, <..> indicates a packed 1-byte integer; newlines have
been added for readability, and would not be contained in the actual data):

<4-263><4-131><3><1><0><4-0><12>Homepage fix<27>script:admin:0755:admin.cgi
<34>234:template::0644:admin/home.html<32>235:library::0644:GT/Template.pm
<22>236:library::0777:tmp/<0><2-116>This fixes a problem with the home page 
displaying some wrong information, and creates the missing lib/tmp directory.
<4-107><4-132><2><0><0><4-131><4-0><15>Test script fix
<24>237:script:tools:test.pl<0><2-48>This fixes a minor problems with the test
script<4-0>

indicates one reversible critical (typically, a security-related fix or major
bug fix) update that replaces /path/a/admin.cgi, /path/tpl/admin/home.html, and
/path/admin/GT/Template.pm, and adds a /path/admin/tmp/ directory; and one
irreversible recommended update that replaces /path/t/test.pl and depends on
update 131 (the first update).

The 'version' and 'code' types are special pseudo-types used to indicate a
version upgrade download (e.g. product-1.2.3.tar.gz) and a file containing
upgrade code to run, respectively.

=cut

    my @updates;
    while (my $update_size = unpack 'N', _remove($response, 4)) {
        my $update = _remove($response, $update_size);

        my ($id, $severity, $reversible, $unique) = unpack 'NCCC', _remove($update, 7);
        my @deps;
        while (my $dep = unpack 'N', _remove($update, 4)) {
            push @deps, $dep;
        }
        my $title_size = unpack 'C', _remove($update, 1);
        my $title = _remove($update, $title_size);
        my @files;
        while (my $file_info_size = unpack 'C', _remove($update, 1)) {
            my $file_info = _remove($update, $file_info_size);
            push @files, [$file_info =~ /^(\d+|code):(\w+):(\w*):([0-7]+):(.*)/];
            $files[-1][0] or die "Received success response, but invalid update file data followed";
        }

        my $desc_size = unpack 'n', _remove($update, 2);
        my $desc = _remove($update, $desc_size);

        push @updates, {
            id => $id,
            severity => $severity,
            reversible => $reversible,
            unique => $unique,
            deps => \@deps,
            title => $title,
            files => \@files,
            description => $desc
        };
    }

    return @updates;
}

# Takes two arguments - a string, and a number of characters to remove off the
# beginning of the string, which are returned.  This could be done via
# to substr($_[0], 0, $_[1], '') - but that doesn't work prior to Perl 5.005.
# Also, if the size you requested exceeds the length of the string, a fatal
# error occurs.
sub _remove ($$) {
    die "Received success response, but invalid update data followed" if length($_[0]) < $_[1];
    my $ret = substr($_[0], 0, $_[1]);
    substr($_[0], 0, $_[1]) = '';
    $ret;
}

# Normally when calling check(), the results retrieved from the update server
# are cached so that multiple calls on the same object do not establish
# multiple connections to the server.  If, for some reason, you want to force
# a connection to the server to occur, you can call ->clear_cache() before
# calling ->check().  This is done automatically after a successful ->install()
# or ->uninstall() call.
sub clear_cache {
    my $self = shift;
    delete $self->{updates};
    return;
}

# Returns an array reference of ordered update ID's on success, a hash
# reference containing the following keys on error:
sub verify {
    my ($self, @ids) = @_;

    my @must_have = qw/reg_number init_path product version installed perl_path backup_path/;
    for (my $i = 0; $i < @must_have; $i++) {
        splice @must_have, $i--, 1 if $self->{$must_have[$i]};
    }
    croak "The following must be set before calling ->check: @must_have" if @must_have;

    my $version = $self->{version};
    my %installed = %{$self->{installed}->{$version} ||= {}};
    my %install = map { $_ => 1 } @ids;

    my %updates = map { $_->id => $_ } $self->check;
    my %deps;

    my $error;

    for (keys %install) {
        unless ($updates{$_}) {
            push @{$error->{does_not_exist}}, $_;
            next;
        }
        elsif ($installed{$_} and $updates{$_}->severity != VERSION) {
            push @{$error->{already_installed}}, $_;
            next;
        }
        elsif (@ids > 1 and $updates{$_}->unique) {
            push @{$error->{unique_update}}, $_;
            next;
        }

        $deps{$_} = { map { $_ => 1 } $updates{$_}->deps };
        for my $dep (keys %{$deps{$_}}) {
            unless ($installed{$dep} or $install{$dep}) {
                push @{$error->{depends_on}}, { update => $_, requires => $dep };
                next;
            }
        }
    }

    return $error if $error;

    return [sort {
        # A is a dependency of B, A comes first:
        $deps{$b}->{$a} ? -1 :
        # B is a dependency of A, B comes first:
        $deps{$a}->{$b} ? 1 :
        # Neither depends on either one; order by ID:
        $a <=> $b
    } keys %install];
}

sub verify_uninstall {
    my ($self, @ids) = @_;

    my @must_have = qw/reg_number init_path product version installed perl_path backup_path/;
    for (my $i = 0; $i < @must_have; $i++) {
        splice @must_have, $i--, 1 if $self->{$must_have[$i]};
    }
    croak "The following must be set before calling ->verify_uninstall: @must_have" if @must_have;

    my %installed = map { $_->id => $_ } $self->check($self->{version});
    my %uninstall = map { $_ => 1 } @ids;

    my (%revdep, $error);

    for (values %installed) {
        for my $dep ($_->deps) {
            $revdep{$dep}->{$_->id} = 1 if $installed{$dep};
        }
    }

    for (keys %uninstall) {
        unless ($installed{$_}) {
            push @{$error->{not_installed}}, $_;
            next;
        }
        elsif (@ids > 1 and $installed{$_}->unique) {
            push @{$error->{unique_update}}, $_;
            next;
        }

        for my $revdep (keys %{$revdep{$installed{$_}->id} || {}}) {
            if ($installed{$revdep} and not $uninstall{$revdep}) {
                push @{$error->{depends_on}}, { update => $revdep, requires => $_ };
                next;
            }
        }
    }

    return $error if $error;

    return [sort {
        # A is a dependency of B, B comes first:
        $revdep{$b}->{$a} ? 1 :
        # B is a dependency of A, A comes first:
        $revdep{$a}->{$b} ? -1 :
        # Neither depends on either one; order by ID, descending:
        $b <=> $a
    } keys %uninstall];
}

# Takes updates, verifies them, then calls install_verified() on the ordered updates.
sub install {
    my ($self, @updates) = @_;

    my $v = $self->verify(@updates);
    return $self->error('Update verification failed: see ->verify(@updates) result') unless ref $v eq 'ARRAY';

    $self->install_verified(@$v);
}

# Takes updates, verifies them, then calls uninstall_verified() on the ordered updates.
sub uninstall {
    my ($self, @updates) = @_;

    my $v = $self->verify_uninstall(@updates);
    return $self->error('Update verification failed: see ->verify(@updates) result') unless ref $v eq 'ARRAY';

    $self->uninstall_verified(@$v);
}

# Takes update ID's assumed to have been verified and ordered by ->verify,
# downloads and installs them.  Calling this with non-verified data will most
# likely break your installation.
sub install_verified {
    my ($self, @install) = @_;

    my %updates = map { $_->id => $_ } $self->check;

    my $www = GT::WWW->new();
    $www->debug_level($self->{debug}) if $self->{debug};

    my $version = $self->version;
    my %installed = $self->installed;

    for (@install) {
        my $update = $updates{$_} or return $self->error("Invalid update to install: $_");
        my $severity = $update->severity;
        my %update_info = (
            title => $update->title,
            description => $update->description,
            severity => $severity,
            reversible => $update->reversible,
            unique => $update->unique,
            deps => [$update->deps],
            installed => time,
            files => [$update->files],
        );
        my $update_code;

        for my $file ($update->files) { # id dir type path file mode
            my $file_mode = oct $file->{mode};
            if ($file->{dir}) {
                mkpath $file->{path} or return $self->error("Unable to create directory '$file->{path}': $!")
                    unless -d $file->{path};
                if (((stat $file->{path})[2] & 07777) != $file_mode) {
                    chmod oct($file->{mode}), $file->{path};
                }
                next;
            }
            elsif ($file->{type} eq 'fixed' and -e $file->{path}) {
                if (((stat $file->{path})[2] & 07777) != $file_mode) {
                    chmod oct($file->{mode}), $file->{path};
                }
                next;
            }

            my $tmpfile = GT::TempFile->new(destroy => 1);
            $www->url($https ? GTUPDATES : GTUPDATE);
            $www->parameters(
                reg_number => $self->{reg_number},
                init_path => $self->{init_path},
                product => $self->{product},
                product_version => $self->{version},
                update_version => $VERSION,
                update_id => $update->id,
                file_id => $file->{id},
                $self->{testing} ? (testing => 1) : (),
                $severity == VERSION ? (file_path => $file->{file}) : ()
            );
            $www->chunk_size(4096);

            my $fh = gensym;
            my $error;
            my $first_chunk = 1;
            my $file_size;
            my $printed = 0;
            $www->chunk(sub {
                my $data = ${$_[0]};
                if ($first_chunk) {
                    if ($data !~ s/^GTUPDATE\n(\d{3})(?:\s+(\S.*))?\n//) {
                        $error = "Received invalid data from update server ($data)";
                        $www->cancel;
                        return;
                    }
                    my ($response_code, $response_string) = ($1, $2);
                    if ($response_code != "101") {
                        $error = "Server returned error code: $response_code $response_string";
                        $www->cancel;
                        return;
                    }
                    $file_size = unpack 'N', _remove($data, 4);
                    unless (open $fh, "> $tmpfile") {
                        $www->cancel;
                        $error = "Could not open temporary file location $tmpfile: $!";
                        return;
                    }
                    binmode $fh;
                    $first_chunk = 0;
                }
                unless (print $fh $data) {
                    $error = "Unable to write to temporary file location $tmpfile: $!";
                    $www->cancel;
                }
                $printed += length $data;
            });
            $www->get or return $self->error("Unable to download update file $file->{file}: " . $www->error);
            return $self->error("Unable to download update file $file->{file}: $error") if $error;
            return $self->error("Update file download contained no data") if $first_chunk;

            close $fh;

            if ($file->{type} eq 'code') {
                my $fh = gensym;
                open $fh, "<$tmpfile";
                local $/;
                $update_code = <$fh>;
                close $fh;
            }
            else {
                $tmpfile = $self->_fixup_file($tmpfile, $file, $update) or return;
                $self->_install_file($tmpfile, $file, $update, \%update_info) or return;
            }
        }

        if ($update_code) {
            eval <<UPDATE_CODE;
package $self->{product};

$update_code

UPDATE_CODE
            return $self->error("Unable to run update code <pre>package $self->{product};\n\n$update_code\n</pre>\n$@") if $@;
        }

        $installed{$version}->{$update->id} = \%update_info;

        # Set this here, inside the loop, in case the next install fails
        $self->installed(%installed);
    }

    $self->clear_cache;
    return 1;
}

# Takes update ID's assumed to have been verified and ordered by
# ->verify_uninstall, downloads and installs them.  Calling this with
# non-verified data will most likely break your installation.
sub uninstall_verified {
    my ($self, @uninstall) = @_;

    my %updates = map { $_->id => $_ } $self->check;

    my $version = $self->version;
    my %installed = $self->installed;

    for (@uninstall) {
        my $update = $installed{$version}->{$_} or return $self->error("Invalid update to uninstall: $_");

        for my $file (@{$update->{files}}) {
            next unless $file->{backup};
            my ($path, $backup) = @$file{qw/path backup/};
            -r $backup or return $self->error("Unable to restore backup file '$backup': File not readable");

            copy $backup, $path, { preserve_all => 1 }
                or return $self->error("Unable to restore '$backup' to '$path': $!");

            unlink $backup;
        }

        delete $installed{$version}->{$_};

        # Set this here, inside the loop, in case the next uninstall fails
        $self->installed(%installed);
    }

    $self->clear_cache;
    return 1;
}

# Returns a temp filename on success, or undef if an error occurs.  In the case
# of an error, it is assumed that $self->error will have already been called
# with the error message.
sub _fixup_file {
    my ($self, $tmpfile, $file, $update) = @_;

    if ($file->{type} eq 'static' or $file->{type} eq 'template' or $file->{type} eq 'library' or $file->{type} eq 'fixed' or $file->{type} eq 'code' or $file->{type} eq 'version') {

        # Handle file replacements, if needed.
        if (exists $self->{replacements}->{$file->{type}}->{$file->{subtype}}->{$file->{file}}) {
            my $repl = $self->{replacements}->{$file->{type}}->{$file->{subtype}}->{$file->{file}};
            my ($source, $dest) = (gensym, gensym);

            open $source, "<$tmpfile" or return $self->error("Unable to open temp file '$tmpfile': $!");
            my $destination = GT::TempFile->new(destroy => 1);
            open $dest, "> $destination" or return $self->error("Unable to open temp file '$destination': $!");

            # Longer before shorter because 'FOOBAR' should match before 'FOO':
            my $replacements = join '|', map quotemeta, sort { length $b <=> length $a } keys %$repl;
            while (<$source>) {
                s/($replacements)/$repl->{$1}/g;
                s/\r\n/\n/;
                print $dest $_;
            }
            close $source;
            close $dest;
            return $destination;
        }

        # Some day we may attempt to look for localized versions of templates
        # and integrate changes - but that is neither an easy nor fool-proof
        # task.
        return $tmpfile;
    }
    elsif ($file->{type} eq 'script') {
        # We need to rewrite the file to use the correct #!/usr/bin/perl line,
        # the correct use lib line(s), and the correct Product::init() line.
        my $source = gensym;
        my $dest = gensym;
        open $source, "<$tmpfile" or return $self->error("Unable to open temp file '$tmpfile': $!");
        my $destination = GT::TempFile->new(destroy => 1);
        open $dest, "> $destination" or return $self->error("Unable to open temp file '$destination': $!");
        my $shebang = <$source>;
        my ($flags) = $shebang =~ /^\s*#!\s*\S+(?:\s+(.*\S))?/;
        $flags ||= '';
        print $dest "#!$self->{perl_path} $flags \n";
        my $use_lib;
        while (<$source>) {
            if (/^\s*use\s+lib\s*(['"])[^'"]*\1\s*;\s*/) {
                unless ($use_lib++) {
                    for (values %{$self->{paths}->{library}}) {
                        s/'/\\'/g;
                        print $dest "use lib '$_';\n";
                    }
                }
            }
            elsif (/^\s*\Q$self->{product}\E::init\s*\([^\)]*\)\s*;/) {
                (my $init_path = $self->{init_path}) =~ s/'/\\'/g;
                print $dest "$self->{product}::init('$init_path');\n";
            }
            else {
                s/\r\n/\n/;
                print $dest $_;
            }
        }
        close $source;
        close $dest;
        return $destination;
    }
    else {
        return $self->error("Unknown file type: $file->{type}");
    }
}

sub _install_file {
    my ($self, $tmpfile, $file, $update, $update_info) = @_;
    my $error;
    my $error_handler = sub { GT::File::Tools->warn(@_); $error = $GT::File::Tools::error; undef };
    my $backup_file;
    if (-e $file->{path} and $update->severity != VERSION) {
        # Create the Make the backup file, and store its location in the file info

        $backup_file = $self->backup_path . "/"
            . join('-', $update->id, time, $file->{type}, $file->{subtype}, split(m{/}, $file->{file}))
            . '.backup';

        copy $file->{path}, $backup_file, { preserve_all => 1, error_handler => $error_handler }
            or return $self->error("Unable to backup '$file->{path}' to '$backup_file': $error");
    }

    # Copy the tmpfile to its final location/mode
    copy $tmpfile, $file->{path}, { error_handler => $error_handler }
        and (chmod(oct $file->{mode}, $file->{path}) or $error = "chmod failed: $!");

    if ($backup_file) {
        # Attempt to restore the original file
        move $backup_file, $file->{path} if $error;

        for (@{$update_info->{files}}) {
            if ($_->{path} eq $file->{path}) {
                $_->{backup} = $backup_file;
                last;
            }
        }
    }

    return $self->error("Unable to overwrite '$file->{path}' with tempfile '$tmpfile': $error")
        if $error;

    1;
}

sub error {
    my $self = shift;
    if (@_) {
        $self->{error} = shift;
        return undef;
    }
    $self->{error};
}

# Returns the last server status code and, in list context, the status message
# returned by the server with the code.
sub server_status {
    my $self = shift;
    return wantarray ? @$self{qw{server_status server_status_message}} : $self->{server_status};
}


package GT::Update::Update;

sub new {
    my ($class, %args) = @_;
    my $self = \%args;
    bless $self, ref $class || $class;
}

# Returns a list of files, each in the form:
# {
#       id => $fileid,
#       dir => $if_dir_boolean,
#       type => 'script', # Or library, template, static, or fixed
#       subtype => '', # One of the paths() sub-paths
#       file => 'relative/file.name', # Relative to type and subtype
#       path => '/full/system/path/to/script/relative/file.name',
#       mode => '0644' # Note: in string form
# }
# Note that id can be set to 'code', which indicates a code update, which isn't
# actually an installable file.
sub files {
    my $self = shift;
    my $paths = $self->{paths};
    my @files;
    for (@{$self->{files}}) {
        if (ref eq 'ARRAY') {
            my ($fid, $type, $which, $mode, $file) = @$_;
            my $path = ($fid ne 'code' and $paths->{$type}->{$which}) ? "$paths->{$type}->{$which}/$file" : $file;
            push @files, {
                id => $fid,
                dir => $file =~ s|/$||,
                type => $type,
                subtype => $which,
                path => $path,
                file => $file,
                mode => $mode
            };
        }
        elsif (ref eq 'HASH') {
            push @files, {%$_};
        }
    }
    @files;
}

# Internal update ID; every update has a unique number.
sub id { shift->{id} }

# Update title
sub title { shift->{title} }

# Update description (HTML):
sub description { shift->{description} }

# Severity code (corresponding to :severity constants)
sub severity { shift->{severity} }

# 1/0 value - 1 means the update can be reversed, 0 means no.
sub reversible { shift->{reversible} }

# 1/0 value - 1 means the update has to be installed by itself, 0 means it doesn't.
sub unique { shift->{unique} }

# Returns a list of dependencies, or reverse dependencies (revdeps).
sub deps { @{shift->{deps}} }
sub revdeps { @{shift->{revdeps}} }

# Returns a list of dependencies that aren't installed (for uninstalled updates)
# or updates that have to be installed first (for already-installed updates)
sub requires { @{shift->{requires} || []} }

# Returns true if depedencies have to be installed before and separate to this update.
# revdeps_first is the equivelant for uninstalling updates.
sub deps_first { shift->{deps_first} }
sub revdeps_first { shift->{revdeps_first} }

# Returns a unix time of the installation date for an uninstalled update, undef
# for an uninstalled update.
sub installed { shift->{installed} }

1;