288 lines
10 KiB
Perl
288 lines
10 KiB
Perl
# ==================================================================
|
|
# Gossamer Links - enhanced directory management system
|
|
#
|
|
# Website : http://gossamer-threads.com/
|
|
# Support : http://gossamer-threads.com/scripts/support/
|
|
# CVS Info : 087,071,086,086,085
|
|
# Revision : $Id: Update.pm,v 1.11 2009/05/08 19:56:50 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# Redistribution in part or in whole strictly prohibited. Please
|
|
# see LICENSE file for full details.
|
|
# ==================================================================
|
|
#
|
|
|
|
package Links::Update;
|
|
use strict;
|
|
use Links qw/$CFG $IN %STASH/;
|
|
use GT::Update qw/:severity/;
|
|
use GT::File::Tools qw/basename/;
|
|
use GT::Config;
|
|
use constant CACHE_TIMEOUT => 5*60; # Only check the server at most once every 5 minutes
|
|
|
|
sub _updater {
|
|
$STASH{updates} ||= GT::Config->load("$CFG->{admin_root_path}/Links/Config/Updates.pm", { debug => $CFG->{debug_level} });
|
|
return $STASH{updater} if $STASH{updater};
|
|
(my $cgi_path = $CFG->{admin_root_path}) =~ s{[\\/]+admin[\\/]*$}//;
|
|
$STASH{updater} = GT::Update->new(
|
|
product => 'Links',
|
|
version => $CFG->{version},
|
|
reg_number => $CFG->{reg_number},
|
|
init_path => $CFG->{admin_root_path},
|
|
perl_path => $CFG->{path_to_perl},
|
|
backup_path => "$CFG->{admin_root_path}/updates",
|
|
paths => {
|
|
script => {
|
|
cgi => $cgi_path,
|
|
admin => $CFG->{admin_root_path}
|
|
},
|
|
library => $CFG->{admin_root_path},
|
|
template => $CFG->{admin_root_path} . '/templates',
|
|
static => {
|
|
static => $CFG->{build_static_path},
|
|
},
|
|
fixed => {
|
|
static => $CFG->{build_static_path},
|
|
cool => $CFG->{build_cool_path},
|
|
detail => $CFG->{build_detail_path},
|
|
new => $CFG->{build_new_path},
|
|
ratings => $CFG->{build_ratings_path},
|
|
build => $CFG->{build_root_path},
|
|
},
|
|
version => $CFG->{admin_root_path}
|
|
},
|
|
replacements => {
|
|
library => {
|
|
'' => {
|
|
'Links.pm' => {
|
|
'<%VERSION%>' => $CFG->{version}
|
|
}
|
|
}
|
|
}
|
|
},
|
|
installed => ($STASH{updates}->{installed} ||= {}),
|
|
testing => $STASH{updates}->{testing}
|
|
);
|
|
}
|
|
|
|
sub check {
|
|
my $updater = _updater;
|
|
my ($cached, @updates);
|
|
if (my $cache = $STASH{updates}->{cache} and !$STASH{updates}->{testing}) {
|
|
if ($cache->{version} == $GT::Update::VERSION and $cache->{time} > time - CACHE_TIMEOUT) { # Only check at most once every 5 minutes
|
|
@updates = @{$cache->{updates}};
|
|
$cached = 1;
|
|
}
|
|
}
|
|
unless ($cached) {
|
|
@updates = $updater->check;
|
|
|
|
if (@updates == 1 and not defined $updates[0]) {
|
|
my $error = $updater->error;
|
|
my ($error_code, $error_message) = $error =~ /error code: (\d{3})\s*(.*)/;
|
|
return { error => $error, update_error_code => $error_code, update_error_message => $error_message };
|
|
}
|
|
|
|
$STASH{updates}->{cache} = { time => time, version => $GT::Update::VERSION, updates => \@updates };
|
|
$STASH{updates}->save;
|
|
}
|
|
|
|
my %ret;
|
|
my %available = map { $_->id => $_ } @updates;
|
|
for my $update (@updates) {
|
|
my $id = $update->id;
|
|
my $severity = $update->severity;
|
|
my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional';
|
|
my $info = {
|
|
id => $id,
|
|
title => $update->title,
|
|
description => \($update->description),
|
|
severity => $severity,
|
|
files => [$update->files],
|
|
reversible => $update->reversible,
|
|
unique => $update->unique,
|
|
deps => [$update->deps],
|
|
revdeps => [$update->revdeps],
|
|
requires => [$update->requires],
|
|
deps_first => $update->deps_first,
|
|
update_type => $update_type,
|
|
installed => $update->installed
|
|
};
|
|
push @{$ret{$update_type}}, $info;
|
|
$ret{update}->{$id} = $info;
|
|
}
|
|
for (sort { $a <=> $b } keys %{$STASH{updates}->{installed}->{$CFG->{version}}}) {
|
|
next if $available{$_};
|
|
my %info = %{$STASH{updates}->{installed}->{$CFG->{version}}->{$_}};
|
|
$info{id} = $_;
|
|
my $severity = $info{severity};
|
|
my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional';
|
|
push @{$ret{$update_type}}, \%info;
|
|
}
|
|
|
|
for (qw/critical recommended optional version/) {
|
|
$ret{"${_}_total"} = @{$ret{$_} ||= []};
|
|
$ret{"${_}_installed"} = $ret{"${_}_installable"} = 0;
|
|
for my $update (@{$ret{$_}}) {
|
|
next unless $available{$update->{id}};
|
|
if ($available{$update->{id}}->{installed}) {
|
|
$ret{"${_}_installed"}++;
|
|
}
|
|
elsif (!$available{$update->{id}}->{impossible}) {
|
|
$ret{"${_}_installable"}++;
|
|
}
|
|
}
|
|
push @{$ret{update_types}}, { update_type => $_, updates => $ret{$_} };
|
|
}
|
|
|
|
my @historic = sort { _numeric_version($a) <=> _numeric_version($b) } keys %{$STASH{updates}->{installed}};
|
|
$ret{historic} = \@historic;
|
|
|
|
\%ret;
|
|
}
|
|
|
|
sub check_historic {
|
|
my $updater = _updater;
|
|
my $version = shift || $CFG->{version};
|
|
|
|
my @updates = $updater->check($version);
|
|
my %ret = (historic_version => $version, current_version => $CFG->{version});
|
|
|
|
for (@updates) {
|
|
my @files = $_->files;
|
|
my $severity = $_->severity;
|
|
my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional';
|
|
my $id = $_->id;
|
|
my %info = (
|
|
id => $id,
|
|
title => $_->title,
|
|
description => \($_->description),
|
|
severity => $severity,
|
|
files => \@files,
|
|
reversible => ($version eq $CFG->{version} ? $_->reversible : 0),
|
|
unique => $_->unique,
|
|
deps => [$_->deps],
|
|
revdeps => [$_->revdeps],
|
|
requires => [$_->requires],
|
|
revdeps_first => $_->revdeps_first,
|
|
update_type => $update_type,
|
|
installed => $_->installed
|
|
);
|
|
push @{$ret{$update_type}}, \%info;
|
|
$ret{update}->{$id} = \%info;
|
|
}
|
|
|
|
for (qw/critical recommended optional version/) {
|
|
push @{$ret{update_types}}, { update_type => $_, updates => $ret{$_} };
|
|
}
|
|
|
|
my @historic = sort { _numeric_version($a) <=> _numeric_version($b) } grep keys %{$STASH{updates}->{installed}->{$_}}, keys %{$STASH{updates}->{installed}};
|
|
$ret{historic} = \@historic;
|
|
|
|
\%ret;
|
|
}
|
|
|
|
# Takes a version such as 1.3.7 and converts it to 1.0307.
|
|
sub _numeric_version {
|
|
my @v = split /\./, (shift =~ /^(\d+(?:\.\d+)*)/)[0];
|
|
my $numeric = 0;
|
|
for (0 .. $#v) { $numeric += $v[$_] * 100**-$_ }
|
|
$numeric;
|
|
}
|
|
|
|
sub browser_install {
|
|
my @updates = $IN->param('install');
|
|
my ($status, $errors) = install(@updates);
|
|
if (!$status) {
|
|
$errors->{updates_selected} = \@updates;
|
|
return $errors;
|
|
}
|
|
my %ret = (update_success => 1, update_status => $status, updates_selected => []);
|
|
|
|
if ($status == 2) {
|
|
my $id = $errors;
|
|
my $path;
|
|
for (@{$STASH{updates}->{installed}->{$CFG->{version}}->{$updates[0]}->{files}}) {
|
|
if (basename($_->{file}) eq 'install.cgi') {
|
|
$path = $_->{file} . "?upgrade_choice=Yes;install_dir=" . $IN->escape($CFG->{admin_root_path});
|
|
last;
|
|
}
|
|
}
|
|
$ret{continue_url} = $path;
|
|
}
|
|
|
|
return \%ret;
|
|
}
|
|
|
|
# Installs updates passed in. Returns (0, \%error_hash) on failure, 1 on
|
|
# success of normal updates, (2, $id) on the success of version upgrade files.
|
|
sub install {
|
|
my @updates = @_;
|
|
my $updater = _updater;
|
|
my $v = $updater->verify(@updates);
|
|
return 0, { %$v, update_failed => 1, verify_failed => 1 } if ref $v eq 'HASH';
|
|
@updates = @$v;
|
|
|
|
my $success = $updater->install_verified(@updates);
|
|
if (!$success) {
|
|
my $error = $updater->error;
|
|
return 0, { update_failed => 1, error => "Update failed: $error" };
|
|
}
|
|
$STASH{updates}->{installed} = { $updater->installed };
|
|
delete $STASH{updates}->{cache};
|
|
$STASH{updates}->save;
|
|
|
|
if (@updates == 1 and $STASH{updates}->{installed}->{$CFG->{version}}->{$updates[0]}->{severity} == VERSION) {
|
|
# We just installed a version upgrade
|
|
return (2, $updates[0]);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub browser_uninstall {
|
|
my @updates = $IN->param('uninstall');
|
|
my ($status, $errors) = uninstall(@updates);
|
|
if (!$status) {
|
|
$errors->{updates_selected} = \@updates;
|
|
return $errors;
|
|
}
|
|
return { uninstall_success => 1, updates_selected => [] };
|
|
}
|
|
|
|
sub uninstall {
|
|
my @updates = @_;
|
|
my $updater = _updater;
|
|
my $v = $updater->verify_uninstall(@updates);
|
|
return { %$v, update_failed => 1, verify_failed => 1 } if ref $v eq 'HASH';
|
|
@updates = @$v;
|
|
|
|
my $success = $updater->uninstall_verified(@updates);
|
|
if (!$success) {
|
|
my $error = $updater->error;
|
|
return 0, { uninstall_failed => 1, error => "Update uninstall failed: $error" };
|
|
}
|
|
$STASH{updates}->{installed} = { $updater->installed };
|
|
delete $STASH{updates}->{cache};
|
|
$STASH{updates}->save;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# Takes a string, such as '/foo/bar/blah/sdffffffddddddddddddddddddddddddddddd'
|
|
# and replaces a part of it with ...
|
|
# The arguments are:
|
|
# - string
|
|
# - number of characters before the ...
|
|
# - number of characters after the ...
|
|
sub shorten {
|
|
my ($string, $leading, $trailing) = @_;
|
|
if (length($string) <= ($leading + $trailing + 3)) {
|
|
return $string;
|
|
}
|
|
else {
|
|
return substr($string, 0, $leading) . ' ... ' . substr($string, -$trailing);
|
|
}
|
|
}
|
|
|
|
1;
|