1package InstallPar;
2
3$unzip_cmd = 'unzip $dist -d $path';
4$unzip_cmd = '7za x $dist -o$path -r' if ($^O eq 'MSWin32');
5
6$DEBUG = 0;
7
8use Config;
9use File::Path;
10use File::Spec;
11use File::Temp;
12use Cwd;
13
14sub install_all
15{
16    my (@jobs) = @_;
17    my ($job, $module, $version, $file);
18
19    foreach $job (@jobs)
20    {
21        next unless test(@$job);
22        unless ($file = find_file(@$job))
23        {
24            warn "Can't find a PAR file for $job->[0] v$job->[1]";
25            next;
26        }
27        install($job->[0], $file);
28    }
29}
30
31sub test
32{
33    my ($module, $version) = @_;
34
35    if (eval "require $module")     # installed
36    {
37        return 0 if (${"${module}::VERSION"} >= $version);
38    }
39    return 1;
40}
41
42sub find_file
43{
44    my ($module, $version) = @_;
45    my ($fbase) = $module;
46    my (@res, $res);
47
48    $fbase =~ s|::|-|og;
49    $fbase .= "-$version-$Config::Config{archname}";
50    @res = glob("$fbase*.par");
51    $res = (grep {$_ eq "$fbase-$Config::Config{version}.par"} @res)[0];
52    return $res if $res;
53    return $res[0] if ($res[0]);
54
55# try non binary modules
56    $fbase = $module;
57    $fbase =~ s/::/-/og;
58    @res = glob("$fbase-$version-noarch*.par");
59    $res = (grep {$_ eq "$fbase-$Config::Config{version}.par"} @res)[0];
60    return $res if $res;
61    return $res[0] if ($res[0]);
62}
63
64sub install
65{
66    my ($module, $fname) = @_;
67    my ($cwd) = getcwd;
68    my ($dist, $tmpdir) = unzip_to_tmpdir($fname, 'blib');
69    my ($name) = $module;
70    my ($rv);
71
72    $name =~ s|::|/|og;
73
74    if (-d 'script')
75    {
76        require ExtUtils::MY;
77        foreach my $file (glob("script/*"))
78        {
79            next unless -T $file;
80            if ($DEBUG)
81            { print STDERR "Scripting $file\n"; }
82            elsif ($^O eq 'MSWin32' && ! -f "$file.bat" && $file !~m/\.bat$/oi)
83            { system("pl2bat", $file); }
84            else
85            { ExtUtils::MY->fixin($file); }
86            chmod(0555, $file);
87        }
88    }
89    chdir('..');
90
91    $name =~ s{::|-}{/}g;
92    require ExtUtils::Install;
93
94    if ($DEBUG)
95    { print STDERR "Installing $name from $fname in $tmpdir\n"; }
96    else
97    { $rv = ExtUtils::Install::install_default($name); }
98
99#    elsif ($action eq 'uninstall') {
100#    require Config;
101#    $rv = ExtUtils::Install::uninstall(
102#        "$Config::Config{installsitearch}/auto/$name/.packlist"
103#    );
104#    }
105
106    chdir($cwd);
107    File::Path::rmtree([$tmpdir]);
108    return $rv;
109}
110
111sub uninstall
112{
113    $rv = ExtUtils::Install::uninstall("$Config::Config{installsitearch}/auto/$name/.packlist");
114}
115
116sub unzip_to_tmpdir
117{
118    my ($dist, $subdir) = @_;
119
120    $dist = File::Spec->rel2abs($dist);
121    my $tmpdir = File::Temp::mkdtemp(File::Spec->catdir(File::Spec->tmpdir, "parXXXXX")) or die $!;
122    $tmpdir = File::Spec->catdir($tmpdir, $subdir) if defined $subdir;
123    unzip($dist, $tmpdir) || die "Can't unzip $dist to $tmpdir";
124    chdir $tmpdir;
125    return ($dist, $tmpdir);
126}
127
128sub unzip
129{
130    my ($dist, $path) = @_;
131    my ($failed);
132    return 0 unless -f $dist;
133    $path ||= File::Spec->curdir;
134
135    if (eval { require Archive::Zip; 1 })
136    {
137        my (@members, $file, $m);
138        my $zip = Archive::Zip->new;
139        $SIG{__WARN__} = sub { print STDERR $_[0] unless $_[0] =~ /\bstat\b/ };
140        unless ($zip->read($dist) == Archive::Zip::AZ_OK())
141        {
142            $failed = 1;
143            last;
144        }
145
146        @members = $zip->members();
147        foreach $m (@members)
148        {
149            $file = "$path/" . $m->fileName();
150
151            $file = Archive::Zip::_asLocalName($file);
152            next if ($^O eq "MSWin32" && $file =~ m/::/o);
153            if ($m->extractToFileNamed($file) != AZ_OK)
154            {
155                $failed = 1;
156                last;
157            }
158        }
159        return 1;
160#           $zip->extractTree('', "$path/") == Archive::Zip::AZ_OK());  # but with filtering
161    }
162    else
163    { $failed = 1; }
164# try using a system command
165    if ($failed && $unzip_cmd)
166    {
167        my ($cmd) = $unzip_cmd;
168        $cmd =~ s/\$([\w+])/$$1/oge;
169        print STDERR "$cmd\n" if ($DEBUG);
170        return 1 unless system($cmd);
171    }
172    return 0;
173}
174
1751;
176