xref: /openbsd/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm (revision 09467b48) 
1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2package CPAN::Tarzip;
3use strict;
4use vars qw($VERSION @ISA $BUGHUNTING);
5use CPAN::Debug;
6use File::Basename qw(basename);
7$VERSION = "5.5012";
8# module is internal to CPAN.pm
9
10@ISA = qw(CPAN::Debug); ## no critic
11$BUGHUNTING ||= 0; # released code must have turned off
12
13# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
14sub new {
15    my($class,$file) = @_;
16    $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
17    my $me = { FILE => $file };
18    if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
19        $me->{ISCOMPRESSED} = 1;
20    } else {
21        $me->{ISCOMPRESSED} = 0;
22    }
23    if (0) {
24    } elsif ($file =~ /\.(?:bz2|tbz)$/i) {
25        unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
26            my $bzip2 = _my_which("bzip2");
27            if ($bzip2) {
28                $me->{UNGZIPPRG} = $bzip2;
29            } else {
30                $CPAN::Frontend->mydie(qq{
31CPAN.pm needs the external program bzip2 in order to handle '$file'.
32Please install it now and run 'o conf init bzip2' from the
33CPAN shell prompt to register it as external program.
34});
35            }
36        }
37    } else {
38        $me->{UNGZIPPRG} = _my_which("gzip");
39    }
40    $me->{TARPRG} = _my_which("tar") || _my_which("gtar");
41    bless $me, $class;
42}
43
44sub _my_which {
45    my($what) = @_;
46    if ($CPAN::Config->{$what}) {
47        return $CPAN::Config->{$what};
48    }
49    if ($CPAN::META->has_inst("File::Which")) {
50        return File::Which::which($what);
51    }
52    my @cand = MM->maybe_command($what);
53    return $cand[0] if @cand;
54    require File::Spec;
55    my $component;
56  PATH_COMPONENT: foreach $component (File::Spec->path()) {
57        next unless defined($component) && $component;
58        my($abs) = File::Spec->catfile($component,$what);
59        if (MM->maybe_command($abs)) {
60            return $abs;
61        }
62    }
63    return;
64}
65
66sub gzip {
67    my($self,$read) = @_;
68    my $write = $self->{FILE};
69    if ($CPAN::META->has_inst("Compress::Zlib")) {
70        my($buffer,$fhw);
71        $fhw = FileHandle->new($read)
72            or $CPAN::Frontend->mydie("Could not open $read: $!");
73        my $cwd = `pwd`;
74        my $gz = Compress::Zlib::gzopen($write, "wb")
75            or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
76        binmode($fhw);
77        $gz->gzwrite($buffer)
78            while read($fhw,$buffer,4096) > 0 ;
79        $gz->gzclose() ;
80        $fhw->close;
81        return 1;
82    } else {
83        my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
84        system(qq{$command -c "$read" > "$write"})==0;
85    }
86}
87
88
89sub gunzip {
90    my($self,$write) = @_;
91    my $read = $self->{FILE};
92    if ($CPAN::META->has_inst("Compress::Zlib")) {
93        my($buffer,$fhw);
94        $fhw = FileHandle->new(">$write")
95            or $CPAN::Frontend->mydie("Could not open >$write: $!");
96        my $gz = Compress::Zlib::gzopen($read, "rb")
97            or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
98        binmode($fhw);
99        $fhw->print($buffer)
100            while $gz->gzread($buffer) > 0 ;
101        $CPAN::Frontend->mydie("Error reading from $read: $!\n")
102            if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
103        $gz->gzclose() ;
104        $fhw->close;
105        return 1;
106    } else {
107        my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
108        system(qq{$command -d -c "$read" > "$write"})==0;
109    }
110}
111
112
113sub gtest {
114    my($self) = @_;
115    return $self->{GTEST} if exists $self->{GTEST};
116    defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
117    my $read = $self->{FILE};
118    my $success;
119    if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
120        my($buffer,$len);
121        $len = 0;
122        my $gz = Compress::Bzip2::bzopen($read, "rb")
123            or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
124                                              $read,
125                                              $Compress::Bzip2::bzerrno));
126        while ($gz->bzread($buffer) > 0 ) {
127            $len += length($buffer);
128            $buffer = "";
129        }
130        my $err = $gz->bzerror;
131        $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
132        if ($len == -s $read) {
133            $success = 0;
134            CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
135        }
136        $gz->gzclose();
137        CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
138    } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) {
139        # After I had reread the documentation in zlib.h, I discovered that
140        # uncompressed files do not lead to an gzerror (anymore?).
141        my($buffer,$len);
142        $len = 0;
143        my $gz = Compress::Zlib::gzopen($read, "rb")
144            or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
145                                              $read,
146                                              $Compress::Zlib::gzerrno));
147        while ($gz->gzread($buffer) > 0 ) {
148            $len += length($buffer);
149            $buffer = "";
150        }
151        my $err = $gz->gzerror;
152        $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
153        if ($len == -s $read) {
154            $success = 0;
155            CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
156        }
157        $gz->gzclose();
158        CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
159    } elsif (!$self->{ISCOMPRESSED}) {
160        $success = 0;
161    } else {
162        my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
163        $success = 0==system(qq{$command -qdt "$read"});
164    }
165    return $self->{GTEST} = $success;
166}
167
168
169sub TIEHANDLE {
170    my($class,$file) = @_;
171    my $ret;
172    $class->debug("file[$file]");
173    my $self = $class->new($file);
174    if (0) {
175    } elsif (!$self->gtest) {
176        my $fh = FileHandle->new($file)
177            or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
178        binmode $fh;
179        $self->{FH} = $fh;
180        $class->debug("via uncompressed FH");
181    } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
182        my $gz = Compress::Bzip2::bzopen($file,"rb") or
183            $CPAN::Frontend->mydie("Could not bzopen $file");
184        $self->{GZ} = $gz;
185        $class->debug("via Compress::Bzip2");
186    } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) {
187        my $gz = Compress::Zlib::gzopen($file,"rb") or
188            $CPAN::Frontend->mydie("Could not gzopen $file");
189        $self->{GZ} = $gz;
190        $class->debug("via Compress::Zlib");
191    } else {
192        my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
193        my $pipe = "$gzip -d -c $file |";
194        my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
195        binmode $fh;
196        $self->{FH} = $fh;
197        $class->debug("via external $gzip");
198    }
199    $self;
200}
201
202
203sub READLINE {
204    my($self) = @_;
205    if (exists $self->{GZ}) {
206        my $gz = $self->{GZ};
207        my($line,$bytesread);
208        $bytesread = $gz->gzreadline($line);
209        return undef if $bytesread <= 0;
210        return $line;
211    } else {
212        my $fh = $self->{FH};
213        return scalar <$fh>;
214    }
215}
216
217
218sub READ {
219    my($self,$ref,$length,$offset) = @_;
220    $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
221    if (exists $self->{GZ}) {
222        my $gz = $self->{GZ};
223        my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
224        return $byteread;
225    } else {
226        my $fh = $self->{FH};
227        return read($fh,$$ref,$length);
228    }
229}
230
231
232sub DESTROY {
233    my($self) = @_;
234    if (exists $self->{GZ}) {
235        my $gz = $self->{GZ};
236        $gz->gzclose() if defined $gz; # hard to say if it is allowed
237                                       # to be undef ever. AK, 2000-09
238    } else {
239        my $fh = $self->{FH};
240        $fh->close if defined $fh;
241    }
242    undef $self;
243}
244
245sub untar {
246    my($self) = @_;
247    my $file = $self->{FILE};
248    my($prefer) = 0;
249
250    my $exttar = $self->{TARPRG} || "";
251    $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
252    my $extgzip = $self->{UNGZIPPRG} || "";
253    $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
254
255    if (0) { # makes changing order easier
256    } elsif ($BUGHUNTING) {
257        $prefer=2;
258    } elsif ($CPAN::Config->{prefer_external_tar}) {
259        $prefer = 1;
260    } elsif (
261             $CPAN::META->has_usable("Archive::Tar")
262             &&
263             $CPAN::META->has_inst("Compress::Zlib") ) {
264        my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
265        unless (defined $prefer_external_tar) {
266            if ($^O =~ /(MSWin32|solaris)/) {
267                $prefer_external_tar = 0;
268            } else {
269                $prefer_external_tar = 1;
270            }
271        }
272        $prefer = $prefer_external_tar ? 1 : 2;
273    } elsif ($exttar && $extgzip) {
274        # no modules and not bz2
275        $prefer = 1;
276        # but solaris binary tar is a problem
277        if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
278            $CPAN::Frontend->mywarn(<< 'END_WARN');
279
280WARNING: Many CPAN distributions were archived with GNU tar and some of
281them may be incompatible with Solaris tar.  We respectfully suggest you
282configure CPAN to use a GNU tar instead ("o conf init tar") or install
283a recent Archive::Tar instead;
284
285END_WARN
286        }
287    } else {
288        my $foundtar = $exttar ? "'$exttar'" : "nothing";
289        my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
290        my $foundAT;
291        if ($CPAN::META->has_usable("Archive::Tar")) {
292            $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
293        } else {
294            $foundAT = "nothing";
295        }
296        my $foundCZ;
297        if ($CPAN::META->has_inst("Compress::Zlib")) {
298            $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
299        } elsif ($foundAT) {
300            $foundCZ = "nothing";
301        } else {
302            $foundCZ = "also nothing";
303        }
304        $CPAN::Frontend->mydie(qq{
305
306CPAN.pm needs either the external programs tar and gzip -or- both
307modules Archive::Tar and Compress::Zlib installed.
308
309For tar I found $foundtar, for gzip $foundzip.
310
311For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
312
313Can't continue cutting file '$file'.
314});
315    }
316    my $tar_verb = "v";
317    if (defined $CPAN::Config->{tar_verbosity}) {
318        $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
319            $CPAN::Config->{tar_verbosity};
320    }
321    if ($prefer==1) { # 1 => external gzip+tar
322        my($system);
323        my $is_compressed = $self->gtest();
324        my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
325        if ($is_compressed) {
326            my $command = CPAN::HandleConfig->safe_quote($extgzip);
327            $system = qq{$command -d -c }.
328                qq{< "$file" | $tarcommand x${tar_verb}f -};
329        } else {
330            $system = qq{$tarcommand x${tar_verb}f "$file"};
331        }
332        if (system($system) != 0) {
333            # people find the most curious tar binaries that cannot handle
334            # pipes
335            if ($is_compressed) {
336                (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
337                $ungzf = basename $ungzf;
338                my $ct = CPAN::Tarzip->new($file);
339                if ($ct->gunzip($ungzf)) {
340                    $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
341                } else {
342                    $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
343                }
344                $file = $ungzf;
345            }
346            $system = qq{$tarcommand x${tar_verb}f "$file"};
347            $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
348            my $ret = system($system);
349            if ($ret==0) {
350                $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
351            } else {
352                if ($? == -1) {
353                    $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
354                                           $file, $!);
355                } elsif ($? & 127) {
356                    $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
357                                           $file, ($? & 127),  ($? & 128) ? 'with' : 'without');
358                } else {
359                    $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
360                                           $file, $? >> 8);
361                }
362            }
363            return 1;
364        } else {
365            return 1;
366        }
367    } elsif ($prefer==2) { # 2 => modules
368        unless ($CPAN::META->has_usable("Archive::Tar")) {
369            $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
370        }
371        # Make sure AT does not use uid/gid/permissions in the archive
372        # This leaves it to the user's umask instead
373        local $Archive::Tar::CHMOD = 1;
374        local $Archive::Tar::SAME_PERMISSIONS = 0;
375        # Make sure AT leaves current user as owner
376        local $Archive::Tar::CHOWN = 0;
377        my $tar = Archive::Tar->new($file,1);
378        my $af; # archive file
379        my @af;
380        if ($BUGHUNTING) {
381            # RCS 1.337 had this code, it turned out unacceptable slow but
382            # it revealed a bug in Archive::Tar. Code is only here to hunt
383            # the bug again. It should never be enabled in published code.
384            # GDGraph3d-0.53 was an interesting case according to Larry
385            # Virden.
386            warn(">>>Bughunting code enabled<<< " x 20);
387            for $af ($tar->list_files) {
388                if ($af =~ m!^(/|\.\./)!) {
389                    $CPAN::Frontend->mydie("ALERT: Archive contains ".
390                                           "illegal member [$af]");
391                }
392                $CPAN::Frontend->myprint("$af\n");
393                $tar->extract($af); # slow but effective for finding the bug
394                return if $CPAN::Signal;
395            }
396        } else {
397            for $af ($tar->list_files) {
398                if ($af =~ m!^(/|\.\./)!) {
399                    $CPAN::Frontend->mydie("ALERT: Archive contains ".
400                                           "illegal member [$af]");
401                }
402                if ($tar_verb eq "v" || $tar_verb eq "vv") {
403                    $CPAN::Frontend->myprint("$af\n");
404                }
405                push @af, $af;
406                return if $CPAN::Signal;
407            }
408            $tar->extract(@af) or
409                $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
410        }
411
412        Mac::BuildTools::convert_files([$tar->list_files], 1)
413            if ($^O eq 'MacOS');
414
415        return 1;
416    }
417}
418
419sub unzip {
420    my($self) = @_;
421    my $file = $self->{FILE};
422    if ($CPAN::META->has_inst("Archive::Zip")) {
423        # blueprint of the code from Archive::Zip::Tree::extractTree();
424        my $zip = Archive::Zip->new();
425        my $status;
426        $status = $zip->read($file);
427        $CPAN::Frontend->mydie("Read of file[$file] failed\n")
428            if $status != Archive::Zip::AZ_OK();
429        $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
430        my @members = $zip->members();
431        for my $member ( @members ) {
432            my $af = $member->fileName();
433            if ($af =~ m!^(/|\.\./)!) {
434                $CPAN::Frontend->mydie("ALERT: Archive contains ".
435                                       "illegal member [$af]");
436            }
437            $status = $member->extractToFileNamed( $af );
438            $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
439            $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
440                $status != Archive::Zip::AZ_OK();
441            return if $CPAN::Signal;
442        }
443        return 1;
444    } elsif ( my $unzip = $CPAN::Config->{unzip}  ) {
445        my @system = ($unzip, $file);
446        return system(@system) == 0;
447    }
448    else {
449            $CPAN::Frontend->mydie(<<"END");
450
451Can't unzip '$file':
452
453You have not configured an 'unzip' program and do not have Archive::Zip
454installed.  Please either install Archive::Zip or else configure 'unzip'
455by running the command 'o conf init unzip' from the CPAN shell prompt.
456
457END
458    }
459}
460
4611;
462
463__END__
464
465=head1 NAME
466
467CPAN::Tarzip - internal handling of tar archives for CPAN.pm
468
469=head1 LICENSE
470
471This program is free software; you can redistribute it and/or
472modify it under the same terms as Perl itself.
473
474=cut
475