# Module of Foswiki - The Free and Open Source Wiki, http://foswiki.org/ # # Copyright (C) 1999-2007 Foswiki Contributors. All Rights Reserved. # Foswiki Contributors are listed in the AUTHORS file in the root of # this distribution. NOTE: Please extend that file, not this notice. # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. For # more details read LICENSE in the root of this distribution. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # # As per the GPL, removal of this notice is prohibited. # # Author: Crawford Currie http://wikiring.com # # This module contains the functions used by the extensions installer. # It is not treated as a "standard" module because it has radically # different environment requirements (i.e. as few as possible) # # It is invoked from the individual installer scripts shipped with # extensions, and should not be run directly. # package Foswiki::Extender; use strict; use warnings; use Cwd; use File::Temp; use File::Copy; use File::Path; no warnings 'redefine'; my $noconfirm = 0; my $downloadOK = 0; my $alreadyUnpacked = 0; my $reuseOK = 0; my $inactive = 0; my $session; my %available; my $lwp; my @archTypes = ( '.tgz', '.tar.gz', '.zip' ); my $installationRoot; my $MODULE; my $PACKAGES_URL; my $MANIFEST; BEGIN { $installationRoot = Cwd::getcwd(); # getcwd is often a simple `pwd` thus it's tainted, untaint it $installationRoot =~ /^(.*)$/; $installationRoot = $1; # Check if we were invoked from configure # by looking at the call stack sub running_from_configure { my $i = 0; while ( my $caller = caller( ++$i ) ) { if ( $caller =~ /^Foswiki::Configure::UIs::EXTEND$/ ) { return 1; } } return 0; } my $check_perl_module = sub { my $module = shift; if ( $module =~ /^CPAN/ ) { # Check how we were invoked as CPAN shouldn't # be loaded from the configure if (running_from_configure) { print "Running from configure, disabling $module\n"; return $available{$module} = 0; } } if ( eval "use $module; 1;" ) { $available{$module} = 1; } else { print "Warning: $module is not available," . " some installer functions have been disabled\n"; $available{$module} = 0; } return $available{$module}; }; unless ( -d 'lib' && -d 'bin' && -e 'bin/setlib.cfg' ) { die 'This installer must be run from the root directory' . ' of a Foswiki installation'; } # read setlib.cfg chdir('bin'); require 'setlib.cfg'; # See if we can make a Foswiki. If we can, then we can save topic # and attachment histories. Key off Foswiki::Merge because it is # fairly new and fairly unique. unless ( &$check_perl_module('Foswiki::Merge') ) { die "Can't find Foswiki: $@"; } require Foswiki; # We have to get the admin user, as a guest user may be blocked. my $user = $Foswiki::cfg{AdminUserLogin}; $session = new Foswiki($user); chdir($installationRoot); if ( &$check_perl_module('LWP') ) { $lwp = new LWP::UserAgent(); $lwp->agent("PluginsInstaller"); $lwp->env_proxy(); } &$check_perl_module('CPAN'); } sub remap { my $file = shift; if ( $Foswiki::cfg{SystemWebName} ne 'System' ) { $file =~ s#^data/System/#data/$Foswiki::cfg{SystemWebName}/#; $file =~ s#^pub/System/#pub/$Foswiki::cfg{SystemWebName}/#; } if ( $Foswiki::cfg{TrashWebName} ne 'Trash' ) { $file =~ s#^data/Trash/#data/$Foswiki::cfg{TrashWebName}/#; $file =~ s#^pub/Trash/#pub/$Foswiki::cfg{TrashWebName}/#; } if ( $Foswiki::cfg{UsersWebName} ne 'Main' ) { $file =~ s#^data/Main/#data/$Foswiki::cfg{UsersWebName}/#; $file =~ s#^pub/Main/#pub/$Foswiki::cfg{UsersWebName}/#; } if ( $Foswiki::cfg{UsersWebName} ne 'Users' ) { $file =~ s#^data/Users/#data/$Foswiki::cfg{UsersWebName}/#; $file =~ s#^pub/Users/#pub/$Foswiki::cfg{UsersWebName}/#; } # Canonical symbol mappings foreach my $w qw( SystemWebName TrashWebName UsersWebName ) { if ( defined $Foswiki::cfg{$w} ) { $file =~ s#^data/$w/#data/$Foswiki::cfg{$w}/#; $file =~ s#^pub/$w/#pub/$Foswiki::cfg{$w}/#; } } foreach my $t qw( NotifyTopicName HomeTopicName WebPrefsTopicName MimeTypesFileName ) { if ( defined $Foswiki::cfg{$t} ) { $file =~ s#^data/(.*)/$t\.txt(,v)?#data/$1/$Foswiki::cfg{$t}.txt$2/#; $file =~ s#^pub/(.*)/$t/([^/]*)$#pub/$1/$Foswiki::cfg{$t}/$2/#; } } return $file; } sub max_field_length { my $max_length = 1; for my $number (@_) { next unless defined $number; foreach my $field ($number =~ /(\d+|\D+)/g) { $max_length = length($field) if $max_length < length($field); } } return $max_length; } # Convert a version number into a form that may be compared using a string comparison sub string_comparable_version { my ($version_string, $field_length) = @_; # version numbers have many possible forms. Here are some examples: # * 2.36_01 (Digest::MD5) # * 6.3.7 (Image::Magick) # * 6.2.4.5 (Image::Magick) # * $Rev: 4315 $ (WysiwygPlugin) # * 1.2.5a # * 1.2.4.5-beta1 # * r123 # # SMELL # This function makes 1.2.4.5-beta1 compare larger than 1.2.4.5 $version_string = ' ' if not defined $version_string; # set version to an arbitary high number if it's supposed to be some subversion revision $version_string = 999999 if $version_string eq '$Rev$'; # remove the SVN marker text from the version number, if it is there $version_string =~ s/^\$Rev: (\d+) \$$/$1/; # eval the string to remove _ between digits, so that 2.36_01 becomes 2.3601 # only use the result if there are no warnings #my $eval_string = eval $version_string; #$version_string = $eval_string if not $@; # convert all multi-part version numbers to use the same separator . # All non-letters and non-digits are considered separators $version_string =~ s/(?:\W|_)/./g; my $comparable = ''; foreach my $part (split /(\d+)/, $version_string) { if ($part =~ /^\d/) { # Numbers are right-justified so that a string comparison produces the correct result # e.g. 062 compares less than 103 $comparable .= sprintf('%0'.$field_length.'d', $part); } elsif ($part =~ /^\D/) { # non-digit sequences are left-justified, and made uppercase # so that "alpha" compares less than "beta ", and "cairo" less than "Dakar" $comparable .= sprintf('%-'.$field_length.'s', uc($part)); } } return $comparable; } sub compare_versions { my ($a, $op, $b) = @_; my $string_op = { '=' => 'eq', '<' => 'lt', '>' => 'gt', '<=' => 'le', '>=' => 'ge' }->{$op}; #print "|$a$op$b|=>"; my $field_length = max_field_length($a, $b); $a = string_comparable_version($a, $field_length); $b = string_comparable_version($b, $field_length); my $comparison = "'$a' $string_op '$b'"; my $result = eval $comparison; #print "[$comparison]->$result\n"; return $result; } sub check_dep { my ($dep) = @_; my ( $ok, $msg ) = ( 1, "" ); # reject non-Perl dependencies if ( $dep->{type} !~ /^(?:perl|cpan)$/i ) { $ok = 0; $msg = "Module is type $dep->{type}, and cannot be automatically checked.\n" . "Please check it manually and install if necessary.\n"; return ( $ok, $msg ); } # try to load the module my $module = $dep->{name}; if ( not eval "require $module" ) { $ok = 0; ( $msg = $@ ) =~ s/ in .*$/\n/s; return ( $ok, $msg ); } my $moduleVersion = 0; { no strict 'refs'; $moduleVersion = ${"${module}::VERSION"}; # remove the SVN marker text from the version number, if it is there $moduleVersion =~ s/^\$Rev: (\d+) \$$/$1/; } # check if the version satisfies the prerequisite if ( defined $dep->{version} ) { # the version field is in fact a condition if ( $dep->{version} =~ /^\s*(?:>=?)?\s*([0-9a-z._-]+)/ ) { # Condition is >0 or >= 1.3 my $requiredVersion = $1; # SMELL: Once all modules have proper version, this should be: # if ( not eval { $module->VERSION( $requiredVersion ) } ) # but plugin modules use SVN numbers as versions, so this may never be if ( compare_versions($moduleVersion, '<', $requiredVersion) ) { # But module doesn't meet this condition $msg = "$module version $requiredVersion required" . "--this is only version $moduleVersion"; $ok = 0; return ( $ok, $msg ); } } elsif ( $dep->{version} =~ /<\s*([0-9a-z._-]+)/ ) { # Condition is < 2.7 my $requiredVersion = $1; if ( compare_versions($moduleVersion, '>=', $requiredVersion) ) { # But module doesn't meet this condition $ok = 0; $msg = "Module $module is version v" . $moduleVersion . " and the dependency wants " . $dep->{version}; return ( $ok, $msg ); } } else { $ok = 0; $msg = "Module $module is version v" . $moduleVersion . " and the dependency wants " . $dep->{version}; return ( $ok, $msg ); } } $msg = "$module v$moduleVersion loaded\n"; return ( $ok, $msg ); } # Satisfy dependencies on modules, by checking: # 1. If the module is a perl module, then: # 1. If the module is loadable in the current environment # 2. If the dependency has specified a version constraint, then # the module must have a top-level variable VERSION which satisfies # the constraint. # Note that all Foswiki modules are perl modules - even non-perl # distributions have a perl 'stub' module that carries the version info. # 2. If the module is _not_ perl, then we can't check it. sub satisfy { my $dep = shift; my $trig = eval $dep->{trigger}; return 1 unless ($trig); print <{name}.... DONE my ( $ok, $msg ) = check_dep($dep); if ($ok) { print $msg; return 1; } print <{type} package $dep->{name} $dep->{version} which is described as "$dep->{description}" But when I tried to find it I got this error: $msg DONE if ( $dep->{name} =~ m/^(Foswiki|TWiki)::(Contrib|Plugins)::(\w*)/ ) { my $type = $1; my $pack = $2; my $packname = $3; $packname .= $pack if ( $pack eq 'Contrib' && $packname !~ /Contrib$/ ); if ( !$noconfirm || ( $noconfirm && $downloadOK ) ) { my $reply = ask( 'Would you like me to try to download ' . 'and install the latest version of ' . $packname . ' from foswiki.org?' ); if ($reply) { return installPackage($packname); } } return 0; } if ( $dep->{type} eq 'cpan' && $available{CPAN} ) { print <<'DONE'; This module is available from the CPAN archive (http://www.cpan.org). You can download and install it from here. The module will be installed to wherever you configured CPAN to install to. DONE my $reply = ask( 'Would you like me to try to download ' . 'and install the latest version of ' . $dep->{name} . ' from cpan.org?' ); return 0 unless $reply; my $mod = CPAN::Shell->expand( 'Module', $dep->{name} ); my $info = $mod->dslip_status(); if ( $info->{D} eq 'S' ) { # Standard perl module! print STDERR <{name} is a standard perl module # # I cannot install it without upgrading your version of perl, something # I'm not willing to do. Please either install the module manually (from # a package downloaded from cpan.org) or upgrade your perl to a version # that includes this module. ######################################################################### DONE return 0; } if ($noconfirm) { $CPAN::Config->{prerequisites_policy} = 'follow'; } else { $CPAN::Config->{prerequisites_policy} = 'ask'; } CPAN::install( $dep->{name} ); ( $ok, $msg ) = check_dep($dep); return 1 if $ok; my $e = 'it'; if ( $CPAN::Config->{makepl_arg} =~ /PREFIX=(\S+)/ ) { $e = $1; } print STDERR <{name} # # If you installed the module in a non-standard directory, make sure you # have followed the instructions in bin/setlib.cfg and added $e # to your \@INC path. ######################################################################### DONE } return 0; } =pod ---++ StaticMethod ask( $question ) -> $boolean Ask a question. Example: =if( ask( "Proceed?" )) { ... }= =cut sub ask { my $q = shift; my $reply; return 1 if $noconfirm; local $/ = "\n"; $q .= '?' unless $q =~ /\?\s*$/; print $q. ' [y/n] '; while ( ( $reply = ) !~ /^[yn]/i ) { print "Please answer yes or no\n"; } return ( $reply =~ /^y/i ) ? 1 : 0; } =pod ---++ StaticMethod prompt( $question, $default ) -> $string Prompt for a string, using a default if return is pressed. Example: =$dir = prompt("Directory")=; =cut sub prompt { my ( $q, $default ) = @_; my $reply = ''; local $/ = "\n"; while ( !$reply ) { print $q; print " ($default)" if defined $default; print ': '; $reply = ; chomp($reply); $reply ||= $default; } return $reply; } # Try and find an installer or archive. # Look in (1) the current directory (2) on the $TWIKI_PACKAGES path and # (3) in the twikiplugins subdirectory (if there, to support developers) # and finally (4) download from $PACKAGES_URL sub getComponent { my ( $module, $types, $what ) = @_; my $f; # Look for the archive. require Config; if ( !$noconfirm || ( $noconfirm && $reuseOK ) ) { foreach my $dir ( $installationRoot, $installationRoot . '/twikiplugins/' . $module, split( $Config::Config{path_sep}, $ENV{TWIKI_PACKAGES} || '' ) ) { foreach my $type (@$types) { # .tgz preferred $f = $dir . '/' . $module . $type; if ( -e $f ) { my @st = stat($f); my $credate = localtime( $st[9] ); print <', $test ) ) { close(F); unlink($test); $downloadDir = $ENV{TWIKI_PACKAGES}; } } my $response; foreach my $type (@$types) { $response = $lwp->get( $url . $type ); if ( $response->is_success() ) { $f = $downloadDir . '/' . $module . $type; open( F, '>', $f ) || die "Failed to open $f for write: $!"; binmode F; print F $response->content(); close(F); last; } } unless ( $f && -e $f ) { print STDERR "Failed to download $module $what\n", $response->status_line(), "\n"; return; } else { print "Downloaded $what from $PACKAGES_URL to $f\n"; } return $f; } # Try and find an archive for the named module. sub getArchive { my $module = shift; return getComponent( $module, \@archTypes, 'archive' ); } # Try and find an installer for the named module. sub getInstaller { my $module = shift; return getComponent( $module, ['_installer'], 'installer' ); } # install a package by running the installer sub installPackage { my ($module) = @_; my $script = getInstaller($module); if ( $script && -e $script ) { my $cmd = "perl $script"; $cmd .= ' -a' if $noconfirm; $cmd .= ' -d' if $downloadOK; $cmd .= ' -r' if $reuseOK; $cmd .= ' -n' if $inactive; $cmd .= ' install'; local $| = 0; # Fork the installation of the downloaded package. my $pid = fork(); if ($pid) { wait(); if ($?) { print STDERR "Installation of $module failed: $?\n"; return 0; } } else { exec($cmd); } } else { print STDERR < 1 ); chdir($dir); unless ( $name =~ /\.zip/i && unzip($name) || $name =~ /(\.tar\.gz|\.tgz|\.tar)/ && untar($name) ) { $dir = undef; print STDERR "Failed to unpack archive $name\n"; } chdir($installationRoot); return $dir; } sub unzip { my $archive = shift; if ( not eval 'require Archive::Zip' ) { my $zip = Archive::Zip->new(); my $err = $zip->read($archive); if ( $err ) { print STDERR "Could not openzip file $archive (" . $err . "\n"; return 0; } my @members = $zip->members(); foreach my $member (@members) { my $file = $member->fileName(); my $target = $file; my $err = $zip->extractMember( $file, $target ); if ($err) { print STDERR "Failed to extract '$file' from zip file ", $zip, ". Archive may be corrupt.\n"; return 0; } else { print " $target\n"; } } } else { print STDERR "Archive::Zip is not installed; trying unzip on the command line\n"; print `unzip $archive`; if ($?) { print STDERR "unzip failed: $?\n"; return 0; } } return 1; } sub untar { my $archive = shift; my $compressed = ( $archive =~ /z$/i ) ? 'z' : ''; if ( not eval 'require Archive::Tar' ) { my $tar = Archive::Tar->new(); my $numberOfFiles = $tar->read( $archive, $compressed ); unless ( $numberOfFiles > 0 ) { print STDERR "Could not open tar file $archive (" . $tar->error() . "\n"; return 0; } my @members = $tar->list_files(); foreach my $file (@members) { my $target = $file; my $ok = $tar->extract_file( $file, $target ); unless ($ok) { print STDERR 'Failed to extract ', $file, ' from tar file ', $tar, ". Archive may be corrupt.\n"; return 0; } else { print " $target\n"; } } } else { print STDERR "Archive::Tar is not installed; trying tar on the command-line\n"; print `tar xvf$compressed $archive`; if ($?) { print STDERR "tar failed: $?\n"; return 0; } } return 1; } # Check in. sub checkin { my ( $web, $topic, $file ) = @_; return 0 unless ($session); my $err = 1; if ($file) { my $origfile = $Foswiki::cfg{PubDir} . '/' . $web . '/' . $topic . '/' . $file; print "Add attachment $origfile\n"; return 1 if ($inactive); print < 1 ); File::Copy::copy( $origfile, $tmpfilename ) || die "$origfile could not be copied to tmp dir ($tmpfilename): $!"; eval { Foswiki::Func::saveAttachment( $web, $topic, $file, { comment => 'Saved by install script', file => $tmpfilename, filesize => $fileSize, filedate => $fileDate } ); }; $err = $@; } else { print "Add topic $web.$topic\n"; return 1 if ($inactive); print < 'Saved by install script' } ); }; $err = $@; } return ( !$err ); } sub _uninstall { my $file; my @dead; foreach $file ( keys %$MANIFEST ) { if ( -e $file ) { push( @dead, remap($file) ); } } unless ( $#dead > 1 ) { print STDERR "No part of $MODULE is installed\n"; return 0; } print "To uninstall $MODULE, the following files will be deleted:\n"; print "\t" . join( "\n\t", @dead ) . "\n"; return 1 if $inactive; my $reply = ask("Are you SURE you want to uninstall $MODULE?"); if ($reply) { if (defined &Foswiki::preuninstall) { Foswiki::preuninstall(); } elsif (defined &TWiki::preuninstall) { TWiki::preuninstall(); } foreach $file ( keys %$MANIFEST ) { if ( -e $file ) { unlink($file); } } if (defined &Foswiki::postuninstall) { Foswiki::postuninstall(); } elsif (defined &TWiki::postuninstall) { TWiki::postuninstall(); } print "### $MODULE uninstalled ###\n"; } return 1; } # 1 Check dependencies # 2 Transfer files from temporary unpack area to the target installation # 3 Check in any files with existing ,vs on disc # 4 Perform post-install sub _emplace { my $source = shift; # For each file in the MANIFEST, move the file into the installation, # set the permissions, and check if it is a data or pub file. If it is, # then check it in. my @ci_topic; # topics to checkin my @ci_attachment; # topics to checkin my $file; foreach $file ( keys %$MANIFEST ) { my $source = "$source/$file"; my $target = remap($file); print "Install $target, permissions $MANIFEST->{$file}->{perms}\n"; unless ($inactive) { if ( -e $target ) { # Save current permissions, remove write protect for Windows sake, # Back up the file and then restore the original permissions my $mode = (stat($file))[2]; chmod( oct(600), "$target"); chmod( oct(600), "$target.bak") if ( -e "$target.bak"); if ( File::Copy::move( $target, "$target.bak" ) ) { chmod( $mode, "$target.bak"); } else { print STDERR "Could not create $target.bak: $!\n"; } } my @path = split( /[\/\\]+/, $target ); pop(@path); if ( scalar(@path) ) { File::Path::mkpath( join( '/', @path ) ); } File::Copy::move( $source, $target ) || die "Failed to move $source to $target: $!\n"; } unless ($inactive) { chmod( oct( $MANIFEST->{$file}->{perms} ), $target ) || print STDERR "WARNING: cannot set permissions on $target: $!\n"; } if ( $MANIFEST->{$file}->{ci} ) { if ( $target =~ /^data\/(\w+)\/(\w+).txt$/ ) { push( @ci_topic, $target ); } elsif ( $target =~ /^pub\/(\w+)\/(\w+)\/([^\/]+)$/ ) { push( @ci_attachment, $target ); } } } my @bads; foreach $file (@ci_topic) { $file =~ /^data\/(.*)\/(\w+).txt$/; unless ( checkin( $1, $2, undef ) ) { push( @bads, $file ); } } foreach $file (@ci_attachment) { $file =~ /^pub\/(.*)\/(\w+)\/([^\/]+)$/; unless ( checkin( $1, $2, $3 ) ) { push( @bads, $file ); } } if ( scalar(@bads) ) { print STDERR ' WARNING: I cannot automatically update the local revision history for:', "\n\t"; print STDERR join( "\n\t", @bads ); print STDERR <{$file}->{ci} = ( $desc =~ /\(noci\)/ ? 0 : 1 ); $MANIFEST->{$file}->{perms} = $perms; } my @deps; foreach my $row ( split( /\r?\n/, $data{DEPENDENCIES} ) ) { my ( $module, $condition, $trigger, $type, $desc ) = split( ',', $row, 5 ); $module = Foswiki::Sandbox::untaint( $module, \&_validatePerlModule ); if ( $trigger eq '1' ) { # ONLYIF usually isn't used, and is dangerous push( @deps, { name => $module, type => $type, version => $condition, # version condition trigger => 1, # ONLYIF condition description => $desc, } ); } else { # There is a ONLYIF condition, warn user print 'The script uses an ONLYIF condition' . ' which is potentially insecure: "' . $trigger . "\"\n"; if ( $trigger =~ /^[a-zA-Z:\s<>0-9.()]*$/ ) { # It looks more or less safe push( @deps, { name => $module, type => $type, version => $condition, # version condition trigger => $1, # ONLYIF condition description => $desc, } ); } else { print 'This ' . $trigger . ' condition does not look safe.'; if (running_from_configure) { print < $module, type => $type, version => $condition, # version condition trigger => Foswiki::Sandbox::untaintUnchecked($1) , # ONLYIF condition description => $desc, } ); } } } } } unshift( @INC, 'lib' ); my $n = 0; my $action = 'install'; while ( $n < scalar(@ARGV) ) { if ( $ARGV[$n] eq '-a' ) { $noconfirm = 1; } elsif ( $ARGV[$n] eq '-d' ) { $downloadOK = 1; } elsif ( $ARGV[$n] eq '-r' ) { $reuseOK = 1; } elsif ( $ARGV[$n] eq '-n' ) { $inactive = 1; } elsif ( $ARGV[$n] eq '-u' ) { $alreadyUnpacked = 1; } elsif ( $ARGV[$n] =~ m/(install|uninstall|manifest|dependencies)/ ) { $action = $1; } # SMELL: There really shouldn't be a null argument. But installer breaks if it is there. elsif ( $ARGV[$n] eq '' ) { $n++; next; } else { usage(); die 'Bad parameter ' . $ARGV[$n]; } $n++; } if ( $action eq 'manifest' ) { foreach my $row ( split( /\r?\n/, $data{MANIFEST} ) ) { my ( $file, $perms, $desc ) = split( ',', $row, 3 ); print "$file $perms $desc\n"; } exit 0; } if ( $action eq 'dependencies' ) { foreach my $dep (@deps) { if ( $dep->{trigger} && $dep->{trigger} != '1' ) { print "ONLYIF $dep->{trigger}\n"; } print "$dep->{name},$dep->{version},$dep->{type},$dep->{description}\n"; } exit 0; } print "\n### ${MODULE} Installer ###\n\n"; print <