# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/ # # Copyright (C) 1999-2007 TWiki Contributors. All Rights Reserved. # TWiki 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 TWiki::Extender; use strict; use Cwd; use File::Temp; use File::Copy; use File::Path; no warnings 'redefine'; my $noconfirm = 0; my $inactive = 0; my $twiki; my $twiki4OrMore; my %available; my $lwp; my @archTypes = ( '.tgz', '.tar.gz', '.zip' ); my %cfg; my $installationRoot; my $MODULE; my $PACKAGES_URL; my $MANIFEST; BEGIN { $installationRoot = Cwd::getcwd(); my $check_perl_module = sub { my $module = shift; eval "use $module;"; if( $@ ) { print "Warning: $module is not available, some installer functions have been disabled\n"; $available{$module} = 0; } else { $available{$module} = 1; } return $available{$module}; }; unless ( -d 'lib' && -d 'bin' && -e 'bin/setlib.cfg' ) { die 'This installer must be run from the root directory of a TWiki installation'; } # read setlib.cfg chdir('bin'); require 'setlib.cfg'; # See if we can make a TWiki. If we can, then we can save topic # and attachment histories. Key off TWiki::Merge because it was # added in Dakar. if( &$check_perl_module( 'TWiki::Merge' )) { eval { require TWiki; # We have to get the admin user, as a guest user may be blocked. # TWiki 4.2 has AdminUserLogin; for earlier releases, we need to # do something a bit different. my $user = $TWiki::cfg{AdminUserLogin} || 'admin'; $twiki = new TWiki($user); # Compatibility with 4.0 <= TWiki::VERSION < 4.2 if ($twiki->{users}->can('findUser')) { $TWiki::Plugins::SESSION = $twiki; $twiki->{user} = $twiki->{users}->findUser( $TWiki::cfg{AdminUserWikiName}, $TWiki::cfg{AdminUserWikiName}); } chdir($installationRoot); $twiki4OrMore = 1; }; # if it fails, fall back to old behaviour } else { # Not TWiki-4 chdir($installationRoot); no strict; do 'lib/TWiki.cfg'; if( -e 'lib/LocalSite.cfg') { do 'lib/LocalSite.cfg'; } use strict; $twiki4OrMore = 0; } if( &$check_perl_module( 'LWP' )) { $lwp = new LWP::UserAgent(); $lwp->agent("TWikiPluginsInstaller"); $lwp->env_proxy(); } &$check_perl_module( 'CPAN' ); } =pod ---+ StaticMethod remap ($file ) -> $file Given a "canonical" path, convert it using the remappings in LocalSite.cfg to a site- specific path. For example, if a site defines: $TWiki::cfg{UsersWebName} = 'Users'; then this function will convert =data/Main/Burble.txt= to =data/Users/Burble.txt=. Note: remapping only works for TWiki 4 and later. Anyone who cares enough can write and test the mappings for Cairo. =cut sub remap { my $file = shift; if (defined $cfg{SitePrefsTopicName}) { $file =~ s#^data/(TWiki|Main)/TWikiPreferences\.txt(.*)$#data/$1/$cfg{SitePrefsTopicName}.txt$2#; } if (defined $cfg{UsersTopicName}) { $file =~ s#(Main)/TWikiUsers\.txt(.*)$#$1/$cfg{UsersTopicName}.txt$2#; } foreach my $w qw( SystemWebName TrashWebName UsersWebName ) { if (defined $cfg{$w}) { $file =~ s#^data/$w/#data/$cfg{$w}/#; $file =~ s#^pub/$w/#pub/$cfg{$w}/#; } } foreach my $t qw( NotifyTopicName HomeTopicName WebPrefsTopicName MimeTypesFileName ) { if (defined $cfg{$t}) { $file =~ s#^data/(.*)/$t\.txt(,v)?#data/$1/$cfg{$t}.txt$2/#; $file =~ s#^pub/(.*)/$t/([^/]*)$#pub/$1/$cfg{$t}/$2/#; } } return $file; } sub check_dep { my $dep = shift; my( $ok, $msg ) = (1, ''); if( $dep->{type} =~ /^(perl|cpan)$/i ) { # Try to 'use' the perl module eval 'use '.$dep->{name}; if( $@ ) { $msg = $@; $msg =~ s/ in .*$/\n/s; $ok = 0; } else { # OK, it was loaded. See if a version constraint is specified if( defined( $dep->{version} ) ) { my $ver; # check the $VERSION variable in the loaded module eval '$ver = $'.$dep->{name}.'::VERSION;'; if( $@ || !defined( $ver ) ) { $msg .= 'The VERSION of the package could not be found: '. $@; $ok = 0; } else { # The version variable exists. Clean it up $ver =~ s/^.*\$Rev: (\d+)\$.*$/$1/; $ver =~ s/[^\d]//g; $ver ||= 0; eval '$ok = ( $ver '.$dep->{version}.' )'; if( $@ || ! $ok ) { # The version variable fails the constraint $msg .= ' '.$ver.' is currently installed: '.$@; $ok = 0; } } } } } else { # This module has no perl interface, and can't be checked $ok = 0; $msg = <{type}, and cannot be automatically checked. Please check it manually and install if necessary. END } 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 TWiki 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 ) { 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/^TWiki::(Contrib|Plugins)::(\w*)/ ) { my $pack = $1; my $packname = $2; $packname .= $pack if( $pack eq 'Contrib' && $packname !~ /Contrib$/); my $reply = ask('Would you like me to try to download and install the latest version of '.$packname.' from twiki.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; } # DEPRECATED - do not use - install a .spec instead # ---++ StaticMethod getConfig( $major, $minor, $cairo ) -> $string # * =$major= name of major key. # * =$minor= if undefined, there is no minor key # * =$cairo= expression that when evaled will get the cairo style config var # Get the value of a config var, trying first the Dakar option and # then if that fails, the Cairo name (if any). # Example: # =getConfig("Name")= # will get the value of =$TWiki::cfg{Name}=. # =getConfig("MyPlugin", "Name")= # will get the value of =$TWiki::cfg{Name}=. # =getConfig("HomeTopicName", undef, '$mainTopicname')= # will get the name of the WebHome topic on Dakar and Cairo. # # See setConfig for more information on major/minor keys. sub getConfig { my( $major, $minor, $cairo ) = @_; if( $minor && defined $TWiki::cfg{$major}{$minor} ) { return getTWikiCfg("{$major}{$minor}"); } if (!$minor && defined $TWiki::cfg{$major}) { return getTWikiCfg("{$minor}"); } if( defined $cairo ) { return eval $cairo; } return undef; } # DEPRECATED - do not use - install a .spec instead # ---++ StaticMethod commentConfig( $comment ) # * $comment - comment to insert in LocalSite.cfg, usually before a setConfig # Inserts a comment into LocalSite.cfg. The comment will usually describe a following setConfig; for example, # # commentConfig( < 'Mercedes' ); # sub commentConfig { open(F, ">>lib/LocalSite.cfg") || die "Failed to open lib/LocalSite.cfg for write"; print F $_[0]; close(F); } # DEPRECATED - do not use - install a .spec instead # ---++ StaticMethod setConfig( $major, ... ) # * =$major= if defined, name of major key. If not given, there is no major key and the minorkeys are treated as major keys # * =...= list of minorkey=>value pairs # Set the given configuration variables in LocalSite.cfg. =$value= must be # complete with all syntactic sugar, including quotes. # The valued are written to $TWiki::cfg{major key}{setting} if a major # key is given (recommended, use the plugin name) or $TWiki::cfg{setting} otherwise. Example: # # setConfig( 'CarsPlugin', Name=>"'Mercedes'" }; # setConfig( Tools => "qw(hammer saw screwdriver)" }; # # will write # # $TWiki::cfg{CarsPlugin}{Best} = 'Mercedes'; # $TWiki::cfg{Tools} = qw(hammer saw screwdriver); # sub setConfig { my @settings = @_; my $txt; my $key; if (scalar(@settings) % 2) { # pluck the first odd parameter off to be the major key $key = shift @settings; } my %keys = @settings; if( -e "lib/LocalSite.cfg" ) { open(F, "; close(F); $txt =~ s/\n+1;\s*//gs; # kill the old settings (and previous comment) if any are there foreach my $setting ( keys %keys ) { if( $key ) { $txt =~ s/(# \*\*.*?\n(#.*?\n))?\$TWiki::cfg{$key}{$setting}\s*=.*;\r?\n//s; } else { $txt =~ s/(# \*\*.*?\n(#.*?\n))?\$TWiki::cfg{$setting}\s*=.*;\r?\n//s; } } } $txt .= "\n" unless $txt =~ /\n$/s; open(F, ">lib/LocalSite.cfg") || die "Failed to open lib/LocalSite.cfg for write"; print F $txt if $txt; foreach my $setting ( keys %keys ) { if( defined $key ) { print F '$TWiki::cfg{'.$key.'}{'.$setting.'} = '; } else { print F '$TWiki::cfg{'.$setting.'} = '; } print F $keys{$setting}, ";\n"; } print F "1;\n"; close(F); # is this Cairo or earlier? If it is, we need to include # LocalSite.cfg from TWiki.cfg unless( $twiki4OrMore ) { open(F, "; close(F); unless( $txt =~ /^do.*LocalSite\.cfg/m ) { $txt =~ s/^\s*1\s*;\s*$//m; open(F, ">lib/TWiki.cfg") || die "Failed to open lib/TWiki.cfg for write"; print F "$txt\ndo 'LocalSite.cfg';\n1;\n"; close(F); } } } # 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; 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: $!"; print F $response->content(); close(F); last; } } unless ($f && -e $f) { print STDERR "Failed to download $module $what\n", $response->status_line(),"\n"; return undef; } 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 .= ' -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; eval 'use Archive::Zip'; unless ( $@ ) { my $zip = new Archive::Zip( $archive ); unless ( $zip ) { print STDERR "Could not open zip file $archive\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' : ''; eval 'use Archive::Tar'; unless ( $@ ) { print STDERR `pwd;ls`; my $tar = Archive::Tar->new( $archive, $compressed ); unless ( $tar ) { print STDERR "Could not open tar file $archive\n"; return 0; } my @members = $tar->list_files(); foreach my $file ( @members ) { my $target = $file; my $err = $tar->extract_file( $file, $target ); unless ( $err ) { 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. On Cairo, do nothing because the apache user # has everything checked out :-( sub checkin { my( $web, $topic, $file ) = @_; # If this is Dakar, we have a good chance of completing the # install. my $err = 1; if( $twiki ) { if( $file ) { my $origfile = $TWiki::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 { TWiki::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 ) { TWiki::preuninstall(); foreach $file ( keys %$MANIFEST ) { if( -e $file ) { unlink( $file ); } } 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 @topic; my @pub; my @bads; my $file; foreach $file ( keys %$MANIFEST ) { my $source = "$source/$file"; my $target = remap($file); print "Install $target, permissions $MANIFEST->{$file}\n"; unless ($inactive) { if (-e $target) { unless (File::Copy::move($target, "$target.bak")) { 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"; } if( $target =~ /^data\/(\w+)\/(\w+).txt$/ ) { push(@topic, $target); } elsif( $target =~ /^pub\/(\w+)\/(\w+)\/([^\/]+)$/ ) { push(@pub, $target); } unless( $inactive ) { chmod( oct($MANIFEST->{$file}), $target ) || print STDERR "WARNING: cannot set permissions on $target: $!\n"; } } foreach $file ( @topic ) { $file =~ /^data\/(.*)\/(\w+).txt$/; unless( checkin( $1, $2, undef )) { push( @bads, $file ); } } foreach $file ( @pub ) { $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} = $perms; } my @deps; foreach my $row (split(/\r?\n/, $data{DEPENDENCIES})) { my ($module, $condition, $trigger, $type, $desc) = split(',', $row, 5); push(@deps, { name=>$module, type=>$type, version=>$condition, # version condition trigger => $trigger, # 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 '-n' ) { $inactive = 1; } elsif( $ARGV[$n] =~ m/(install|uninstall|manifest|dependencies)/ ) { $action = $1; } 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 <