#
# TWiki Enterprise Collaboration Platform, http://TWiki.org/
#
# Copyright (C) 2000-2006 TWiki Contributors.
#
# 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.
use strict;

package TWiki::Configure::UIs::EXTEND;

use TWiki::Configure::UI;

use base 'TWiki::Configure::UI';
use File::Temp;
use File::Copy;
use Cwd;

sub new {
    my $class = shift;
    my $this = bless($class->SUPER::new(@_), $class);

    push(@{$this->{repositories}},
         { data => 'http://twiki.org/cgi-bin/view/Plugins/',
           pub => 'http://twiki.org/p/pub/Plugins/' } );

    $this->{bin} = $FindBin::Bin;
    my @root = File::Spec->splitdir($this->{bin});
    pop(@root);
    $this->{root} = File::Spec->catfile(@root, '');

    return $this;
}

sub ui {
    my $this = shift;
    my $query = $TWiki::query;
    my $ar;
    my $extension = $query->param('extension');
    my $ext = '.tgz';
    my $arf = $query->param('pub').$extension.'/'.$extension.$ext;

    print "<br/>Fetching $arf...<br />\n";
    eval {
        $ar = $this->getUrl($arf);
    };

    if ($@) {
        print $this->WARN(<<HERE);
I can't download $arf because of the following error:
<pre>$@</pre>
HERE
        undef $ar;
    } elsif ($ar !~ s!^.*Content-Type: application/x-gzip\r\n\r\n!!is) {
        print $this->WARN(<<HERE);
I can't install $arf because I don't recognise the download
as a gzip file.
HERE
        undef $ar;
    }

    if (!defined($ar)) {
        print $this->WARN(<<HERE);
Extension may not have been packaged correctly.
Trying for a .zip file instead.
HERE
        $ext = '.zip';
        $arf = $query->param('pub').$extension.'/'.$extension.$ext;
        print "<br/>Fetching $arf...<br />\n";
        eval {
            $ar = $this->getUrl($arf);
        };
        if ($@) {
            print $this->WARN(<<HERE);
I can't download $arf because of the following error:
<pre>$@</pre>
HERE
            undef $ar;
        } elsif ($ar !~ s#^.*Content-Type: application/zip\r\n\r\n##is) {
            print $this->WARN(<<HERE);
I can't install $arf because I don't recognise the download
as a zip file.
HERE
            $ar = undef;
        }
    }

    unless ($ar) {
        return $this->ERROR(<<MESS);
Please follow the published process for manual installation from the
command line.
MESS
    }

    # Save it somewhere it will be cleaned up
    my $tmp = new File::Temp(SUFFIX => $ext, UNLINK=>1);
    binmode($tmp);
    print $tmp $ar;
    $tmp->close();
    print "Unpacking...<br />\n";
    my $dir = _unpackArchive($tmp->filename());

    my @names = _listDir($dir);
    # install the contents
    my $sawInstaller = 0;
    unless ($query->param('confirm')) {
        foreach my $file (@names) {
            my $ef = $this->_findTarget($file);
            if (-e $ef && !-d $ef) {
                my $mess = "Note: Existing $file overwritten.";
                if (File::Copy::move($ef, "$ef.bak")) {
                    $mess .= " Backup saved in $ef.bak";
                }
                print $this->NOTE("$mess<br />");
            } else {
                print "$file<br />";
            }
            if( $file =~ /^${extension}_installer.pl/) {
                $sawInstaller = 1;
            }
        }
        unless ($sawInstaller) {
            print $this->WARN(
                "No ${extension}_installer.pl script found in archive");
        }
    }

    # foreach file in archive, move it to the correct place
    foreach my $file (@names) {
        # The file may already have been moved along with its directory
        next unless -e "$dir/$file";
        # Find where it is meant to go
        my $ef = $this->_findTarget($file);
        if (-e $ef && !-d $ef && !-w $ef) {
            print $this->ERROR("No permission to write to $ef");
        } elsif (!-d $ef) {
            unless (File::Copy::move("$dir/$file", $ef)) {
                print $this->ERROR("Failed to move file '$file' to $ef: $!");
            };
            die "$@ on $ef" if $@;
        }
    }
    if (-e "$this->{root}/${extension}_installer.pl") {
        # invoke the installer script.
        # SMELL: Not sure yet how to handle
        # interaction if the script ignores -a. At the moment it
        # will just hang :-(
        chdir($this->{root});
        unshift(@ARGV, '-a');
        eval {
            do '$this->{root}/${extension}_installer.pl';
            die $@ if $@; # propagate
        };
        if ($@) {
            print $this->ERROR(<<HERE);
${extension}_installer.pl returned errors:
<pre>$@</pre>
You may be able to resolve these errors and complete the installation
from the command line, so I will leave the installed files where they are.
HERE
        } else {
            print $this->NOTE("${extension}_installer.pl ran without errors");
        }
        chdir($this->{bin});
    }

    if ($this->{warnings}) {
        print $this->NOTE(
            "Installation finished with $this->{errors} error".
              ($this->{errors}==1?'':'s').
                " and $this->{warnings} warning".
                  ($this->{warnings}==1?'':'s'));
    } else {
        print 'Installation finished.';
    }
    unless ($sawInstaller) {
        print $this->WARN(<<HERE);
You should test this installation very carefully, as there is no installer
script. This suggests that $arf may have been generated manually, and may
require further manual configuration.
HERE
    }
    if ($extension =~ /Plugin$/) {
        print $this->NOTE(<<HERE);
Note: Before you can use newly installed plugins, you must enable them in the
"Plugins" section in the main page.
HERE
    }

    return '';
}

# Find the installation target of a single file. This involves remapping
# through the settings in LocalSIte.cfg. If the target is not remapped, then
# the file is installed relative to the root, which is the directory
# immediately above bin.
sub _findTarget {
    my ($this, $file) = @_;

    if ($file =~ s#^data/#$TWiki::cfg{DataDir}/#) {
    } elsif ($file =~ s#^pub/#$TWiki::cfg{PubDir}/#) {
    } elsif ($file =~ s#^templates/#$TWiki::cfg{TemplateDir}/#) {
    } elsif ($file =~ s#^locale/#$TWiki::cfg{LocalesDir}/#) {
    } elsif ($file =~ s#^(bin/\w+)$#$1$TWiki::cfg{ScriptSuffix}#) {
    } else {
        $file = File::Spec->catfile($this->{root}, $file);
    }
    $file =~ /^(.*)$/;
    return $1;
}

# Recursively list a directory
sub _listDir {
    my ($dir, $path) = @_;
    $path ||= '';
    $dir .= '/' unless $dir =~ /\/$/;
    my $d;
    my @names = ();
    if (opendir($d, "$dir/$path")) {
        foreach my $f ( grep { !/^\.*$/ } readdir $d ) {
            if (-d "$dir$path/$f") {
                push(@names, "$path$f/");
                push(@names, _listDir($dir, "$path$f/"));
            } else {
                push(@names, "$path$f");
            }
        }
    }
    return @names;
}

=pod

---++ StaticMethod _unpackArchive($archive [,$dir] )
Unpack an archive. The unpacking method is determined from the file
extension e.g. .zip, .tgz. .tar, etc. If $dir is not given, unpack
to a temporary directory, the name of which is returned.

=cut

sub _unpackArchive {
    my ($name, $dir) = @_;

    $dir ||= File::Temp::tempdir(CLEANUP=>1);
    my $here = Cwd::getcwd();
    chdir( $dir );
    unless( $name =~ /\.zip/i && _unzip( $name ) ||
              $name =~ /(\.tar\.gz|\.tgz|\.tar)/ && _untar( $name )) {
        $dir = undef;
        print "Failed to unpack archive $name\n";
    }
    chdir( $here );

    return $dir;
}

sub _unzip {
    my $archive = shift;

    eval 'use Archive::Zip';
    unless ( $@ ) {
        my $zip = Archive::Zip->new( $archive );
        unless ( $zip ) {
            print "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 "Failed to extract '$file' from zip file ",
                  $zip,". Archive may be corrupt.\n";
                return 0;
            }
        }
    } else {
        print "Archive::Zip is not installed; trying unzip on the command line\n";
        print `unzip $archive`;
        if ( $! ) {
            print "unzip failed: $!\n";
            return 0;
        }
    }

    return 1;
}

sub _untar {
    my $archive = shift;

    my $compressed = ( $archive =~ /z$/i ) ? 'z' : '';

    eval 'use Archive::Tar';
    unless ( $@ ) {
        my $tar = Archive::Tar->new( $archive, $compressed );
        unless ( $tar ) {
            print "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 'Failed to extract ',$file,' from tar file ',
                  $tar,". Archive may be corrupt.\n";
                return 0;
            }
        }
    } else {
        print "Archive::Tar is not installed; trying tar on the command-line\n";
        print `tar xvf$compressed $archive`;
        if ( $! ) {
            print "tar failed: $!\n";
            return 0;
        }
    }

    return 1;
}

1;