1094 lines
38 KiB
Perl
1094 lines
38 KiB
Perl
# ====================================================================
|
|
# 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;
|