File Coverage

blib/lib/CPAN/Mirror/Tiny/Archive.pm
Criterion Covered Total %
statement 24 162 14.8
branch 0 86 0.0
condition 0 48 0.0
subroutine 8 24 33.3
pod 0 4 0.0
total 32 324 9.8


line stmt bran cond sub pod time code
1             package CPAN::Mirror::Tiny::Archive;
2 1     1   7 use strict;
  1         3  
  1         30  
3 1     1   6 use warnings;
  1         2  
  1         25  
4              
5 1     1   6 use File::Basename ();
  1         2  
  1         12  
6 1     1   780 use File::Temp ();
  1         23143  
  1         27  
7 1     1   467 use File::Which ();
  1         967  
  1         38  
8 1     1   592 use IPC::Run3 ();
  1         11964  
  1         1436  
9              
10             sub run3 {
11 0     0 0   my ($cmd, $outfile) = @_;
12 0           my $out;
13 0 0         IPC::Run3::run3 $cmd, \undef, ($outfile ? $outfile : \$out), \my $err;
14 0           return ($?, $out, $err);
15             }
16              
17             sub new {
18 0     0 0   my ($class, %argv) = @_;
19 0           my $self = bless \%argv, $class;
20 0           $self->_init_untar;
21 0           $self->_init_unzip;
22 0           $self;
23             }
24              
25             sub unpack {
26 0     0 0   my ($self, $file) = @_;
27 0 0         my $method = $file =~ /\.zip$/ ? $self->{method}{unzip} : $self->{method}{untar};
28 0           $self->$method($file);
29             }
30              
31             sub describe {
32 0     0 0   my $self = shift;
33             +{
34 0           map { ($_, $self->{$_}) }
35 0           grep $self->{$_},
36             qw(tar gzip bzip2 Archive::Tar unzip Archive::Zip),
37             };
38             }
39              
40             sub _init_untar {
41 0     0     my $self = shift;
42              
43 0   0       my $tar = $self->{tar} = File::Which::which('gtar') || File::Which::which("tar");
44 0 0         if ($tar) {
45 0           my ($exit, $out, $err) = run3 [$tar, '--version'];
46 0 0         $self->{tar_kind} = $out =~ /bsdtar/ ? "bsd" : "gnu";
47 0 0 0       $self->{tar_bad} = 1 if $out =~ /GNU.*1\.13/i || $^O eq 'MSWin32' || $^O eq 'solaris' || $^O eq 'hpux';
      0        
      0        
48             }
49              
50 0 0 0       if ($tar and !$self->{tar_bad}) {
51 0           $self->{method}{untar} = *_untar;
52 0 0         return if !$self->{_init_all};
53             }
54              
55 0           my $gzip = $self->{gzip} = File::Which::which("gzip");
56 0           my $bzip2 = $self->{bzip2} = File::Which::which("bzip2");
57              
58 0 0 0       if ($tar && $gzip && $bzip2) {
      0        
59 0           $self->{method}{untar} = *_untar_bad;
60 0 0         return if !$self->{_init_all};
61             }
62              
63 0 0         if (eval { require Archive::Tar }) {
  0            
64 0           $self->{"Archive::Tar"} = Archive::Tar->VERSION;
65 0           $self->{method}{untar} = *_untar_module;
66 0 0         return if !$self->{_init_all};
67             }
68              
69 0 0         return if $self->{_init_all};
70 0     0     $self->{method}{untar} = sub { die "There is no backend for untar" };
  0            
71             }
72              
73             sub _init_unzip {
74 0     0     my $self = shift;
75              
76 0           my $unzip = $self->{unzip} = File::Which::which("unzip");
77 0 0         if ($unzip) {
78 0           $self->{method}{unzip} = *_unzip;
79 0 0         return if !$self->{_init_all};
80             }
81              
82 0 0         if (eval { require Archive::Zip }) {
  0            
83 0           $self->{"Archive::Zip"} = Archive::Zip->VERSION;
84 0           $self->{method}{unzip} = *_unzip_module;
85 0 0         return if !$self->{_init_all};
86             }
87              
88 0 0         return if $self->{_init_all};
89 0     0     $self->{method}{unzip} = sub { die "There is no backend for unzip" };
  0            
90             }
91              
92             sub _untar {
93 0     0     my ($self, $file) = @_;
94 0           my $wantarray = wantarray;
95              
96 0           my ($exit, $out, $err);
97             {
98 0 0         my $ar = $file =~ /\.bz2$/ ? 'j' : 'z';
  0            
99 0           ($exit, $out, $err) = run3 [$self->{tar}, "${ar}tf", $file];
100 0 0         last if $exit != 0;
101 0           my $root = $self->_find_tarroot(split /\r?\n/, $out);
102 0           ($exit, $out, $err) = run3 [$self->{tar}, "${ar}xf", $file, "-o"];
103 0 0 0       return $root if $exit == 0 and -d $root;
104             }
105 0 0         return if !$wantarray;
106 0   0       return (undef, $err || $out);
107             }
108              
109             sub _untar_bad {
110 0     0     my ($self, $file) = @_;
111 0           my $wantarray = wantarray;
112 0           my ($exit, $out, $err);
113             {
114 0 0         my $ar = $file =~ /\.bz2$/ ? $self->{bzip2} : $self->{gzip};
  0            
115 0           my $temp = File::Temp->new(SUFFIX => '.tar', EXLOCK => 0);
116 0           ($exit, $out, $err) = run3 [$ar, "-dc", $file], $temp->filename;
117 0 0         last if $exit != 0;
118              
119             # XXX /usr/bin/tar: Cannot connect to C: resolve failed
120 0 0 0       my @opt = $^O eq 'MSWin32' && $self->{tar_kind} ne "bsd" ? ('--force-local') : ();
121 0           ($exit, $out, $err) = run3 [$self->{tar}, @opt, "-tf", $temp->filename];
122 0 0 0       last if $exit != 0 || !$out;
123 0           my $root = $self->_find_tarroot(split /\r?\n/, $out);
124 0           ($exit, $out, $err) = run3 [$self->{tar}, @opt, "-xf", $temp->filename, "-o"];
125 0 0 0       return $root if $exit == 0 and -d $root;
126             }
127 0 0         return if !$wantarray;
128 0   0       return (undef, $err || $out);
129             }
130              
131             sub _untar_module {
132 0     0     my ($self, $file) = @_;
133 0           my $wantarray = wantarray;
134 1     1   9 no warnings 'once';
  1         3  
  1         472  
135 0           local $Archive::Tar::WARN = 0;
136 0           my $t = Archive::Tar->new;
137             {
138 0           my $ok = $t->read($file);
  0            
139 0 0         last if !$ok;
140 0           my $root = $self->_find_tarroot($t->list_files);
141 0           my @file = $t->extract;
142 0 0 0       return $root if @file and -d $root;
143             }
144 0 0         return if !$wantarray;
145 0           return (undef, $t->error);
146             }
147              
148             sub _find_tarroot {
149 0     0     my ($self, $root, @others) = @_;
150             FILE: {
151 0           chomp $root;
  0            
152 0           $root =~ s!^\./!!;
153 0           $root =~ s{^(.+?)/.*$}{$1};
154 0 0         if (!length $root) { # archive had ./ as the first entry, so try again
155 0           $root = shift @others;
156 0 0         redo FILE if $root;
157             }
158             }
159 0           $root;
160             }
161              
162             sub _unzip {
163 0     0     my ($self, $file) = @_;
164 0           my $wantarray = wantarray;
165              
166 0           my ($exit, $out, $err);
167             {
168 0           ($exit, $out, $err) = run3 [$self->{unzip}, '-t', $file];
  0            
169 0 0         last if $exit != 0;
170 0           my $root = $self->_find_ziproot(split /\r?\n/, $out);
171 0           ($exit, $out, $err) = run3 [$self->{unzip}, '-q', $file];
172 0 0 0       return $root if $exit == 0 and -d $root;
173             }
174 0 0         return if !$wantarray;
175 0   0       return (undef, $err || $out);
176             }
177              
178             sub _unzip_module {
179 0     0     my ($self, $file) = @_;
180 0           my $wantarray = wantarray;
181              
182 1     1   8 no warnings 'once';
  1         11  
  1         455  
183 0     0     my $err = ''; local $Archive::Zip::ErrorHandler = sub { $err .= "@_" };
  0            
  0            
184 0           my $zip = Archive::Zip->new;
185             UNZIP: {
186 0           my $status = $zip->read($file);
  0            
187 0 0         last UNZIP if $status != Archive::Zip::AZ_OK();
188 0           for my $member ($zip->members) {
189 0           my $af = $member->fileName;
190 0 0         next if $af =~ m!^(/|\.\./)!;
191 0           my $status = $member->extractToFileNamed($af);
192 0 0         last UNZIP if $status != Archive::Zip::AZ_OK();
193             }
194 0           my ($root) = $zip->membersMatching(qr{^[^/]+/$});
195 0 0         last UNZIP if !$root;
196 0           $root = $root->fileName;
197 0           $root =~ s{/$}{};
198 0 0         return $root if -d $root;
199             }
200 0 0         return if !$wantarray;
201 0           return (undef, $err);
202             }
203              
204             sub _find_ziproot {
205 0     0     my ($self, undef, $root, @others) = @_;
206             FILE: {
207 0           chomp $root;
  0            
208 0 0         if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
209 0           $root = shift @others;
210 0 0         redo FILE if $root;
211             }
212             }
213 0           $root;
214             }
215              
216             1;
217              
218             __END__