-
Notifications
You must be signed in to change notification settings - Fork 13
/
Extract.pm
1668 lines (1260 loc) · 51.6 KB
/
Extract.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
package Archive::Extract;
use strict;
use Cwd qw[cwd chdir];
use Carp qw[carp];
use IPC::Cmd qw[run can_run];
use FileHandle;
use File::Path qw[mkpath];
use File::Spec;
use File::Basename qw[dirname basename];
use Params::Check qw[check];
use Module::Load::Conditional qw[can_load check_install];
use Locale::Maketext::Simple Style => 'gettext';
### solaris has silly /bin/tar output ###
use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0;
use constant ON_NETBSD => $^O eq 'netbsd' ? 1 : 0;
use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 };
### VMS may require quoting upper case command options
use constant ON_VMS => $^O eq 'VMS' ? 1 : 0;
### Windows needs special treatment of Tar options
use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
### we can't use this extraction method, because of missing
### modules/binaries:
use constant METHOD_NA => [];
### If these are changed, update @TYPES and the new() POD
use constant TGZ => 'tgz';
use constant TAR => 'tar';
use constant GZ => 'gz';
use constant ZIP => 'zip';
use constant BZ2 => 'bz2';
use constant TBZ => 'tbz';
use constant Z => 'Z';
use constant LZMA => 'lzma';
use constant XZ => 'xz';
use constant TXZ => 'txz';
use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
$_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
];
$VERSION = '0.50';
$PREFER_BIN = 0;
$WARN = 1;
$DEBUG = 0;
$_ALLOW_PURE_PERL = 1; # allow pure perl extractors
$_ALLOW_BIN = 1; # allow binary extractors
$_ALLOW_TAR_ITER = 1; # try to use Archive::Tar->iter if available
# same as all constants
my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA, XZ, TXZ );
local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
=pod
=head1 NAME
Archive::Extract - A generic archive extracting mechanism
=head1 SYNOPSIS
use Archive::Extract;
### build an Archive::Extract object ###
my $ae = Archive::Extract->new( archive => 'foo.tgz' );
### extract to cwd() ###
my $ok = $ae->extract;
### extract to /tmp ###
my $ok = $ae->extract( to => '/tmp' );
### what if something went wrong?
my $ok = $ae->extract or die $ae->error;
### files from the archive ###
my $files = $ae->files;
### dir that was extracted to ###
my $outdir = $ae->extract_path;
### quick check methods ###
$ae->is_tar # is it a .tar file?
$ae->is_tgz # is it a .tar.gz or .tgz file?
$ae->is_gz; # is it a .gz file?
$ae->is_zip; # is it a .zip file?
$ae->is_bz2; # is it a .bz2 file?
$ae->is_tbz; # is it a .tar.bz2 or .tbz file?
$ae->is_lzma; # is it a .lzma file?
$ae->is_xz; # is it a .xz file?
$ae->is_txz; # is it a .tar.xz or .txz file?
### absolute path to the archive you provided ###
$ae->archive;
### commandline tools, if found ###
$ae->bin_tar # path to /bin/tar, if found
$ae->bin_gzip # path to /bin/gzip, if found
$ae->bin_unzip # path to /bin/unzip, if found
$ae->bin_bunzip2 # path to /bin/bunzip2 if found
$ae->bin_unlzma # path to /bin/unlzma if found
$ae->bin_unxz # path to /bin/unxz if found
=head1 DESCRIPTION
Archive::Extract is a generic archive extraction mechanism.
It allows you to extract any archive file of the type .tar, .tar.gz,
.gz, .Z, tar.bz2, .tbz, .bz2, .zip, .xz,, .txz, .tar.xz or .lzma
without having to worry how it
does so, or use different interfaces for each type by using either
perl modules, or commandline tools on your system.
See the C<HOW IT WORKS> section further down for details.
=cut
### see what /bin/programs are available ###
$PROGRAMS = {};
for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) {
if ( $pgm eq 'unzip' and ON_NETBSD ) {
local $IPC::Cmd::INSTANCES = 1;
my @possibles = can_run($pgm);
($PROGRAMS->{$pgm}) = grep { m!/usr/pkg/! } can_run($pgm);
next;
}
$PROGRAMS->{$pgm} = can_run($pgm);
}
### mapping from types to extractor methods ###
my $Mapping = { # binary program # pure perl module
is_tgz => { bin => '_untar_bin', pp => '_untar_at' },
is_tar => { bin => '_untar_bin', pp => '_untar_at' },
is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' },
is_zip => { bin => '_unzip_bin', pp => '_unzip_az' },
is_tbz => { bin => '_untar_bin', pp => '_untar_at' },
is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'},
is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' },
is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' },
is_xz => { bin => '_unxz_bin', pp => '_unxz_cz' },
is_txz => { bin => '_untar_bin', pp => '_untar_at' },
};
{ ### use subs so we re-generate array refs etc for the no-override flags
### if we don't, then we reuse the same arrayref, meaning objects store
### previous errors
my $tmpl = {
archive => sub { { required => 1, allow => FILE_EXISTS } },
type => sub { { default => '', allow => [ @Types ] } },
_error_msg => sub { { no_override => 1, default => [] } },
_error_msg_long => sub { { no_override => 1, default => [] } },
};
### build accessors ###
for my $method( keys %$tmpl,
qw[_extractor _gunzip_to files extract_path],
) {
no strict 'refs';
*$method = sub {
my $self = shift;
$self->{$method} = $_[0] if @_;
return $self->{$method};
}
}
=head1 METHODS
=head2 $ae = Archive::Extract->new(archive => '/path/to/archive',[type => TYPE])
Creates a new C<Archive::Extract> object based on the archive file you
passed it. Automatically determines the type of archive based on the
extension, but you can override that by explicitly providing the
C<type> argument.
Valid values for C<type> are:
=over 4
=item tar
Standard tar files, as produced by, for example, C</bin/tar>.
Corresponds to a C<.tar> suffix.
=item tgz
Gzip compressed tar files, as produced by, for example C</bin/tar -z>.
Corresponds to a C<.tgz> or C<.tar.gz> suffix.
=item gz
Gzip compressed file, as produced by, for example C</bin/gzip>.
Corresponds to a C<.gz> suffix.
=item Z
Lempel-Ziv compressed file, as produced by, for example C</bin/compress>.
Corresponds to a C<.Z> suffix.
=item zip
Zip compressed file, as produced by, for example C</bin/zip>.
Corresponds to a C<.zip>, C<.jar> or C<.par> suffix.
=item bz2
Bzip2 compressed file, as produced by, for example, C</bin/bzip2>.
Corresponds to a C<.bz2> suffix.
=item tbz
Bzip2 compressed tar file, as produced by, for example C</bin/tar -j>.
Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
=item lzma
Lzma compressed file, as produced by C</bin/lzma>.
Corresponds to a C<.lzma> suffix.
=item xz
Xz compressed file, as produced by C</bin/xz>.
Corresponds to a C<.xz> suffix.
=item txz
Xz compressed tar file, as produced by, for example C</bin/tar -J>.
Corresponds to a C<.txz> or C<.tar.xz> suffix.
=back
Returns a C<Archive::Extract> object on success, or false on failure.
=cut
### constructor ###
sub new {
my $class = shift;
my %hash = @_;
### see above why we use subs here and generate the template;
### it's basically to not re-use arrayrefs
my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl;
my $parsed = check( \%utmpl, \%hash ) or return;
### make sure we have an absolute path ###
my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} );
### figure out the type, if it wasn't already specified ###
unless ( $parsed->{type} ) {
$parsed->{type} =
$ar =~ /.+?\.(?:tar\.gz|tgz)$/i ? TGZ :
$ar =~ /.+?\.gz$/i ? GZ :
$ar =~ /.+?\.tar$/i ? TAR :
$ar =~ /.+?\.(zip|jar|par)$/i ? ZIP :
$ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
$ar =~ /.+?\.bz2$/i ? BZ2 :
$ar =~ /.+?\.Z$/ ? Z :
$ar =~ /.+?\.lzma$/ ? LZMA :
$ar =~ /.+?\.(?:txz|tar\.xz)$/i ? TXZ :
$ar =~ /.+?\.xz$/ ? XZ :
'';
}
bless $parsed, $class;
### don't know what type of file it is
### XXX this *has* to be an object call, not a package call
return $parsed->_error(loc("Cannot determine file type for '%1'",
$parsed->{archive} )) unless $parsed->{type};
return $parsed;
}
}
=head2 $ae->extract( [to => '/output/path'] )
Extracts the archive represented by the C<Archive::Extract> object to
the path of your choice as specified by the C<to> argument. Defaults to
C<cwd()>.
Since C<.gz> files never hold a directory, but only a single file; if
the C<to> argument is an existing directory, the file is extracted
there, with its C<.gz> suffix stripped.
If the C<to> argument is not an existing directory, the C<to> argument
is understood to be a filename, if the archive type is C<gz>.
In the case that you did not specify a C<to> argument, the output
file will be the name of the archive file, stripped from its C<.gz>
suffix, in the current working directory.
C<extract> will try a pure perl solution first, and then fall back to
commandline tools if they are available. See the C<GLOBAL VARIABLES>
section below on how to alter this behaviour.
It will return true on success, and false on failure.
On success, it will also set the follow attributes in the object:
=over 4
=item $ae->extract_path
This is the directory that the files where extracted to.
=item $ae->files
This is an array ref with the paths of all the files in the archive,
relative to the C<to> argument you specified.
To get the full path to an extracted file, you would use:
File::Spec->catfile( $to, $ae->files->[0] );
Note that all files from a tar archive will be in unix format, as per
the tar specification.
=back
=cut
sub extract {
my $self = shift;
my %hash = @_;
### reset error messages
$self->_error_msg( [] );
$self->_error_msg_long( [] );
my $to;
my $tmpl = {
to => { default => '.', store => \$to }
};
check( $tmpl, \%hash ) or return;
### so 'to' could be a file or a dir, depending on whether it's a .gz
### file, or basically anything else.
### so, check that, then act accordingly.
### set an accessor specifically so _gunzip can know what file to extract
### to.
my $dir;
{ ### a foo.gz file
if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma or $self->is_xz ) {
my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma|xz)$//i;
### to is a dir?
if ( -d $to ) {
$dir = $to;
$self->_gunzip_to( basename($cp) );
### then it's a filename
} else {
$dir = dirname($to);
$self->_gunzip_to( basename($to) );
}
### not a foo.gz file
} else {
$dir = $to;
}
}
### make the dir if it doesn't exist ###
unless( -d $dir ) {
eval { mkpath( $dir ) };
return $self->_error(loc("Could not create path '%1': %2", $dir, $@))
if $@;
}
### get the current dir, to restore later ###
my $cwd = cwd();
my $ok = 1;
EXTRACT: {
### chdir to the target dir ###
unless( chdir $dir ) {
$self->_error(loc("Could not chdir to '%1': %2", $dir, $!));
$ok = 0; last EXTRACT;
}
### set files to an empty array ref, so there's always an array
### ref IN the accessor, to avoid errors like:
### Can't use an undefined value as an ARRAY reference at
### ../lib/Archive/Extract.pm line 742. (rt #19815)
$self->files( [] );
### find out the dispatch methods needed for this type of
### archive. Do a $self->is_XXX to figure out the type, then
### get the hashref with bin + pure perl dispatchers.
my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping;
### add pure perl extractor if allowed & add bin extractor if allowed
my @methods;
push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL;
push @methods, $map->{'bin'} if $_ALLOW_BIN;
### reverse it if we prefer bin extractors
@methods = reverse @methods if $PREFER_BIN;
my($na, $fail);
for my $method (@methods) {
$self->debug( "# Extracting with ->$method\n" );
my $rv = $self->$method;
### a positive extraction
if( $rv and $rv ne METHOD_NA ) {
$self->debug( "# Extraction succeeded\n" );
$self->_extractor($method);
last;
### method is not available
} elsif ( $rv and $rv eq METHOD_NA ) {
$self->debug( "# Extraction method not available\n" );
$na++;
} else {
$self->debug( "# Extraction method failed\n" );
$fail++;
}
}
### warn something went wrong if we didn't get an extractor
unless( $self->_extractor ) {
my $diag = $fail ? loc("Extract failed due to errors") :
$na ? loc("Extract failed; no extractors available") :
'';
$self->_error($diag);
$ok = 0;
}
}
### and chdir back ###
unless( chdir $cwd ) {
$self->_error(loc("Could not chdir back to start dir '%1': %2'",
$cwd, $!));
}
return $ok;
}
=pod
=head1 ACCESSORS
=head2 $ae->error([BOOL])
Returns the last encountered error as string.
Pass it a true value to get the C<Carp::longmess()> output instead.
=head2 $ae->extract_path
This is the directory the archive got extracted to.
See C<extract()> for details.
=head2 $ae->files
This is an array ref holding all the paths from the archive.
See C<extract()> for details.
=head2 $ae->archive
This is the full path to the archive file represented by this
C<Archive::Extract> object.
=head2 $ae->type
This is the type of archive represented by this C<Archive::Extract>
object. See accessors below for an easier way to use this.
See the C<new()> method for details.
=head2 $ae->types
Returns a list of all known C<types> for C<Archive::Extract>'s
C<new> method.
=cut
sub types { return @Types }
=head2 $ae->is_tgz
Returns true if the file is of type C<.tar.gz>.
See the C<new()> method for details.
=head2 $ae->is_tar
Returns true if the file is of type C<.tar>.
See the C<new()> method for details.
=head2 $ae->is_gz
Returns true if the file is of type C<.gz>.
See the C<new()> method for details.
=head2 $ae->is_Z
Returns true if the file is of type C<.Z>.
See the C<new()> method for details.
=head2 $ae->is_zip
Returns true if the file is of type C<.zip>.
See the C<new()> method for details.
=head2 $ae->is_lzma
Returns true if the file is of type C<.lzma>.
See the C<new()> method for details.
=head2 $ae->is_xz
Returns true if the file is of type C<.xz>.
See the C<new()> method for details.
=cut
### quick check methods ###
sub is_tgz { return $_[0]->type eq TGZ }
sub is_tar { return $_[0]->type eq TAR }
sub is_gz { return $_[0]->type eq GZ }
sub is_zip { return $_[0]->type eq ZIP }
sub is_tbz { return $_[0]->type eq TBZ }
sub is_bz2 { return $_[0]->type eq BZ2 }
sub is_Z { return $_[0]->type eq Z }
sub is_lzma { return $_[0]->type eq LZMA }
sub is_xz { return $_[0]->type eq XZ }
sub is_txz { return $_[0]->type eq TXZ }
=pod
=head2 $ae->bin_tar
Returns the full path to your tar binary, if found.
=head2 $ae->bin_gzip
Returns the full path to your gzip binary, if found
=head2 $ae->bin_unzip
Returns the full path to your unzip binary, if found
=head2 $ae->bin_unlzma
Returns the full path to your unlzma binary, if found
=head2 $ae->bin_unxz
Returns the full path to your unxz binary, if found
=cut
### paths to commandline tools ###
sub bin_gzip { return $PROGRAMS->{'gzip'} if $PROGRAMS->{'gzip'} }
sub bin_unzip { return $PROGRAMS->{'unzip'} if $PROGRAMS->{'unzip'} }
sub bin_tar { return $PROGRAMS->{'tar'} if $PROGRAMS->{'tar'} }
sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
sub bin_uncompress { return $PROGRAMS->{'uncompress'}
if $PROGRAMS->{'uncompress'} }
sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} }
sub bin_unxz { return $PROGRAMS->{'unxz'} if $PROGRAMS->{'unxz'} }
=head2 $bool = $ae->have_old_bunzip2
Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
require all archive names to end in C<.bz2> or it will not extract
them. This method checks if you have a recent version of C<bunzip2>
that allows any extension, or an older one that doesn't.
=cut
sub have_old_bunzip2 {
my $self = shift;
### no bunzip2? no old bunzip2 either :)
return unless $self->bin_bunzip2;
### if we can't run this, we can't be sure if it's too old or not
### XXX stupid stupid stupid bunzip2 doesn't understand --version
### is not a request to extract data:
### $ bunzip2 --version
### bzip2, a block-sorting file compressor. Version 1.0.2, 30-Dec-2001.
### [...]
### bunzip2: I won't read compressed data from a terminal.
### bunzip2: For help, type: `bunzip2 --help'.
### $ echo $?
### 1
### HATEFUL!
### double hateful: bunzip2 --version also hangs if input is a pipe
### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH]
### So, we have to provide *another* argument which is a fake filename,
### just so it wont try to read from stdin to print its version..
### *sigh*
### Even if the file exists, it won't clobber or change it.
my $buffer;
scalar run(
command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
verbose => 0,
buffer => \$buffer
);
### no output
return unless $buffer;
my ($version) = $buffer =~ /version \s+ (\d+)/ix;
return 1 if $version < 1;
return;
}
#################################
#
# Untar code
#
#################################
### annoying issue with (gnu) tar on win32, as illustrated by this
### bug: https://rt.cpan.org/Ticket/Display.html?id=40138
### which shows that (gnu) tar will interpret a file name with a :
### in it as a remote file name, so C:\tmp\foo.txt is interpreted
### as a remote shell, and the extract fails.
{ my @ExtraTarFlags;
if( ON_WIN32 and my $cmd = __PACKAGE__->bin_tar ) {
### if this is gnu tar we are running, we need to use --force-local
push @ExtraTarFlags, '--force-local' if `$cmd --version` =~ /gnu tar/i;
}
### use /bin/tar to extract ###
sub _untar_bin {
my $self = shift;
### check for /bin/tar ###
### check for /bin/gzip if we need it ###
### if any of the binaries are not available, return NA
{ my $diag = not $self->bin_tar ?
loc("No '%1' program found", '/bin/tar') :
$self->is_tgz && !$self->bin_gzip ?
loc("No '%1' program found", '/bin/gzip') :
$self->is_tbz && !$self->bin_bunzip2 ?
loc("No '%1' program found", '/bin/bunzip2') :
$self->is_txz && !$self->bin_unxz ?
loc("No '%1' program found", '/bin/unxz') :
'';
if( $diag ) {
$self->_error( $diag );
return METHOD_NA;
}
}
### XXX figure out how to make IPC::Run do this in one call --
### currently i don't know how to get output of a command after a pipe
### trapped in a scalar. Mailed barries about this 5th of june 2004.
### see what command we should run, based on whether
### it's a .tgz or .tar
### XXX solaris tar and bsdtar are having different outputs
### depending whether you run with -x or -t
### compensate for this insanity by running -t first, then -x
{ my $cmd =
$self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
$self->bin_tar, '-tf', '-'] :
$self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
$self->bin_tar, '-tf', '-'] :
$self->is_txz ? [$self->bin_unxz, '-cd', $self->archive, '|',
$self->bin_tar, '-tf', '-'] :
[$self->bin_tar, @ExtraTarFlags, '-tf', $self->archive];
### run the command
### newer versions of 'tar' (1.21 and up) now print record size
### to STDERR as well if v OR t is given (used to be both). This
### is a 'feature' according to the changelog, so we must now only
### inspect STDOUT, otherwise, failures like these occur:
### http://www.cpantesters.org/cpan/report/3230366
my $buffer = '';
my @out = run( command => $cmd,
buffer => \$buffer,
verbose => $DEBUG );
### command was unsuccessful
unless( $out[0] ) {
return $self->_error(loc(
"Error listing contents of archive '%1': %2",
$self->archive, $buffer ));
}
### no buffers available?
if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
$self->_error( $self->_no_buffer_files( $self->archive ) );
} else {
### if we're on solaris we /might/ be using /bin/tar, which has
### a weird output format... we might also be using
### /usr/local/bin/tar, which is gnu tar, which is perfectly
### fine... so we have to do some guessing here =/
my @files = map { chomp;
!ON_SOLARIS ? $_
: (m|^ x \s+ # 'xtract' -- sigh
(.+?), # the actual file name
\s+ [\d,.]+ \s bytes,
\s+ [\d,.]+ \s tape \s blocks
|x ? $1 : $_);
### only STDOUT, see above. Sometimes, extra whitespace
### is present, so make sure we only pick lines with
### a length
} grep { length } map { split $/, $_ } join '', @{$out[3]};
### store the files that are in the archive ###
$self->files(\@files);
}
}
### now actually extract it ###
{ my $cmd =
$self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
$self->bin_tar, '-xf', '-'] :
$self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',
$self->bin_tar, '-xf', '-'] :
$self->is_txz ? [$self->bin_unxz, '-cd', $self->archive, '|',
$self->bin_tar, '-xf', '-'] :
[$self->bin_tar, @ExtraTarFlags, '-xf', $self->archive];
my $buffer = '';
unless( scalar run( command => $cmd,
buffer => \$buffer,
verbose => $DEBUG )
) {
return $self->_error(loc("Error extracting archive '%1': %2",
$self->archive, $buffer ));
}
### we might not have them, due to lack of buffers
if( $self->files ) {
### now that we've extracted, figure out where we extracted to
my $dir = $self->__get_extract_dir( $self->files );
### store the extraction dir ###
$self->extract_path( $dir );
}
}
### we got here, no error happened
return 1;
}
}
### use archive::tar to extract ###
sub _untar_at {
my $self = shift;
### Loading Archive::Tar is going to set it to 1, so make it local
### within this block, starting with its initial value. Whatever
### Achive::Tar does will be undone when we return.
###
### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN
### so users don't have to even think about this variable. If they
### do, they still get their set value outside of this call.
local $Archive::Tar::WARN = $Archive::Tar::WARN;
### we definitely need Archive::Tar, so load that first
{ my $use_list = { 'Archive::Tar' => '0.0' };
unless( can_load( modules => $use_list ) ) {
$self->_error(loc("You do not have '%1' installed - " .
"Please install it as soon as possible.",
'Archive::Tar'));
return METHOD_NA;
}
}
### we might pass it a filehandle if it's a .tbz file..
my $fh_to_read = $self->archive;
### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
### if A::T's version is 0.99 or higher
if( $self->is_tgz ) {
my $use_list = { 'Compress::Zlib' => '0.0' };
$use_list->{ 'IO::Zlib' } = '0.0'
if $Archive::Tar::VERSION >= '0.99';
unless( can_load( modules => $use_list ) ) {
my $which = join '/', sort keys %$use_list;
$self->_error(loc(
"You do not have '%1' installed - Please ".
"install it as soon as possible.", $which)
);
return METHOD_NA;
}
} elsif ( $self->is_tbz ) {
my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
unless( can_load( modules => $use_list ) ) {
$self->_error(loc(
"You do not have '%1' installed - Please " .
"install it as soon as possible.",
'IO::Uncompress::Bunzip2')
);
return METHOD_NA;
}
my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
return $self->_error(loc("Unable to open '%1': %2",
$self->archive,
$IO::Uncompress::Bunzip2::Bunzip2Error));
$fh_to_read = $bz;
} elsif ( $self->is_txz ) {
my $use_list = { 'IO::Uncompress::UnXz' => '0.0' };
unless( can_load( modules => $use_list ) ) {
$self->_error(loc(
"You do not have '%1' installed - Please " .
"install it as soon as possible.",
'IO::Uncompress::UnXz')
);
return METHOD_NA;
}
my $xz = IO::Uncompress::UnXz->new( $self->archive ) or
return $self->_error(loc("Unable to open '%1': %2",
$self->archive,
$IO::Uncompress::UnXz::UnXzError));
$fh_to_read = $xz;
}
my @files;
{
### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
### localized $Archive::Tar::WARN already.
$Archive::Tar::WARN = $Archive::Extract::WARN;
### only tell it it's compressed if it's a .tgz, as we give it a file
### handle if it's a .tbz
my @read = ( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) );
### for version of Archive::Tar > 1.04
local $Archive::Tar::CHOWN = 0;
### use the iterator if we can. it's a feature of A::T 1.40 and up
if ( $_ALLOW_TAR_ITER && Archive::Tar->can( 'iter' ) ) {
my $next;
unless ( $next = Archive::Tar->iter( @read ) ) {
return $self->_error(loc(
"Unable to read '%1': %2", $self->archive,
$Archive::Tar::error));
}
while ( my $file = $next->() ) {
push @files, $file->full_path;
$file->extract or return $self->_error(loc(
"Unable to read '%1': %2",
$self->archive,
$Archive::Tar::error));
}
### older version, read the archive into memory
} else {
my $tar = Archive::Tar->new();
unless( $tar->read( @read ) ) {
return $self->_error(loc("Unable to read '%1': %2",
$self->archive, $Archive::Tar::error));
}
### workaround to prevent Archive::Tar from setting uid, which
### is a potential security hole. -autrijus
### have to do it here, since A::T needs to be /loaded/ first ###
{ no strict 'refs'; local $^W;
### older versions of archive::tar <= 0.23
*Archive::Tar::chown = sub {};
}
{ local $^W; # quell 'splice() offset past end of array' warnings
# on older versions of A::T
### older archive::tar always returns $self, return value
### slightly fux0r3d because of it.
$tar->extract or return $self->_error(loc(
"Unable to extract '%1': %2",
$self->archive, $Archive::Tar::error ));
}
@files = $tar->list_files;
}
}
my $dir = $self->__get_extract_dir( \@files );
### store the files that are in the archive ###
$self->files(\@files);
### store the extraction dir ###
$self->extract_path( $dir );
### check if the dir actually appeared ###
return 1 if -d $self->extract_path;
### no dir, we failed ###
return $self->_error(loc("Unable to extract '%1': %2",
$self->archive, $Archive::Tar::error ));
}
#################################
#
# Gunzip code
#
#################################
sub _gunzip_bin {
my $self = shift;
### check for /bin/gzip -- we need it ###
unless( $self->bin_gzip ) {
$self->_error(loc("No '%1' program found", '/bin/gzip'));
return METHOD_NA;
}
my $fh = FileHandle->new('>'. $self->_gunzip_to) or
return $self->_error(loc("Could not open '%1' for writing: %2",
$self->_gunzip_to, $! ));
my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];
my $buffer;
unless( scalar run( command => $cmd,
verbose => $DEBUG,
buffer => \$buffer )
) {
return $self->_error(loc("Unable to gunzip '%1': %2",
$self->archive, $buffer));
}
### no buffers available?
if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
$self->_error( $self->_no_buffer_content( $self->archive ) );
}
$self->_print($fh, $buffer) if defined $buffer;
close $fh;
### set what files where extract, and where they went ###
$self->files( [$self->_gunzip_to] );
$self->extract_path( File::Spec->rel2abs(cwd()) );
return 1;
}
sub _gunzip_cz {
my $self = shift;
my $use_list = { 'Compress::Zlib' => '0.0' };
unless( can_load( modules => $use_list ) ) {
$self->_error(loc("You do not have '%1' installed - Please " .
"install it as soon as possible.", 'Compress::Zlib'));
return METHOD_NA;
}
my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
return $self->_error(loc("Unable to open '%1': %2",
$self->archive, $Compress::Zlib::gzerrno));
my $fh = FileHandle->new('>'. $self->_gunzip_to) or
return $self->_error(loc("Could not open '%1' for writing: %2",
$self->_gunzip_to, $! ));
my $buffer;
$self->_print($fh, $buffer) while $gz->gzread($buffer) > 0;
$fh->close;
### set what files where extract, and where they went ###
$self->files( [$self->_gunzip_to] );
$self->extract_path( File::Spec->rel2abs(cwd()) );