File Coverage

lib/Archive/Tar.pm

Criterion	Covered	Total	%
statement	362	462	78.4
branch	153	286	53.5
condition	56	92	60.9
subroutine	41	47	87.2
pod	23	24	95.8
total	635	911	69.7

line	stmt	bran	cond	sub	pod	time	code
1							### the gnu tar specification:
2							### http://www.gnu.org/software/tar/manual/tar.html
3							###
4							### and the pax format spec, which tar derives from:
5							### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html
6
7							package Archive::Tar;
8							require 5.005_03;
9
10	3			3		41	use strict;
	3					29
	3					96
11	3					49	use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
12	3			3		43	$DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING];
	3					28
13
14							$DEBUG = 0;
15							$WARN = 1;
16							$FOLLOW_SYMLINK = 0;
17							$VERSION = "1.30";
18							$CHOWN = 1;
19							$CHMOD = 1;
20							$DO_NOT_USE_PREFIX = 0;
21
22							BEGIN {
23	3			3		46	use Config;
	3					27
	3					49
24	3			3		39	$HAS_PERLIO = $Config::Config{useperlio};
25
26							### try and load IO::String anyway, so you can dynamically
27							### switch between perlio and IO::String
28	3					50	eval {
29	3					129	require IO::String;
30	3					74	import IO::String;
31							};
32	3	50				41	$HAS_IO_STRING = $@ ? 0 : 1;
33
34							}
35
36	3			3		93	use Cwd;
	3					25
	3					64
37	3			3		122	use IO::File;
	3					31
	3					65
38	3			3		51	use Carp qw(carp croak);
	3					27
	3					49
39	3			3		46	use File::Spec ();
	3					26
	3					28
40	3			3		75	use File::Spec::Unix ();
	3					26
	3					27
41	3			3		43	use File::Path ();
	3					26
	3					27
42
43	3			3		90	use Archive::Tar::File;
	3					30
	3					80
44	3			3		59	use Archive::Tar::Constant;
	3					28
	3					61
45
46							=head1 NAME
47
48							Archive::Tar - module for manipulations of tar archives
49
50							=head1 SYNOPSIS
51
52							use Archive::Tar;
53							my $tar = Archive::Tar->new;
54
55							$tar->read('origin.tgz',1);
56							$tar->extract();
57
58							$tar->add_files('file/foo.pl', 'docs/README');
59							$tar->add_data('file/baz.txt', 'This is the contents now');
60
61							$tar->rename('oldname', 'new/file/name');
62
63							$tar->write('files.tar');
64
65							=head1 DESCRIPTION
66
67							Archive::Tar provides an object oriented mechanism for handling tar
68							files. It provides class methods for quick and easy files handling
69							while also allowing for the creation of tar file objects for custom
70							manipulation. If you have the IO::Zlib module installed,
71							Archive::Tar will also support compressed or gzipped tar files.
72
73							An object of class Archive::Tar represents a .tar(.gz) archive full
74							of files and things.
75
76							=head1 Object Methods
77
78							=head2 Archive::Tar->new( [$file, $compressed] )
79
80							Returns a new Tar object. If given any arguments, C<new()> calls the
81							C<read()> method automatically, passing on the arguments provided to
82							the C<read()> method.
83
84							If C<new()> is invoked with arguments and the C<read()> method fails
85							for any reason, C<new()> returns undef.
86
87							=cut
88
89							my $tmpl = {
90							_data => [ ],
91							_file => 'Unknown',
92							};
93
94							### install get/set accessors for this object.
95							for my $key ( keys %$tmpl ) {
96	3			3		833	no strict 'refs';
	3					44
	3					53
97							*{__PACKAGE__."::$key"} = sub {
98	192			192		3366	my $self = shift;
99	192	100				2435	$self->{$key} = $_[0] if @_;
100	192					6465	return $self->{$key};
101							}
102							}
103
104							sub new {
105	29			28	1	8222	my $class = shift;
106	28	50				698	$class = ref $class if ref $class;
107
108							### copying $tmpl here since a shallow copy makes it use the
109							### same aref, causing for files to remain in memory always.
110	28					866	my $obj = bless { _data => [ ], _file => 'Unknown' }, $class;
111
112	28	100				1349	if (@_) {
113	3	50				35	unless ( $obj->read( @_ ) ) {
114	0					0	$obj->_error(qq[No data could be read from file]);
115	0					0	return;
116							}
117							}
118
119	28					484	return $obj;
120							}
121
122							=head2 $tar->read ( $filename\|$handle, $compressed, {opt => 'val'} )
123
124							Read the given tar file into memory.
125							The first argument can either be the name of a file or a reference to
126							an already open filehandle (or an IO::Zlib object if it's compressed)
127							The second argument indicates whether the file referenced by the first
128							argument is compressed.
129
130							The C<read> will I<replace> any previous content in C<$tar>!
131
132							The second argument may be considered optional if IO::Zlib is
133							installed, since it will transparently Do The Right Thing.
134							Archive::Tar will warn if you try to pass a compressed file if
135							IO::Zlib is not available and simply return.
136
137							Note that you can currently B<not> pass a C<gzip> compressed
138							filehandle, which is not opened with C<IO::Zlib>, nor a string
139							containing the full archive information (either compressed or
140							uncompressed). These are worth while features, but not currently
141							implemented. See the C<TODO> section.
142
143							The third argument can be a hash reference with options. Note that
144							all options are case-sensitive.
145
146							=over 4
147
148							=item limit
149
150							Do not read more than C<limit> files. This is useful if you have
151							very big archives, and are only interested in the first few files.
152
153							=item extract
154
155							If set to true, immediately extract entries when reading them. This
156							gives you the same memory break as the C<extract_archive> function.
157							Note however that entries will not be read into memory, but written
158							straight to disk.
159
160							=back
161
162							All files are stored internally as C<Archive::Tar::File> objects.
163							Please consult the L<Archive::Tar::File> documentation for details.
164
165							Returns the number of files read in scalar context, and a list of
166							C<Archive::Tar::File> objects in list context.
167
168							=cut
169
170							sub read {
171	23			23	1	5484	my $self = shift;
172	23					551	my $file = shift;
173	23		100			1132	my $gzip = shift \|\| 0;
174	23		100			882	my $opts = shift \|\| {};
175
176	23	100				293	unless( defined $file ) {
177	1					14	$self->_error( qq[No file to read from!] );
178	1					12	return;
179							} else {
180	22					508	$self->_file( $file );
181							}
182
183	22	50				700	my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) )
184							or return;
185
186	22	50				804	my $data = $self->_read_tar( $handle, $opts ) or return;
187
188	22					674	$self->_data( $data );
189
190	22	100				259	return wantarray ? @$data : scalar @$data;
191							}
192
193							sub _get_handle {
194	35			35		317	my $self = shift;
195	35	50				343	my $file = shift; return unless defined $file;
	35					340
196	35	50				338	return $file if ref $file;
197
198	35		100			808	my $gzip = shift \|\| 0;
199	35		33			341	my $mode = shift \|\| READ_ONLY->( ZLIB ); # default to read only
200
201	35					273	my $fh; my $bin;
	35					311
202
203							### only default to ZLIB if we're not trying to /write/ to a handle ###
204	35	100	100			2422	if( ZLIB and $gzip \|\| MODE_READ->( $mode ) ) {
205
206							### IO::Zlib will Do The Right Thing, even when passed
207							### a plain file ###
208	28					1366	$fh = new IO::Zlib;
209
210							} else {
211	7	50				85	if( $gzip ) {
212	0					0	$self->_error(qq[Compression not available - Install IO::Zlib!]);
213	0					0	return;
214
215							} else {
216	7					131	$fh = new IO::File;
217	7					704	$bin++;
218							}
219							}
220
221	35	50				2688	unless( $fh->open( $file, $mode ) ) {
222	0					0	$self->_error( qq[Could not create filehandle for '$file': $!!] );
223	0					0	return;
224							}
225
226	35	100				190651	binmode $fh if $bin;
227
228	35					631	return $fh;
229							}
230
231							sub _read_tar {
232	22			22		261	my $self = shift;
233	22	50				345	my $handle = shift or return;
234	22		50			224	my $opts = shift \|\| {};
235
236	22		100			329	my $count = $opts->{limit} \|\| 0;
237	22		100			291	my $extract = $opts->{extract} \|\| 0;
238
239							### set a cap on the amount of files to extract ###
240	22					612	my $limit = 0;
241	22	100				275	$limit = 1 if $count > 0;
242
243	22					680	my $tarfile = [ ];
244	22					283	my $chunk;
245	22					174	my $read = 0;
246	22					765	my $real_name; # to set the name of a file when
247							# we're encountering @longlink
248	22					178	my $data;
249
250							LOOP:
251	22					673	while( $handle->read( $chunk, HEAD ) ) {
252							### IO::Zlib doesn't support this yet
253	182		50			87382	my $offset = eval { tell $handle } \|\| 'unknown';
	182					2898
254
255	182	100				4405	unless( $read++ ) {
256	22					192	my $gzip = GZIP_MAGIC_NUM;
257	22	50				675	if( $chunk =~ /$gzip/ ) {
258	0					0	$self->_error( qq[Cannot read compressed format in tar-mode] );
259	0					0	return;
260							}
261							}
262
263							### if we can't read in all bytes... ###
264	182	50				2732	last if length $chunk != HEAD;
265
266							### Apparently this should really be two blocks of 512 zeroes,
267							### but GNU tar sometimes gets it wrong. See comment in the
268							### source code (tar.c) to GNU cpio.
269	182	100				1986	next if $chunk eq TAR_END;
270
271							### according to the posix spec, the last 12 bytes of the header are
272							### null bytes, to pad it to a 512 byte block. That means if these
273							### bytes are NOT null bytes, it's a corrrupt header. See:
274							### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx
275							### line 111
276	92					732	{ my $nulls = join '', "\0" x 12;
	92					1004
277	92	50				1020	unless( $nulls eq substr( $chunk, 500, 12 ) ) {
278	0					0	$self->_error( qq[Invalid header block at offset $offset] );
279	0					0	next LOOP;
280							}
281							}
282
283							### pass the realname, so we can set it 'proper' right away
284							### some of the heuristics are done on the name, so important
285							### to set it ASAP
286	92					866	my $entry;
287	92					723	{ my %extra_args = ();
	92					868
288	92	100				904	$extra_args{'name'} = $$real_name if defined $real_name;
289
290	92	50				1700	unless( $entry = Archive::Tar::File->new( chunk => $chunk,
291							%extra_args )
292							) {
293	0					0	$self->_error( qq[Couldn't read chunk at offset $offset] );
294	0					0	next LOOP;
295							}
296							}
297
298							### ignore labels:
299							### http://www.gnu.org/manual/tar/html_node/tar_139.html
300	92	50				1118	next if $entry->is_label;
301
302	92	100	66			1060	if( length $entry->type and ($entry->is_file \|\| $entry->is_longlink) ) {
			66
303
304	72	50	33			794	if ( $entry->is_file && !$entry->validate ) {
305							### sometimes the chunk is rather fux0r3d and a whole 512
306							### bytes ends p in the ->name area.
307							### clean it up, if need be
308	0					0	my $name = $entry->name;
309	0	0				0	$name = substr($name, 0, 100) if length $name > 100;
310	0					0	$name =~ s/\n/ /g;
311
312	0					0	$self->_error( $name . qq[: checksum error] );
313	0					0	next LOOP;
314							}
315
316	72					1112	my $block = BLOCK_SIZE->( $entry->size );
317
318	72					1129	$data = $entry->get_content_by_ref;
319
320							### just read everything into memory
321							### can't do lazy loading since IO::Zlib doesn't support 'seek'
322							### this is because Compress::Zlib doesn't support it =/
323							### this reads in the whole data in one read() call.
324	72	50				1300	if( $handle->read( $$data, $block ) < $block ) {
325	0					0	$self->_error( qq[Read error on tarfile (missing data) '].
326							$entry->full_path ."' at offset $offset" );
327	0					0	next LOOP;
328							}
329
330							### throw away trailing garbage ###
331	72					32652	substr ($$data, $entry->size) = "";
332
333							### part II of the @LongLink munging -- need to do /after/
334							### the checksum check.
335	72	100				924	if( $entry->is_longlink ) {
336							### weird thing in tarfiles -- if the file is actually a
337							### @LongLink, the data part seems to have a trailing ^@
338							### (unprintable) char. to display, pipe output through less.
339							### but that doesn't always happen.. so check if the last
340							### character is a control character, and if so remove it
341							### at any rate, we better remove that character here, or tests
342							### like 'eq' and hashlook ups based on names will SO not work
343							### remove it by calculating the proper size, and then
344							### tossing out everything that's longer than that size.
345
346							### count number of nulls
347	20					222	my $nulls = $$data =~ tr/\0/\0/;
348
349							### cut data + size by that many bytes
350	20					213	$entry->size( $entry->size - $nulls );
351	20					217	substr ($$data, $entry->size) = "";
352							}
353							}
354
355							### clean up of the entries.. posix tar /apparently/ has some
356							### weird 'feature' that allows for filenames > 255 characters
357							### they'll put a header in with as name '././@LongLink' and the
358							### contents will be the name of the /next/ file in the archive
359							### pretty crappy and kludgy if you ask me
360
361							### set the name for the next entry if this is a @LongLink;
362							### this is one ugly hack =/ but needed for direct extraction
363	92	100				1149	if( $entry->is_longlink ) {
		100
364	20					164	$real_name = $data;
365	20					427	next LOOP;
366							} elsif ( defined $real_name ) {
367	20					218	$entry->name( $$real_name );
368	20					610	$entry->prefix('');
369	20					235	undef $real_name;
370							}
371
372	72	100	66			4477	$self->_extract_file( $entry ) if $extract
			66
			66
373							&& !$entry->is_longlink
374							&& !$entry->is_unknown
375							&& !$entry->is_label;
376
377							### Guard against tarfiles with garbage at the end
378	72	50				2178	last LOOP if $entry->name eq '';
379
380							### push only the name on the rv if we're extracting
381							### -- for extract_archive
382	72	100				1062	push @$tarfile, ($extract ? $entry->name : $entry);
383
384	72	100				1751	if( $limit ) {
385	1	50	33			49	$count-- unless $entry->is_longlink \|\| $entry->is_dir;
386	1	50				15	last LOOP unless $count;
387							}
388							} continue {
389	181					4552	undef $data;
390							}
391
392	22					4700	return $tarfile;
393							}
394
395							=head2 $tar->contains_file( $filename )
396
397							Check if the archive contains a certain file.
398							It will return true if the file is in the archive, false otherwise.
399
400							Note however, that this function does an exact match using C<eq>
401							on the full path. So it cannot compensate for case-insensitive file-
402							systems or compare 2 paths to see if they would point to the same
403							underlying file.
404
405							=cut
406
407							sub contains_file {
408	1			1	1	12	my $self = shift;
409	1	50				14	my $full = shift or return;
410
411	1	50				13	return 1 if $self->_find_entry($full);
412	0					0	return;
413							}
414
415							=head2 $tar->extract( [@filenames] )
416
417							Write files whose names are equivalent to any of the names in
418							C<@filenames> to disk, creating subdirectories as necessary. This
419							might not work too well under VMS.
420							Under MacPerl, the file's modification time will be converted to the
421							MacOS zero of time, and appropriate conversions will be done to the
422							path. However, the length of each element of the path is not
423							inspected to see whether it's longer than MacOS currently allows (32
424							characters).
425
426							If C<extract> is called without a list of file names, the entire
427							contents of the archive are extracted.
428
429							Returns a list of filenames extracted.
430
431							=cut
432
433							sub extract {
434	8			8	1	111	my $self = shift;
435	8					75	my @args = @_;
436	8					70	my @files;
437
438							# use the speed optimization for all extracted files
439	8	50				157	local($self->{cwd}) = cwd() unless $self->{cwd};
440
441							### you requested the extraction of only certian files
442	8	100				206355	if( @args ) {
443	2					297	for my $file ( @args ) {
444
445							### it's already an object?
446	2	100				328	if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
447	1					142	push @files, $file;
448	1					119	next;
449
450							### go find it then
451							} else {
452
453	1					94	my $found;
454	1					77	for my $entry ( @{$self->_data} ) {
	1					163
455	1	50				202	next unless $file eq $entry->full_path;
456
457							### we found the file you're looking for
458	1					49	push @files, $entry;
459	1					47	$found++;
460							}
461
462	1	50				33	unless( $found ) {
463	0					0	return $self->_error(
464							qq[Could not find '$file' in archive] );
465							}
466							}
467							}
468
469							### just grab all the file items
470							} else {
471	6					880	@files = $self->get_files;
472							}
473
474							### nothing found? that's an error
475	8	50				152	unless( scalar @files ) {
476	0					0	$self->_error( qq[No files found for ] . $self->_file );
477	0					0	return;
478							}
479
480							### now extract them
481	8					177	for my $entry ( @files ) {
482	26	50				665	unless( $self->_extract_file( $entry ) ) {
483	0					0	$self->_error(q[Could not extract ']. $entry->full_path .q['] );
484	0					0	return;
485							}
486							}
487
488	8					2984	return @files;
489							}
490
491							=head2 $tar->extract_file( $file, [$extract_path] )
492
493							Write an entry, whose name is equivalent to the file name provided to
494							disk. Optionally takes a second parameter, which is the full (unix)
495							path (including filename) the entry will be written to.
496
497							For example:
498
499							$tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
500
501							$tar->extract_file( $at_file_object, 'name/i/want/to/give/it' );
502
503							Returns true on success, false on failure.
504
505							=cut
506
507							sub extract_file {
508	43			43	1	2588	my $self = shift;
509	43	50				1066	my $file = shift or return;
510	43					5488	my $alt = shift;
511
512	43	50				2752	my $entry = $self->_find_entry( $file )
513							or $self->_error( qq[Could not find an entry for '$file'] ), return;
514
515	43					1351	return $self->_extract_file( $entry, $alt );
516							}
517
518							sub _extract_file {
519	75			75		1141	my $self = shift;
520	75	50				818	my $entry = shift or return;
521	75					1329	my $alt = shift;
522
523							### you wanted an alternate extraction location ###
524	75	100				1758	my $name = defined $alt ? $alt : $entry->full_path;
525
526							### splitpath takes a bool at the end to indicate
527							### that it's splitting a dir
528	75					982	my ($vol,$dirs,$file);
529	75	100				799	if ( defined $alt ) { # It's a local-OS path
530	41					829	($vol,$dirs,$file) = File::Spec->splitpath( $alt,
531							$entry->is_dir );
532							} else {
533	34					542	($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
534							$entry->is_dir );
535							}
536
537	75					12138	my $dir;
538							### is $name an absolute path? ###
539	75	100				2903	if( File::Spec->file_name_is_absolute( $dirs ) ) {
540	20					1802	$dir = $dirs;
541
542							### it's a relative path ###
543							} else {
544	55	100				3652	my $cwd = (defined $self->{cwd} ? $self->{cwd} : cwd());
545	55					845474	my @dirs = File::Spec::Unix->splitdir( $dirs );
546	55					5728	my @cwd = File::Spec->splitdir( $cwd );
547	55					8170	$dir = File::Spec->catdir( @cwd, @dirs );
548
549							# catdir() returns undef if the path is longer than 255 chars on VMS
550	55	50				18513	unless ( defined $dir ) {
551	0	0				0	$^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
552	0					0	return;
553							}
554
555							}
556
557	75	50	66			10097	if( -e $dir && !-d _ ) {
558	0	0				0	$^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
559	0					0	return;
560							}
561
562	75	100				744	unless ( -d _ ) {
563	3					76	eval { File::Path::mkpath( $dir, 0, 0777 ) };
	3					204
564	3	50				2486	if( $@ ) {
565	0					0	$self->_error( qq[Could not create directory '$dir': $@] );
566	0					0	return;
567							}
568							}
569
570							### we're done if we just needed to create a dir ###
571	75	100				3090	return 1 if $entry->is_dir;
572
573	71					1009	my $full = File::Spec->catfile( $dir, $file );
574
575	71	50				2866	if( $entry->is_unknown ) {
576	0					0	$self->_error( qq[Unknown file type for file '$full'] );
577	0					0	return;
578							}
579
580	71	50	33			786	if( length $entry->type && $entry->is_file ) {
581	71					8648	my $fh = IO::File->new;
582	71	50				26865	$fh->open( '>' . $full ) or (
583							$self->_error( qq[Could not open file '$full': $!] ),
584							return
585							);
586
587	71	100				29006	if( $entry->size ) {
588	65					4455	binmode $fh;
589	65	50				1899	syswrite $fh, $entry->data or (
590							$self->_error( qq[Could not write data to '$full'] ),
591							return
592							);
593							}
594
595	71	50				3298	close $fh or (
596							$self->_error( qq[Could not close file '$full'] ),
597							return
598							);
599
600							} else {
601	0	0				0	$self->_make_special_file( $entry, $full ) or return;
602							}
603
604	71	50				2334	utime time, $entry->mtime - TIME_OFFSET, $full or
605							$self->_error( qq[Could not update timestamp] );
606
607	71	50	50			3459	if( $CHOWN && CAN_CHOWN ) {
608	0	0				0	chown $entry->uid, $entry->gid, $full or
609							$self->_error( qq[Could not set uid/gid on '$full'] );
610							}
611
612							### only chmod if we're allowed to, but never chmod symlinks, since they'll
613							### change the perms on the file they're linking too...
614	71	50	33			2177	if( $CHMOD and not -l $full ) {
615	71	50				1184	chmod $entry->mode, $full or
616							$self->_error( qq[Could not chown '$full' to ] . $entry->mode );
617							}
618
619	71					4578	return 1;
620							}
621
622							sub _make_special_file {
623	0			0		0	my $self = shift;
624	0	0				0	my $entry = shift or return;
625	0	0				0	my $file = shift; return unless defined $file;
	0					0
626
627	0					0	my $err;
628
629	0	0	0			0	if( $entry->is_symlink ) {
		0
		0
		0
		0
630	0					0	my $fail;
631	0					0	if( ON_UNIX ) {
632	0	0				0	symlink( $entry->linkname, $file ) or $fail++;
633
634							} else {
635							$self->_extract_special_file_as_plain_file( $entry, $file )
636							or $fail++;
637							}
638
639	0	0				0	$err = qq[Making symbolink link from '] . $entry->linkname .
640							qq[' to '$file' failed] if $fail;
641
642							} elsif ( $entry->is_hardlink ) {
643	0					0	my $fail;
644	0					0	if( ON_UNIX ) {
645	0	0				0	link( $entry->linkname, $file ) or $fail++;
646
647							} else {
648							$self->_extract_special_file_as_plain_file( $entry, $file )
649							or $fail++;
650							}
651
652	0	0				0	$err = qq[Making hard link from '] . $entry->linkname .
653							qq[' to '$file' failed] if $fail;
654
655							} elsif ( $entry->is_fifo ) {
656	0	0				0	ON_UNIX && !system('mknod', $file, 'p') or
657							$err = qq[Making fifo ']. $entry->name .qq[' failed];
658
659							} elsif ( $entry->is_blockdev or $entry->is_chardev ) {
660	0	0				0	my $mode = $entry->is_blockdev ? 'b' : 'c';
661
662	0	0				0	ON_UNIX && !system('mknod', $file, $mode,
663							$entry->devmajor, $entry->devminor) or
664							$err = qq[Making block device ']. $entry->name .qq[' (maj=] .
665							$entry->devmajor . qq[ min=] . $entry->devminor .
666							qq[) failed.];
667
668							} elsif ( $entry->is_socket ) {
669							### the original doesn't do anything special for sockets.... ###
670	0					0	1;
671							}
672
673	0	0				0	return $err ? $self->_error( $err ) : 1;
674							}
675
676							### don't know how to make symlinks, let's just extract the file as
677							### a plain file
678							sub _extract_special_file_as_plain_file {
679	0			0		0	my $self = shift;
680	0	0				0	my $entry = shift or return;
681	0	0				0	my $file = shift; return unless defined $file;
	0					0
682
683	0					0	my $err;
684	0					0	TRY: {
685	0					0	my $orig = $self->_find_entry( $entry->linkname );
686
687	0	0				0	unless( $orig ) {
688	0					0	$err = qq[Could not find file '] . $entry->linkname .
689							qq[' in memory.];
690	0					0	last TRY;
691							}
692
693							### clone the entry, make it appear as a normal file ###
694	0					0	my $clone = $entry->clone;
695	0					0	$clone->_downgrade_to_plainfile;
696	0	0				0	$self->_extract_file( $clone, $file ) or last TRY;
697
698	0					0	return 1;
699							}
700
701	0					0	return $self->_error($err);
702							}
703
704							=head2 $tar->list_files( [\@properties] )
705
706							Returns a list of the names of all the files in the archive.
707
708							If C<list_files()> is passed an array reference as its first argument
709							it returns a list of hash references containing the requested
710							properties of each file. The following list of properties is
711							supported: name, size, mtime (last modified date), mode, uid, gid,
712							linkname, uname, gname, devmajor, devminor, prefix.
713
714							Passing an array reference containing only one element, 'name', is
715							special cased to return a list of names rather than a list of hash
716							references, making it equivalent to calling C<list_files> without
717							arguments.
718
719							=cut
720
721							sub list_files {
722	13			13	1	416	my $self = shift;
723	13		50			1515	my $aref = shift \|\| [ ];
724
725	13	50				168	unless( $self->_data ) {
726	0	0				0	$self->read() or return;
727							}
728
729	13	50	0			158	if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
			33
730	13					106	return map { $_->full_path } @{$self->_data};
	48					775
	13					122
731							} else {
732
733							#my @rv;
734							#for my $obj ( @{$self->_data} ) {
735							# push @rv, { map { $_ => $obj->$_() } @$aref };
736							#}
737							#return @rv;
738
739							### this does the same as the above.. just needs a +{ }
740							### to make sure perl doesn't confuse it for a block
741	0					0	return map { my $o=$_;
	0					0
742	0					0	+{ map { $_ => $o->$_() } @$aref }
	0					0
743	0					0	} @{$self->_data};
744							}
745							}
746
747							sub _find_entry {
748	78			78		23102	my $self = shift;
749	78					1902	my $file = shift;
750
751	78	50				955	unless( defined $file ) {
752	0					0	$self->_error( qq[No file specified] );
753	0					0	return;
754							}
755
756							### it's an object already
757	78	100				3720	return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
758
759	67					579	for my $entry ( @{$self->_data} ) {
	67					3445
760	169					1969	my $path = $entry->full_path;
761	169	100				2911	return $entry if $path eq $file;
762							}
763
764	2					32	$self->_error( qq[No such file in archive: '$file'] );
765	2					26	return;
766							}
767
768							=head2 $tar->get_files( [@filenames] )
769
770							Returns the C<Archive::Tar::File> objects matching the filenames
771							provided. If no filename list was passed, all C<Archive::Tar::File>
772							objects in the current Tar object are returned.
773
774							Please refer to the C<Archive::Tar::File> documentation on how to
775							handle these objects.
776
777							=cut
778
779							sub get_files {
780	35			35	1	786	my $self = shift;
781
782	35	100				822	return @{ $self->_data } unless @_;
	31					742
783
784	4					33	my @list;
785	4					53	for my $file ( @_ ) {
786	4					59	push @list, grep { defined } $self->_find_entry( $file );
	2					25
787							}
788
789	4					68	return @list;
790							}
791
792							=head2 $tar->get_content( $file )
793
794							Return the content of the named file.
795
796							=cut
797
798							sub get_content {
799	8			8	1	16054	my $self = shift;
800	8	50				142	my $entry = $self->_find_entry( shift ) or return;
801
802	8					95	return $entry->data;
803							}
804
805							=head2 $tar->replace_content( $file, $content )
806
807							Make the string $content be the content for the file named $file.
808
809							=cut
810
811							sub replace_content {
812	1			1	1	11	my $self = shift;
813	1	50				13	my $entry = $self->_find_entry( shift ) or return;
814
815	1					13	return $entry->replace_content( shift );
816							}
817
818							=head2 $tar->rename( $file, $new_name )
819
820							Rename the file of the in-memory archive to $new_name.
821
822							Note that you must specify a Unix path for $new_name, since per tar
823							standard, all files in the archive must be Unix paths.
824
825							Returns true on success and false on failure.
826
827							=cut
828
829							sub rename {
830	1			1	1	505	my $self = shift;
831	1	50				11	my $file = shift; return unless defined $file;
	1					13
832	1	50				10	my $new = shift; return unless defined $new;
	1					13
833
834	1	50				12	my $entry = $self->_find_entry( $file ) or return;
835
836	1					15	return $entry->rename( $new );
837							}
838
839							=head2 $tar->remove (@filenamelist)
840
841							Removes any entries with names matching any of the given filenames
842							from the in-memory archive. Returns a list of C<Archive::Tar::File>
843							objects that remain.
844
845							=cut
846
847							sub remove {
848	1			1	1	12	my $self = shift;
849	1					11	my @list = @_;
850
851	1					9	my %seen = map { $_->full_path => $_ } @{$self->_data};
	5					53
	1					13
852	1					12	delete $seen{ $_ } for @list;
	1					17
853
854	1					15	$self->_data( [values %seen] );
855
856	1					18	return values %seen;
857							}
858
859							=head2 $tar->clear
860
861							C<clear> clears the current in-memory archive. This effectively gives
862							you a 'blank' object, ready to be filled again. Note that C<clear>
863							only has effect on the object, not the underlying tarfile.
864
865							=cut
866
867							sub clear {
868	2	50		2	1	679	my $self = shift or return;
869
870	2					26	$self->_data( [] );
871	2					24	$self->_file( '' );
872
873	2					85	return 1;
874							}
875
876
877							=head2 $tar->write ( [$file, $compressed, $prefix] )
878
879							Write the in-memory archive to disk. The first argument can either
880							be the name of a file or a reference to an already open filehandle (a
881							GLOB reference). If the second argument is true, the module will use
882							IO::Zlib to write the file in a compressed format. If IO::Zlib is
883							not available, the C<write> method will fail and return.
884
885							Note that when you pass in a filehandle, the compression argument
886							is ignored, as all files are printed verbatim to your filehandle.
887							If you wish to enable compression with filehandles, use an
888							C<IO::Zlib> filehandle instead.
889
890							Specific levels of compression can be chosen by passing the values 2
891							through 9 as the second parameter.
892
893							The third argument is an optional prefix. All files will be tucked
894							away in the directory you specify as prefix. So if you have files
895							'a' and 'b' in your archive, and you specify 'foo' as prefix, they
896							will be written to the archive as 'foo/a' and 'foo/b'.
897
898							If no arguments are given, C<write> returns the entire formatted
899							archive as a string, which could be useful if you'd like to stuff the
900							archive into a socket or a pipe to gzip or something.
901
902							=cut
903
904							sub write {
905	16			16	1	6881	my $self = shift;
906	16	100				467	my $file = shift; $file = '' unless defined $file;
	16					349
907	16		100			745	my $gzip = shift \|\| 0;
908	16	50				144	my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
	16					403
909	16					592	my $dummy = '';
910
911							### only need a handle if we have a file to print to ###
912							my $handle = length($file)
913							? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
914							or return )
915	1	0	33	1		563	: $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h }
	1	50				10
	1	100				16
	16					892
	3					98
	3					52
916							: $HAS_IO_STRING ? IO::String->new
917							: __PACKAGE__->no_string_support();
918
919
920
921	16					195	for my $entry ( @{$self->_data} ) {
	16					454
922							### entries to be written to the tarfile ###
923	43					1995	my @write_me;
924
925							### only now will we change the object to reflect the current state
926							### of the name and prefix fields -- this needs to be limited to
927							### write() only!
928	43					1360	my $clone = $entry->clone;
929
930
931							### so, if you don't want use to use the prefix, we'll stuff
932							### everything in the name field instead
933	43	100				566	if( $DO_NOT_USE_PREFIX ) {
934
935							### you might have an extended prefix, if so, set it in the clone
936							### XXX is ::Unix right?
937	1	50				17	$clone->name( length $ext_prefix
938							? File::Spec::Unix->catdir( $ext_prefix,
939							$clone->full_path)
940							: $clone->full_path );
941	1					13	$clone->prefix( '' );
942
943							### otherwise, we'll have to set it properly -- prefix part in the
944							### prefix and name part in the name field.
945							} else {
946
947							### split them here, not before!
948	42					635	my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
949
950							### you might have an extended prefix, if so, set it in the clone
951							### XXX is ::Unix right?
952	42	50				452	$prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
953							if length $ext_prefix;
954
955	42					542	$clone->prefix( $prefix );
956	42					420	$clone->name( $name );
957							}
958
959							### names are too long, and will get truncated if we don't add a
960							### '@LongLink' file...
961	43		100			434	my $make_longlink = ( length($clone->name) > NAME_LENGTH or
			100
962							length($clone->prefix) > PREFIX_LENGTH
963							) \|\| 0;
964
965							### perhaps we need to make a longlink file?
966	43	100				562	if( $make_longlink ) {
967	6					64	my $longlink = Archive::Tar::File->new(
968							data => LONGLINK_NAME,
969							$clone->full_path,
970							{ type => LONGLINK }
971							);
972
973	6	50				90	unless( $longlink ) {
974	0					0	$self->_error( qq[Could not create 'LongLink' entry for ] .
975							qq[oversize file '] . $clone->full_path ."'" );
976	0					0	return;
977							};
978
979	6					61	push @write_me, $longlink;
980							}
981
982	43					388	push @write_me, $clone;
983
984							### write the one, optionally 2 a::t::file objects to the handle
985	43					412	for my $clone (@write_me) {
986
987							### if the file is a symlink, there are 2 options:
988							### either we leave the symlink intact, but then we don't write any
989							### data OR we follow the symlink, which means we actually make a
990							### copy. if we do the latter, we have to change the TYPE of the
991							### clone to 'FILE'
992	49		33			1303	my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
993	49		66			530	my $data_ok = !$clone->is_symlink && $clone->has_content;
994
995							### downgrade to a 'normal' file if it's a symlink we're going to
996							### treat as a regular file
997	49	50				639	$clone->_downgrade_to_plainfile if $link_ok;
998
999							### get the header for this block
1000	49					640	my $header = $self->_format_tar_entry( $clone );
1001	49	50				491	unless( $header ) {
1002	0					0	$self->_error(q[Could not format header for: ] .
1003							$clone->full_path );
1004	0					0	return;
1005							}
1006
1007	49	50				1524	unless( print $handle $header ) {
1008	0					0	$self->_error(q[Could not write header for: ] .
1009							$clone->full_path);
1010	0					0	return;
1011							}
1012
1013	49	100	66			11109	if( $link_ok or $data_ok ) {
1014	40	50				450	unless( print $handle $clone->data ) {
1015	0					0	$self->_error(q[Could not write data for: ] .
1016							$clone->full_path);
1017	0					0	return;
1018							}
1019
1020							### pad the end of the clone if required ###
1021	40	50				10537	print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
1022							}
1023
1024							} ### done writing these entries
1025							}
1026
1027							### write the end markers ###
1028	16	50				377	print $handle TAR_END x 2 or
1029							return $self->_error( qq[Could not write tar end markers] );
1030
1031							### did you want it written to a file, or returned as a string? ###
1032							my $rv = length($file) ? 1
1033							: $HAS_PERLIO ? $dummy
1034	16	50				2302	: do { seek $handle, 0, 0; local $/; <$handle> };
	0	100				0
	0					0
	0					0
1035
1036							### make sure to close the handle;
1037	16					984	close $handle;
1038
1039	16					214	return $rv;
1040							}
1041
1042							sub _format_tar_entry {
1043	49			49		434	my $self = shift;
1044	49	50				514	my $entry = shift or return;
1045	49	50				483	my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
	49					724
1046	49		50			765	my $no_prefix = shift \|\| 0;
1047
1048	49					689	my $file = $entry->name;
1049	49	50				513	my $prefix = $entry->prefix; $prefix = '' unless defined $prefix;
	49					561
1050
1051							### remove the prefix from the file name
1052							### not sure if this is still neeeded --kane
1053							### no it's not -- Archive::Tar::File->_new_from_file will take care of
1054							### this for us. Even worse, this would break if we tried to add a file
1055							### like x/x.
1056							#if( length $prefix ) {
1057							# $file =~ s/^$match//;
1058							#}
1059
1060	49	50				492	$prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
1061							if length $ext_prefix;
1062
1063							### not sure why this is... ###
1064	49					424	my $l = PREFIX_LENGTH; # is ambiguous otherwise...
1065	49	100				513	substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
1066
1067	49					621	my $f1 = "%06o"; my $f2 = "%11o";
	49					401
1068
1069							### this might be optimizable with a 'changed' flag in the file objects ###
1070	147					1904	my $tar = pack (
1071							PACK,
1072							$file,
1073
1074	98					1339	(map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
1075	147					1557	(map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
1076
1077							"", # checksum field - space padded a bit down
1078
1079	98					1340	(map { $entry->$_() } qw[type linkname magic]),
1080
1081							$entry->version \|\| TAR_VERSION,
1082
1083	98					1033	(map { $entry->$_() } qw[uname gname]),
1084	49	50	100			426	(map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
1085
1086							($no_prefix ? '' : $prefix)
1087							);
1088
1089							### add the checksum ###
1090	49					2034	substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
1091
1092	49					664	return $tar;
1093							}
1094
1095							=head2 $tar->add_files( @filenamelist )
1096
1097							Takes a list of filenames and adds them to the in-memory archive.
1098
1099							The path to the file is automatically converted to a Unix like
1100							equivalent for use in the archive, and, if on MacOS, the file's
1101							modification time is converted from the MacOS epoch to the Unix epoch.
1102							So tar archives created on MacOS with B<Archive::Tar> can be read
1103							both with I<tar> on Unix and applications like I<suntar> or
1104							I<Stuffit Expander> on MacOS.
1105
1106							Be aware that the file's type/creator and resource fork will be lost,
1107							which is usually what you want in cross-platform archives.
1108
1109							Returns a list of C<Archive::Tar::File> objects that were just added.
1110
1111							=cut
1112
1113							sub add_files {
1114	10			10	1	2627	my $self = shift;
1115	10	50				314	my @files = @_ or return;
1116
1117	10					85	my @rv;
1118	10					211	for my $file ( @files ) {
1119	10	50				261	unless( -e $file ) {
1120	0					0	$self->_error( qq[No such file: '$file'] );
1121	0					0	next;
1122							}
1123
1124	10					511	my $obj = Archive::Tar::File->new( file => $file );
1125	10	50				106	unless( $obj ) {
1126	0					0	$self->_error( qq[Unable to add file: '$file'] );
1127	0					0	next;
1128							}
1129
1130	10					354	push @rv, $obj;
1131							}
1132
1133	10					90	push @{$self->{_data}}, @rv;
	10					138
1134
1135	10					114	return @rv;
1136							}
1137
1138							=head2 $tar->add_data ( $filename, $data, [$opthashref] )
1139
1140							Takes a filename, a scalar full of data and optionally a reference to
1141							a hash with specific options.
1142
1143							Will add a file to the in-memory archive, with name C<$filename> and
1144							content C<$data>. Specific properties can be set using C<$opthashref>.
1145							The following list of properties is supported: name, size, mtime
1146							(last modified date), mode, uid, gid, linkname, uname, gname,
1147							devmajor, devminor, prefix, type. (On MacOS, the file's path and
1148							modification times are converted to Unix equivalents.)
1149
1150							Valid values for the file type are the following constants defined in
1151							Archive::Tar::Constants:
1152
1153							=over 4
1154
1155							=item FILE
1156
1157							Regular file.
1158
1159							=item HARDLINK
1160
1161							=item SYMLINK
1162
1163							Hard and symbolic ("soft") links; linkname should specify target.
1164
1165							=item CHARDEV
1166
1167							=item BLOCKDEV
1168
1169							Character and block devices. devmajor and devminor should specify the major
1170							and minor device numbers.
1171
1172							=item DIR
1173
1174							Directory.
1175
1176							=item FIFO
1177
1178							FIFO (named pipe).
1179
1180							=item SOCKET
1181
1182							Socket.
1183
1184							=back
1185
1186							Returns the C<Archive::Tar::File> object that was just added, or
1187							C<undef> on failure.
1188
1189							=cut
1190
1191							sub add_data {
1192	9			9	1	8752	my $self = shift;
1193	9					100	my ($file, $data, $opt) = @_;
1194
1195	9					125	my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
1196	9	100				96	unless( $obj ) {
1197	1					14	$self->_error( qq[Unable to add file: '$file'] );
1198	1					12	return;
1199							}
1200
1201	8					64	push @{$self->{_data}}, $obj;
	8					89
1202
1203	8					89	return $obj;
1204							}
1205
1206							=head2 $tar->error( [$BOOL] )
1207
1208							Returns the current errorstring (usually, the last error reported).
1209							If a true value was specified, it will give the C<Carp::longmess>
1210							equivalent of the error, in effect giving you a stacktrace.
1211
1212							For backwards compatibility, this error is also available as
1213							C<$Archive::Tar::error> although it is much recommended you use the
1214							method call instead.
1215
1216							=cut
1217
1218							{
1219							$error = '';
1220							my $longmess;
1221
1222							sub _error {
1223	4			4		40	my $self = shift;
1224	4					44	my $msg = $error = shift;
1225	4					51	$longmess = Carp::longmess($error);
1226
1227							### set Archive::Tar::WARN to 0 to disable printing
1228							### of errors
1229	4	50				42	if( $WARN ) {
1230	0	0				0	carp $DEBUG ? $longmess : $msg;
1231							}
1232
1233	4					37	return;
1234							}
1235
1236							sub error {
1237	8			8	1	2432	my $self = shift;
1238	8	50				220	return shift() ? $longmess : $error;
1239							}
1240							}
1241
1242							=head2 $tar->setcwd( $cwd );
1243
1244							C<Archive::Tar> needs to know the current directory, and it will run
1245							C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
1246							tarfile and saves it in the file system. (As of version 1.30, however,
1247							C<Archive::Tar> will use the speed optimization described below
1248							automatically, so it's only relevant if you're using C<extract_file()>).
1249
1250							Since C<Archive::Tar> doesn't change the current directory internally
1251							while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
1252							can be avoided if we can guarantee that the current directory doesn't
1253							get changed externally.
1254
1255							To use this performance boost, set the current directory via
1256
1257							use Cwd;
1258							$tar->setcwd( cwd() );
1259
1260							once before calling a function like C<extract_file> and
1261							C<Archive::Tar> will use the current directory setting from then on
1262							and won't call C<Cwd::cwd()> internally.
1263
1264							To switch back to the default behaviour, use
1265
1266							$tar->setcwd( undef );
1267
1268							and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
1269
1270							If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
1271							be called for you.
1272
1273							=cut
1274
1275							sub setcwd {
1276	0			0	1	0	my $self = shift;
1277	0					0	my $cwd = shift;
1278
1279	0					0	$self->{cwd} = $cwd;
1280							}
1281
1282							=head2 $bool = $tar->has_io_string
1283
1284							Returns true if we currently have C<IO::String> support loaded.
1285
1286							Either C<IO::String> or C<perlio> support is needed to support writing
1287							stringified archives. Currently, C<perlio> is the preferred method, if
1288							available.
1289
1290							See the C<GLOBAL VARIABLES> section to see how to change this preference.
1291
1292							=cut
1293
1294	0			0	1	0	sub has_io_string { return $HAS_IO_STRING; }
1295
1296							=head2 $bool = $tar->has_perlio
1297
1298							Returns true if we currently have C<perlio> support loaded.
1299
1300							This requires C<perl-5.8> or higher, compiled with C<perlio>
1301
1302							Either C<IO::String> or C<perlio> support is needed to support writing
1303							stringified archives. Currently, C<perlio> is the preferred method, if
1304							available.
1305
1306							See the C<GLOBAL VARIABLES> section to see how to change this preference.
1307
1308							=cut
1309
1310	0			0	1	0	sub has_perlio { return $HAS_PERLIO; }
1311
1312
1313							=head1 Class Methods
1314
1315							=head2 Archive::Tar->create_archive($file, $compression, @filelist)
1316
1317							Creates a tar file from the list of files provided. The first
1318							argument can either be the name of the tar file to create or a
1319							reference to an open file handle (e.g. a GLOB reference).
1320
1321							The second argument specifies the level of compression to be used, if
1322							any. Compression of tar files requires the installation of the
1323							IO::Zlib module. Specific levels of compression may be
1324							requested by passing a value between 2 and 9 as the second argument.
1325							Any other value evaluating as true will result in the default
1326							compression level being used.
1327
1328							Note that when you pass in a filehandle, the compression argument
1329							is ignored, as all files are printed verbatim to your filehandle.
1330							If you wish to enable compression with filehandles, use an
1331							C<IO::Zlib> filehandle instead.
1332
1333							The remaining arguments list the files to be included in the tar file.
1334							These files must all exist. Any files which don't exist or can't be
1335							read are silently ignored.
1336
1337							If the archive creation fails for any reason, C<create_archive> will
1338							return false. Please use the C<error> method to find the cause of the
1339							failure.
1340
1341							Note that this method does not write C<on the fly> as it were; it
1342							still reads all the files into memory before writing out the archive.
1343							Consult the FAQ below if this is a problem.
1344
1345							=cut
1346
1347							sub create_archive {
1348	6			6	1	222	my $class = shift;
1349
1350	6	50				55	my $file = shift; return unless defined $file;
	6					94
1351	6		100			87	my $gzip = shift \|\| 0;
1352	6					82	my @files = @_;
1353
1354	6	50				60	unless( @files ) {
1355	0					0	return $class->_error( qq[Cowardly refusing to create empty archive!] );
1356							}
1357
1358	6					299	my $tar = $class->new;
1359	6					174	$tar->add_files( @files );
1360	6					360	return $tar->write( $file, $gzip );
1361							}
1362
1363							=head2 Archive::Tar->list_archive ($file, $compressed, [\@properties])
1364
1365							Returns a list of the names of all the files in the archive. The
1366							first argument can either be the name of the tar file to list or a
1367							reference to an open file handle (e.g. a GLOB reference).
1368
1369							If C<list_archive()> is passed an array reference as its third
1370							argument it returns a list of hash references containing the requested
1371							properties of each file. The following list of properties is
1372							supported: full_path, name, size, mtime (last modified date), mode,
1373							uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
1374
1375							See C<Archive::Tar::File> for details about supported properties.
1376
1377							Passing an array reference containing only one element, 'name', is
1378							special cased to return a list of names rather than a list of hash
1379							references.
1380
1381							=cut
1382
1383							sub list_archive {
1384	2			2	1	1492	my $class = shift;
1385	2	50				22	my $file = shift; return unless defined $file;
	2					23
1386	2		50			29	my $gzip = shift \|\| 0;
1387
1388	2					26	my $tar = $class->new($file, $gzip);
1389	2	50				24	return unless $tar;
1390
1391	2					25	return $tar->list_files( @_ );
1392							}
1393
1394							=head2 Archive::Tar->extract_archive ($file, $gzip)
1395
1396							Extracts the contents of the tar file. The first argument can either
1397							be the name of the tar file to create or a reference to an open file
1398							handle (e.g. a GLOB reference). All relative paths in the tar file will
1399							be created underneath the current working directory.
1400
1401							C<extract_archive> will return a list of files it extracted.
1402							If the archive extraction fails for any reason, C<extract_archive>
1403							will return false. Please use the C<error> method to find the cause
1404							of the failure.
1405
1406							=cut
1407
1408							sub extract_archive {
1409	6			6	1	57	my $class = shift;
1410	6	50				57	my $file = shift; return unless defined $file;
	6					64
1411	6		100			107	my $gzip = shift \|\| 0;
1412
1413	6	50				71	my $tar = $class->new( ) or return;
1414
1415	6					79	return $tar->read( $file, $gzip, { extract => 1 } );
1416							}
1417
1418							=head2 Archive::Tar->can_handle_compressed_files
1419
1420							A simple checking routine, which will return true if C<Archive::Tar>
1421							is able to uncompress compressed archives on the fly with C<IO::Zlib>,
1422							or false if C<IO::Zlib> is not installed.
1423
1424