lib/TWiki/Configure/UIs/EXTEND.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
permissions -rw-r--r--
RELEASE 4.2.0 freetown
colas@0
     1
#
colas@0
     2
# TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0
     3
#
colas@0
     4
# Copyright (C) 2000-2006 TWiki Contributors.
colas@0
     5
#
colas@0
     6
# This program is free software; you can redistribute it and/or
colas@0
     7
# modify it under the terms of the GNU General Public License
colas@0
     8
# as published by the Free Software Foundation; either version 2
colas@0
     9
# of the License, or (at your option) any later version. For
colas@0
    10
# more details read LICENSE in the root of this distribution.
colas@0
    11
#
colas@0
    12
# This program is distributed in the hope that it will be useful,
colas@0
    13
# but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0
    14
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0
    15
#
colas@0
    16
# As per the GPL, removal of this notice is prohibited.
colas@0
    17
package TWiki::Configure::UIs::EXTEND;
colas@0
    18
use base 'TWiki::Configure::UI';
colas@0
    19
colas@0
    20
use strict;
colas@0
    21
use File::Temp;
colas@0
    22
use File::Copy;
colas@0
    23
use File::Spec;
colas@0
    24
use Cwd;
colas@0
    25
colas@0
    26
sub ui {
colas@0
    27
    my $this = shift;
colas@0
    28
    my $query = $TWiki::query;
colas@0
    29
    my $ar;
colas@0
    30
    my $extension = $query->param('extension');
colas@0
    31
    my $ext = '.tgz';
colas@0
    32
colas@0
    33
    $this->findRepositories();
colas@0
    34
colas@0
    35
    my $repository = $this->getRepository($query->param('repository'));
colas@0
    36
    if (!defined($repository)) {
colas@0
    37
        return $this->ERROR("Repository not found. <pre> ".$query->param('repository')." </pre>");
colas@0
    38
    }
colas@0
    39
    my $arf = $repository->{pub}.$extension.'/'.$extension.$ext;
colas@0
    40
colas@0
    41
    print "<br/>Fetching $arf...<br />\n";
colas@0
    42
    my $response = $this->getUrl($arf);
colas@0
    43
    if (!$response->is_error()) {
colas@0
    44
        eval { $ar = $response->content(); };
colas@0
    45
    } else {
colas@0
    46
        $@ = $response->message();
colas@0
    47
    }
colas@0
    48
colas@0
    49
    if ($@) {
colas@0
    50
        print $this->WARN(<<HERE);
colas@0
    51
I can't download $arf because of the following error:
colas@0
    52
<pre>$@</pre>
colas@0
    53
HERE
colas@0
    54
        undef $ar;
colas@0
    55
    }
colas@0
    56
colas@0
    57
    if (!defined($ar)) {
colas@0
    58
        print $this->WARN(<<HERE);
colas@0
    59
Extension may not have been packaged correctly.
colas@0
    60
Trying for a .zip file instead.
colas@0
    61
HERE
colas@0
    62
        $ext = '.zip';
colas@0
    63
        $arf = $repository->{pub}.$extension.'/'.$extension.$ext;
colas@0
    64
        print "<br/>Fetching $arf...<br />\n";
colas@0
    65
        $response = $this->getUrl($arf);
colas@0
    66
        if (!$response->is_error()) {
colas@0
    67
            eval { $ar = $response->content(); };
colas@0
    68
        } else {
colas@0
    69
            $@ = $response->message();
colas@0
    70
        }
colas@0
    71
        if ($@) {
colas@0
    72
            print $this->WARN(<<HERE);
colas@0
    73
I can't download $arf because of the following error:
colas@0
    74
<pre>$@</pre>
colas@0
    75
HERE
colas@0
    76
            undef $ar;
colas@0
    77
        }
colas@0
    78
    }
colas@0
    79
colas@0
    80
    unless ($ar) {
colas@0
    81
        return $this->ERROR(<<MESS);
colas@0
    82
Please follow the published process for manual installation from the
colas@0
    83
command line.
colas@0
    84
MESS
colas@0
    85
    }
colas@0
    86
colas@0
    87
    # Strip HTTP headers if necessary
colas@0
    88
    $ar =~ s/^HTTP(.*?)\r\n\r\n//sm;
colas@0
    89
colas@0
    90
    # Save it somewhere it will be cleaned up
colas@0
    91
    my ($tmp, $tmpfilename) = File::Temp::tempfile(SUFFIX => $ext, UNLINK=>1);
colas@0
    92
    binmode($tmp);
colas@0
    93
    print $tmp $ar;
colas@0
    94
    $tmp->close();
colas@0
    95
    print "Unpacking...<br />\n";
colas@0
    96
    my $dir = _unpackArchive($tmpfilename);
colas@0
    97
colas@0
    98
    my @names = _listDir($dir);
colas@0
    99
    # install the contents
colas@0
   100
    my $installScript = undef;
colas@0
   101
    unless ($query->param('confirm')) {
colas@0
   102
        foreach my $file (@names) {
colas@0
   103
            my $ef = $this->_findTarget($file);
colas@0
   104
            if (-e $ef && !-d $ef) {
colas@0
   105
                my $mess = "Note: Existing $file overwritten.";
colas@0
   106
                if (File::Copy::move($ef, "$ef.bak")) {
colas@0
   107
                    $mess .= " Backup saved in $ef.bak";
colas@0
   108
                }
colas@0
   109
                print $this->NOTE("$mess<br />");
colas@0
   110
            } else {
colas@0
   111
                print "$file<br />";
colas@0
   112
            }
colas@0
   113
            if( $file =~ /^${extension}_installer(\.pl)?$/) {
colas@0
   114
                $installScript = $this->_findTarget($file);
colas@0
   115
            }
colas@0
   116
        }
colas@0
   117
        unless ($installScript) {
colas@0
   118
            print $this->WARN(
colas@0
   119
                "No installer script found in archive");
colas@0
   120
        }
colas@0
   121
    }
colas@0
   122
colas@0
   123
    # foreach file in archive, move it to the correct place
colas@0
   124
    foreach my $file (@names) {
colas@0
   125
        # The file may already have been moved along with its directory
colas@0
   126
        next unless -e "$dir/$file";
colas@0
   127
        # Find where it is meant to go
colas@0
   128
        my $ef = $this->_findTarget($file);
colas@0
   129
        if (-e $ef && !-d $ef && !-w $ef) {
colas@0
   130
            print $this->ERROR("No permission to write to $ef");
colas@0
   131
            die "Installation terminated";
colas@0
   132
        } elsif (!-d $ef) {
colas@0
   133
            if (-d "$dir/$file") {
colas@0
   134
                unless (mkdir($ef)) {
colas@0
   135
                    print $this->ERROR(
colas@0
   136
                        "Cannot create directory $ef: $!");
colas@0
   137
                    die "Installation terminated";
colas@0
   138
                }
colas@0
   139
            } elsif (!File::Copy::move("$dir/$file", $ef)) {
colas@0
   140
                print $this->ERROR("Failed to move file '$file' to $ef: $!");
colas@0
   141
                die "Installation terminated";
colas@0
   142
            };
colas@0
   143
        }
colas@0
   144
    }
colas@0
   145
colas@0
   146
    if ($installScript && -e $installScript) {
colas@0
   147
        # invoke the installer script.
colas@0
   148
        # SMELL: Not sure yet how to handle
colas@0
   149
        # interaction if the script ignores -a. At the moment it
colas@0
   150
        # will just hang :-(
colas@0
   151
        chdir($this->{root});
colas@0
   152
        unshift(@ARGV, '-a');
colas@0
   153
        print "<pre>\n";
colas@0
   154
        eval {
colas@0
   155
            no warnings 'redefine';
colas@0
   156
            do $installScript;
colas@0
   157
            use warnings 'redefine';
colas@0
   158
            die $@ if $@; # propagate
colas@0
   159
        };
colas@0
   160
        print "</pre>\n";
colas@0
   161
        if ($@) {
colas@0
   162
            print $this->ERROR(<<HERE);
colas@0
   163
Installer returned errors:
colas@0
   164
<pre>$@</pre>
colas@0
   165
You may be able to resolve these errors and complete the installation
colas@0
   166
from the command line, so I will leave the installed files where they are.
colas@0
   167
HERE
colas@0
   168
        } else {
colas@0
   169
            print $this->NOTE("Installer ran without errors");
colas@0
   170
        }
colas@0
   171
        chdir($this->{bin});
colas@0
   172
    }
colas@0
   173
colas@0
   174
    if ($this->{warnings}) {
colas@0
   175
        print $this->NOTE(
colas@0
   176
            "Installation finished with $this->{errors} error".
colas@0
   177
              ($this->{errors}==1?'':'s').
colas@0
   178
                " and $this->{warnings} warning".
colas@0
   179
                  ($this->{warnings}==1?'':'s'));
colas@0
   180
    } else {
colas@0
   181
        print 'Installation finished.';
colas@0
   182
    }
colas@0
   183
    unless ($installScript) {
colas@0
   184
        print $this->WARN(<<HERE);
colas@0
   185
You should test this installation very carefully, as there is no installer
colas@0
   186
script. This suggests that $arf may have been generated manually, and may
colas@0
   187
require further manual configuration.
colas@0
   188
HERE
colas@0
   189
    }
colas@0
   190
    if ($extension =~ /Plugin$/) {
colas@0
   191
        print $this->NOTE(<<HERE);
colas@0
   192
Note: Before you can use newly installed plugins, you must enable them in the
colas@0
   193
"Plugins" section in the main page.
colas@0
   194
HERE
colas@0
   195
    }
colas@0
   196
colas@0
   197
    return '';
colas@0
   198
}
colas@0
   199
colas@0
   200
# Find the installation target of a single file. This involves remapping
colas@0
   201
# through the settings in LocalSIte.cfg. If the target is not remapped, then
colas@0
   202
# the file is installed relative to the root, which is the directory
colas@0
   203
# immediately above bin.
colas@0
   204
sub _findTarget {
colas@0
   205
    my ($this, $file) = @_;
colas@0
   206
colas@0
   207
    if ($file =~ s#^data/#$TWiki::cfg{DataDir}/#) {
colas@0
   208
    } elsif ($file =~ s#^pub/#$TWiki::cfg{PubDir}/#) {
colas@0
   209
    } elsif ($file =~ s#^templates/#$TWiki::cfg{TemplateDir}/#) {
colas@0
   210
    } elsif ($file =~ s#^locale/#$TWiki::cfg{LocalesDir}/#) {
colas@0
   211
    } elsif ($file =~ s#^(bin/\w+)$#$this->{root}$1$TWiki::cfg{ScriptSuffix}#) {
colas@0
   212
    } else {
colas@0
   213
        $file = File::Spec->catfile($this->{root}, $file);
colas@0
   214
    }
colas@0
   215
    $file =~ /^(.*)$/;
colas@0
   216
    return $1;
colas@0
   217
}
colas@0
   218
colas@0
   219
# Recursively list a directory
colas@0
   220
sub _listDir {
colas@0
   221
    my ($dir, $path) = @_;
colas@0
   222
    $path ||= '';
colas@0
   223
    $dir .= '/' unless $dir =~ /\/$/;
colas@0
   224
    my $d;
colas@0
   225
    my @names = ();
colas@0
   226
    if (opendir($d, "$dir/$path")) {
colas@0
   227
        foreach my $f ( grep { !/^\.*$/ } readdir $d ) {
colas@0
   228
            if (-d "$dir$path/$f") {
colas@0
   229
                push(@names, "$path$f/");
colas@0
   230
                push(@names, _listDir($dir, "$path$f/"));
colas@0
   231
            } else {
colas@0
   232
                push(@names, "$path$f");
colas@0
   233
            }
colas@0
   234
        }
colas@0
   235
        closedir($d);
colas@0
   236
    }
colas@0
   237
    return @names;
colas@0
   238
}
colas@0
   239
colas@0
   240
=pod
colas@0
   241
colas@0
   242
---++ StaticMethod _unpackArchive($archive [,$dir] )
colas@0
   243
Unpack an archive. The unpacking method is determined from the file
colas@0
   244
extension e.g. .zip, .tgz. .tar, etc. If $dir is not given, unpack
colas@0
   245
to a temporary directory, the name of which is returned.
colas@0
   246
colas@0
   247
=cut
colas@0
   248
colas@0
   249
sub _unpackArchive {
colas@0
   250
    my ($name, $dir) = @_;
colas@0
   251
colas@0
   252
    $dir ||= File::Temp::tempdir(CLEANUP=>1);
colas@0
   253
    my $here = Cwd::getcwd();
colas@0
   254
    chdir( $dir );
colas@0
   255
    unless( $name =~ /\.zip/i && _unzip( $name ) ||
colas@0
   256
              $name =~ /(\.tar\.gz|\.tgz|\.tar)/ && _untar( $name )) {
colas@0
   257
        $dir = undef;
colas@0
   258
        print "Failed to unpack archive $name<br />\n";
colas@0
   259
    }
colas@0
   260
    chdir( $here );
colas@0
   261
colas@0
   262
    return $dir;
colas@0
   263
}
colas@0
   264
colas@0
   265
sub _unzip {
colas@0
   266
    my $archive = shift;
colas@0
   267
colas@0
   268
    eval 'use Archive::Zip';
colas@0
   269
    unless ( $@ ) {
colas@0
   270
        my $zip = Archive::Zip->new( $archive );
colas@0
   271
        unless ( $zip ) {
colas@0
   272
            print "Could not open zip file $archive<br />\n";
colas@0
   273
            return 0;
colas@0
   274
        }
colas@0
   275
colas@0
   276
        my @members = $zip->members();
colas@0
   277
        foreach my $member ( @members ) {
colas@0
   278
            my $file = $member->fileName();
colas@0
   279
            my $target = $file ;
colas@0
   280
            my $err = $zip->extractMember( $file, $target );
colas@0
   281
            if ( $err ) {
colas@0
   282
                print "Failed to extract '$file' from zip file ",
colas@0
   283
                  $zip,". Archive may be corrupt.<br />\n";
colas@0
   284
                return 0;
colas@0
   285
            }
colas@0
   286
        }
colas@0
   287
    } else {
colas@0
   288
        print "Archive::Zip is not installed; trying unzip on the command line<br />\n";
colas@0
   289
        print `unzip $archive`;
colas@0
   290
        # On certain older versions of perl / unzip it seems the unzip results
colas@0
   291
        # in an illegal seek error. But running the same command again often
colas@0
   292
        # goes well. Seems like the 2nd pass works because the subdirectories
colas@0
   293
        # are then created. A hack but it seems to work.
colas@0
   294
        if ( $! ) {
colas@0
   295
            print `unzip $archive`;
colas@0
   296
            if ( $! ) {
colas@0
   297
                print "unzip failed: $!\n";
colas@0
   298
                return 0;
colas@0
   299
            }
colas@0
   300
        }
colas@0
   301
    }
colas@0
   302
colas@0
   303
    return 1;
colas@0
   304
}
colas@0
   305
colas@0
   306
sub _untar {
colas@0
   307
    my $archive = shift;
colas@0
   308
colas@0
   309
    my $compressed = ( $archive =~ /z$/i ) ? 'z' : '';
colas@0
   310
colas@0
   311
    eval 'use Archive::Tar';
colas@0
   312
    unless ( $@ ) {
colas@0
   313
        my $tar = Archive::Tar->new( $archive, $compressed );
colas@0
   314
        unless ( $tar ) {
colas@0
   315
            print "Could not open tar file $archive<br />\n";
colas@0
   316
            return 0;
colas@0
   317
        }
colas@0
   318
colas@0
   319
        my @members = $tar->list_files();
colas@0
   320
        foreach my $file ( @members ) {
colas@0
   321
            my $err = $tar->extract( $file );
colas@0
   322
            unless ( $err ) {
colas@0
   323
                print 'Failed to extract ',$file,' from tar file ',
colas@0
   324
                  $tar,". Archive may be corrupt.<br />\n";
colas@0
   325
                return 0;
colas@0
   326
            }
colas@0
   327
        }
colas@0
   328
    } else {
colas@0
   329
        print "Archive::Tar is not installed; trying tar on the command-line<br />\n";
colas@0
   330
        print `tar xvf$compressed $archive`;
colas@0
   331
        if ( $! ) {
colas@0
   332
            print "tar failed: $!\n";
colas@0
   333
            return 0;
colas@0
   334
        }
colas@0
   335
    }
colas@0
   336
colas@0
   337
    return 1;
colas@0
   338
}
colas@0
   339
colas@0
   340
1;