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