This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Cross-compilation makefile fails to copy Config_heavy.pl
[perl5.git] / lib / Archive / Tar.pm
CommitLineData
39713df4
RGS
1### the gnu tar specification:
2### http://www.gnu.org/software/tar/manual/html_mono/tar.html
3###
4### and the pax format spec, which tar derives from:
5### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html
6
7package Archive::Tar;
8require 5.005_03;
9
10use strict;
11use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
12 $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING];
13
14$DEBUG = 0;
15$WARN = 1;
16$FOLLOW_SYMLINK = 0;
376cc5ea 17$VERSION = "1.29_02";
39713df4
RGS
18$CHOWN = 1;
19$CHMOD = 1;
20$DO_NOT_USE_PREFIX = 0;
21
22BEGIN {
23 use Config;
24 $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 eval {
29 require IO::String;
30 import IO::String;
31 };
32 $HAS_IO_STRING = $@ ? 0 : 1;
33
34}
35
36use Cwd;
37use IO::File;
38use Carp qw(carp croak);
39use File::Spec ();
40use File::Spec::Unix ();
41use File::Path ();
42
43use Archive::Tar::File;
44use Archive::Tar::Constant;
45
46=head1 NAME
47
48Archive::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
67Archive::Tar provides an object oriented mechanism for handling tar
68files. It provides class methods for quick and easy files handling
69while also allowing for the creation of tar file objects for custom
70manipulation. If you have the IO::Zlib module installed,
71Archive::Tar will also support compressed or gzipped tar files.
72
73An object of class Archive::Tar represents a .tar(.gz) archive full
74of files and things.
75
76=head1 Object Methods
77
78=head2 Archive::Tar->new( [$file, $compressed] )
79
80Returns a new Tar object. If given any arguments, C<new()> calls the
81C<read()> method automatically, passing on the arguments provided to
82the C<read()> method.
83
84If C<new()> is invoked with arguments and the C<read()> method fails
85for any reason, C<new()> returns undef.
86
87=cut
88
89my $tmpl = {
90 _data => [ ],
91 _file => 'Unknown',
92};
93
94### install get/set accessors for this object.
95for my $key ( keys %$tmpl ) {
96 no strict 'refs';
97 *{__PACKAGE__."::$key"} = sub {
98 my $self = shift;
99 $self->{$key} = $_[0] if @_;
100 return $self->{$key};
101 }
102}
103
104sub new {
105 my $class = shift;
106 $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 my $obj = bless { _data => [ ], _file => 'Unknown' }, $class;
111
112 if (@_) {
81a5970e
RGS
113 unless ( $obj->read( @_ ) ) {
114 $obj->_error(qq[No data could be read from file]);
115 return;
116 }
39713df4
RGS
117 }
118
119 return $obj;
120}
121
122=head2 $tar->read ( $filename|$handle, $compressed, {opt => 'val'} )
123
124Read the given tar file into memory.
125The first argument can either be the name of a file or a reference to
126an already open filehandle (or an IO::Zlib object if it's compressed)
127The second argument indicates whether the file referenced by the first
128argument is compressed.
129
130The C<read> will I<replace> any previous content in C<$tar>!
131
132The second argument may be considered optional if IO::Zlib is
133installed, since it will transparently Do The Right Thing.
134Archive::Tar will warn if you try to pass a compressed file if
135IO::Zlib is not available and simply return.
136
b3200c5d
SP
137Note that you can currently B<not> pass a C<gzip> compressed
138filehandle, which is not opened with C<IO::Zlib>, nor a string
139containing the full archive information (either compressed or
140uncompressed). These are worth while features, but not currently
141implemented. See the C<TODO> section.
142
39713df4
RGS
143The third argument can be a hash reference with options. Note that
144all options are case-sensitive.
145
146=over 4
147
148=item limit
149
150Do not read more than C<limit> files. This is useful if you have
151very big archives, and are only interested in the first few files.
152
153=item extract
154
155If set to true, immediately extract entries when reading them. This
156gives you the same memory break as the C<extract_archive> function.
157Note however that entries will not be read into memory, but written
158straight to disk.
159
160=back
161
162All files are stored internally as C<Archive::Tar::File> objects.
163Please consult the L<Archive::Tar::File> documentation for details.
164
165Returns the number of files read in scalar context, and a list of
166C<Archive::Tar::File> objects in list context.
167
168=cut
169
170sub read {
171 my $self = shift;
172 my $file = shift;
173 my $gzip = shift || 0;
174 my $opts = shift || {};
175
176 unless( defined $file ) {
177 $self->_error( qq[No file to read from!] );
178 return;
179 } else {
180 $self->_file( $file );
181 }
182
183 my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) )
184 or return;
185
186 my $data = $self->_read_tar( $handle, $opts ) or return;
187
188 $self->_data( $data );
189
190 return wantarray ? @$data : scalar @$data;
191}
192
193sub _get_handle {
194 my $self = shift;
195 my $file = shift; return unless defined $file;
196 return $file if ref $file;
197
198 my $gzip = shift || 0;
199 my $mode = shift || READ_ONLY->( ZLIB ); # default to read only
200
201 my $fh; my $bin;
202
203 ### only default to ZLIB if we're not trying to /write/ to a handle ###
204 if( ZLIB and $gzip || MODE_READ->( $mode ) ) {
205
206 ### IO::Zlib will Do The Right Thing, even when passed
207 ### a plain file ###
208 $fh = new IO::Zlib;
209
210 } else {
211 if( $gzip ) {
212 $self->_error(qq[Compression not available - Install IO::Zlib!]);
213 return;
214
215 } else {
216 $fh = new IO::File;
217 $bin++;
218 }
219 }
220
221 unless( $fh->open( $file, $mode ) ) {
222 $self->_error( qq[Could not create filehandle for '$file': $!!] );
223 return;
224 }
225
226 binmode $fh if $bin;
227
228 return $fh;
229}
230
231sub _read_tar {
232 my $self = shift;
233 my $handle = shift or return;
234 my $opts = shift || {};
235
236 my $count = $opts->{limit} || 0;
237 my $extract = $opts->{extract} || 0;
238
239 ### set a cap on the amount of files to extract ###
240 my $limit = 0;
241 $limit = 1 if $count > 0;
242
243 my $tarfile = [ ];
244 my $chunk;
245 my $read = 0;
246 my $real_name; # to set the name of a file when
247 # we're encountering @longlink
248 my $data;
249
250 LOOP:
251 while( $handle->read( $chunk, HEAD ) ) {
252 ### IO::Zlib doesn't support this yet
253 my $offset = eval { tell $handle } || 'unknown';
254
255 unless( $read++ ) {
256 my $gzip = GZIP_MAGIC_NUM;
257 if( $chunk =~ /$gzip/ ) {
258 $self->_error( qq[Cannot read compressed format in tar-mode] );
259 return;
260 }
261 }
262
263 ### if we can't read in all bytes... ###
264 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 next if $chunk eq TAR_END;
270
b30bcf62
RGS
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 { my $nulls = join '', "\0" x 12;
277 unless( $nulls eq substr( $chunk, 500, 12 ) ) {
278 $self->_error( qq[Invalid header block at offset $offset] );
279 next LOOP;
280 }
281 }
282
81a5970e
RGS
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
39713df4 286 my $entry;
81a5970e
RGS
287 { my %extra_args = ();
288 $extra_args{'name'} = $$real_name if defined $real_name;
289
290 unless( $entry = Archive::Tar::File->new( chunk => $chunk,
291 %extra_args )
292 ) {
293 $self->_error( qq[Couldn't read chunk at offset $offset] );
b30bcf62 294 next LOOP;
81a5970e 295 }
39713df4
RGS
296 }
297
298 ### ignore labels:
299 ### http://www.gnu.org/manual/tar/html_node/tar_139.html
300 next if $entry->is_label;
301
302 if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) {
303
304 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 my $name = $entry->name;
309 $name = substr($name, 0, 100) if length $name > 100;
310 $name =~ s/\n/ /g;
311
312 $self->_error( $name . qq[: checksum error] );
313 next LOOP;
314 }
315
316 my $block = BLOCK_SIZE->( $entry->size );
317
318 $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 if( $handle->read( $$data, $block ) < $block ) {
325 $self->_error( qq[Read error on tarfile (missing data) '].
326 $entry->full_path ."' at offset $offset" );
b30bcf62 327 next LOOP;
39713df4
RGS
328 }
329
330 ### throw away trailing garbage ###
376cc5ea 331 substr ($$data, $entry->size) = "" if defined $$data;
39713df4
RGS
332
333 ### part II of the @LongLink munging -- need to do /after/
334 ### the checksum check.
335 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 my $nulls = $$data =~ tr/\0/\0/;
348
349 ### cut data + size by that many bytes
350 $entry->size( $entry->size - $nulls );
351 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 if( $entry->is_longlink ) {
364 $real_name = $data;
b30bcf62 365 next LOOP;
39713df4
RGS
366 } elsif ( defined $real_name ) {
367 $entry->name( $$real_name );
368 $entry->prefix('');
369 undef $real_name;
370 }
371
372 $self->_extract_file( $entry ) if $extract
373 && !$entry->is_longlink
374 && !$entry->is_unknown
375 && !$entry->is_label;
376
377 ### Guard against tarfiles with garbage at the end
378 last LOOP if $entry->name eq '';
379
380 ### push only the name on the rv if we're extracting
381 ### -- for extract_archive
382 push @$tarfile, ($extract ? $entry->name : $entry);
383
384 if( $limit ) {
385 $count-- unless $entry->is_longlink || $entry->is_dir;
386 last LOOP unless $count;
387 }
388 } continue {
389 undef $data;
390 }
391
392 return $tarfile;
393}
394
395=head2 $tar->contains_file( $filename )
396
397Check if the archive contains a certain file.
398It will return true if the file is in the archive, false otherwise.
399
400Note however, that this function does an exact match using C<eq>
401on the full path. So it cannot compensate for case-insensitive file-
402systems or compare 2 paths to see if they would point to the same
403underlying file.
404
405=cut
406
407sub contains_file {
408 my $self = shift;
409 my $full = shift or return;
410
411 return 1 if $self->_find_entry($full);
412 return;
413}
414
415=head2 $tar->extract( [@filenames] )
416
417Write files whose names are equivalent to any of the names in
418C<@filenames> to disk, creating subdirectories as necessary. This
419might not work too well under VMS.
420Under MacPerl, the file's modification time will be converted to the
421MacOS zero of time, and appropriate conversions will be done to the
422path. However, the length of each element of the path is not
423inspected to see whether it's longer than MacOS currently allows (32
424characters).
425
426If C<extract> is called without a list of file names, the entire
427contents of the archive are extracted.
428
429Returns a list of filenames extracted.
430
431=cut
432
433sub extract {
434 my $self = shift;
b30bcf62 435 my @args = @_;
39713df4
RGS
436 my @files;
437
438 ### you requested the extraction of only certian files
b30bcf62
RGS
439 if( @args ) {
440 for my $file ( @args ) {
441
442 ### it's already an object?
443 if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
444 push @files, $file;
445 next;
39713df4 446
b30bcf62
RGS
447 ### go find it then
448 } else {
449
450 my $found;
451 for my $entry ( @{$self->_data} ) {
452 next unless $file eq $entry->full_path;
453
454 ### we found the file you're looking for
455 push @files, $entry;
456 $found++;
457 }
458
459 unless( $found ) {
460 return $self->_error(
461 qq[Could not find '$file' in archive] );
462 }
39713df4
RGS
463 }
464 }
465
466 ### just grab all the file items
467 } else {
468 @files = $self->get_files;
469 }
470
471 ### nothing found? that's an error
472 unless( scalar @files ) {
473 $self->_error( qq[No files found for ] . $self->_file );
474 return;
475 }
476
477 ### now extract them
478 for my $entry ( @files ) {
479 unless( $self->_extract_file( $entry ) ) {
480 $self->_error(q[Could not extract ']. $entry->full_path .q['] );
481 return;
482 }
483 }
484
485 return @files;
486}
487
488=head2 $tar->extract_file( $file, [$extract_path] )
489
490Write an entry, whose name is equivalent to the file name provided to
491disk. Optionally takes a second parameter, which is the full (unix)
492path (including filename) the entry will be written to.
493
494For example:
495
496 $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
497
b30bcf62
RGS
498 $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' );
499
39713df4
RGS
500Returns true on success, false on failure.
501
502=cut
503
504sub extract_file {
505 my $self = shift;
506 my $file = shift or return;
507 my $alt = shift;
508
509 my $entry = $self->_find_entry( $file )
510 or $self->_error( qq[Could not find an entry for '$file'] ), return;
511
512 return $self->_extract_file( $entry, $alt );
513}
514
515sub _extract_file {
516 my $self = shift;
517 my $entry = shift or return;
518 my $alt = shift;
39713df4
RGS
519
520 ### you wanted an alternate extraction location ###
521 my $name = defined $alt ? $alt : $entry->full_path;
522
523 ### splitpath takes a bool at the end to indicate
524 ### that it's splitting a dir
7f10f74b
SH
525 my ($vol,$dirs,$file);
526 if ( defined $alt ) { # It's a local-OS path
527 ($vol,$dirs,$file) = File::Spec->splitpath( $alt,
528 $entry->is_dir );
529 } else {
530 ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
531 $entry->is_dir );
532 }
533
39713df4
RGS
534 my $dir;
535 ### is $name an absolute path? ###
536 if( File::Spec->file_name_is_absolute( $dirs ) ) {
537 $dir = $dirs;
538
539 ### it's a relative path ###
540 } else {
b30bcf62 541 my $cwd = cwd();
39713df4
RGS
542 my @dirs = File::Spec::Unix->splitdir( $dirs );
543 my @cwd = File::Spec->splitdir( $cwd );
81a5970e
RGS
544 $dir = File::Spec->catdir( @cwd, @dirs );
545
546 # catdir() returns undef if the path is longer than 255 chars on VMS
547 unless ( defined $dir ) {
548 $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
549 return;
550 }
551
39713df4
RGS
552 }
553
554 if( -e $dir && !-d _ ) {
555 $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
556 return;
557 }
558
559 unless ( -d _ ) {
560 eval { File::Path::mkpath( $dir, 0, 0777 ) };
561 if( $@ ) {
562 $self->_error( qq[Could not create directory '$dir': $@] );
563 return;
564 }
565 }
566
567 ### we're done if we just needed to create a dir ###
568 return 1 if $entry->is_dir;
569
570 my $full = File::Spec->catfile( $dir, $file );
571
572 if( $entry->is_unknown ) {
573 $self->_error( qq[Unknown file type for file '$full'] );
574 return;
575 }
576
577 if( length $entry->type && $entry->is_file ) {
578 my $fh = IO::File->new;
579 $fh->open( '>' . $full ) or (
580 $self->_error( qq[Could not open file '$full': $!] ),
581 return
582 );
583
584 if( $entry->size ) {
585 binmode $fh;
586 syswrite $fh, $entry->data or (
587 $self->_error( qq[Could not write data to '$full'] ),
588 return
589 );
590 }
591
592 close $fh or (
593 $self->_error( qq[Could not close file '$full'] ),
594 return
595 );
596
597 } else {
598 $self->_make_special_file( $entry, $full ) or return;
599 }
600
601 utime time, $entry->mtime - TIME_OFFSET, $full or
602 $self->_error( qq[Could not update timestamp] );
603
604 if( $CHOWN && CAN_CHOWN ) {
605 chown $entry->uid, $entry->gid, $full or
606 $self->_error( qq[Could not set uid/gid on '$full'] );
607 }
608
609 ### only chmod if we're allowed to, but never chmod symlinks, since they'll
610 ### change the perms on the file they're linking too...
611 if( $CHMOD and not -l $full ) {
612 chmod $entry->mode, $full or
613 $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
614 }
615
616 return 1;
617}
618
619sub _make_special_file {
620 my $self = shift;
621 my $entry = shift or return;
622 my $file = shift; return unless defined $file;
623
624 my $err;
625
626 if( $entry->is_symlink ) {
627 my $fail;
628 if( ON_UNIX ) {
629 symlink( $entry->linkname, $file ) or $fail++;
630
631 } else {
632 $self->_extract_special_file_as_plain_file( $entry, $file )
633 or $fail++;
634 }
635
636 $err = qq[Making symbolink link from '] . $entry->linkname .
637 qq[' to '$file' failed] if $fail;
638
639 } elsif ( $entry->is_hardlink ) {
640 my $fail;
641 if( ON_UNIX ) {
642 link( $entry->linkname, $file ) or $fail++;
643
644 } else {
645 $self->_extract_special_file_as_plain_file( $entry, $file )
646 or $fail++;
647 }
648
649 $err = qq[Making hard link from '] . $entry->linkname .
650 qq[' to '$file' failed] if $fail;
651
652 } elsif ( $entry->is_fifo ) {
653 ON_UNIX && !system('mknod', $file, 'p') or
654 $err = qq[Making fifo ']. $entry->name .qq[' failed];
655
656 } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
657 my $mode = $entry->is_blockdev ? 'b' : 'c';
658
659 ON_UNIX && !system('mknod', $file, $mode,
660 $entry->devmajor, $entry->devminor) or
661 $err = qq[Making block device ']. $entry->name .qq[' (maj=] .
662 $entry->devmajor . qq[ min=] . $entry->devminor .
663 qq[) failed.];
664
665 } elsif ( $entry->is_socket ) {
666 ### the original doesn't do anything special for sockets.... ###
667 1;
668 }
669
670 return $err ? $self->_error( $err ) : 1;
671}
672
673### don't know how to make symlinks, let's just extract the file as
674### a plain file
675sub _extract_special_file_as_plain_file {
676 my $self = shift;
677 my $entry = shift or return;
678 my $file = shift; return unless defined $file;
679
680 my $err;
681 TRY: {
682 my $orig = $self->_find_entry( $entry->linkname );
683
684 unless( $orig ) {
685 $err = qq[Could not find file '] . $entry->linkname .
686 qq[' in memory.];
687 last TRY;
688 }
689
690 ### clone the entry, make it appear as a normal file ###
691 my $clone = $entry->clone;
692 $clone->_downgrade_to_plainfile;
693 $self->_extract_file( $clone, $file ) or last TRY;
694
695 return 1;
696 }
697
698 return $self->_error($err);
699}
700
701=head2 $tar->list_files( [\@properties] )
702
703Returns a list of the names of all the files in the archive.
704
705If C<list_files()> is passed an array reference as its first argument
706it returns a list of hash references containing the requested
707properties of each file. The following list of properties is
708supported: name, size, mtime (last modified date), mode, uid, gid,
709linkname, uname, gname, devmajor, devminor, prefix.
710
711Passing an array reference containing only one element, 'name', is
712special cased to return a list of names rather than a list of hash
713references, making it equivalent to calling C<list_files> without
714arguments.
715
716=cut
717
718sub list_files {
719 my $self = shift;
720 my $aref = shift || [ ];
721
722 unless( $self->_data ) {
723 $self->read() or return;
724 }
725
726 if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
727 return map { $_->full_path } @{$self->_data};
728 } else {
729
730 #my @rv;
731 #for my $obj ( @{$self->_data} ) {
732 # push @rv, { map { $_ => $obj->$_() } @$aref };
733 #}
734 #return @rv;
735
736 ### this does the same as the above.. just needs a +{ }
737 ### to make sure perl doesn't confuse it for a block
738 return map { my $o=$_;
739 +{ map { $_ => $o->$_() } @$aref }
740 } @{$self->_data};
741 }
742}
743
744sub _find_entry {
745 my $self = shift;
746 my $file = shift;
747
748 unless( defined $file ) {
749 $self->_error( qq[No file specified] );
750 return;
751 }
752
b30bcf62
RGS
753 ### it's an object already
754 return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
755
39713df4
RGS
756 for my $entry ( @{$self->_data} ) {
757 my $path = $entry->full_path;
758 return $entry if $path eq $file;
759 }
760
761 $self->_error( qq[No such file in archive: '$file'] );
762 return;
763}
764
765=head2 $tar->get_files( [@filenames] )
766
767Returns the C<Archive::Tar::File> objects matching the filenames
768provided. If no filename list was passed, all C<Archive::Tar::File>
769objects in the current Tar object are returned.
770
771Please refer to the C<Archive::Tar::File> documentation on how to
772handle these objects.
773
774=cut
775
776sub get_files {
777 my $self = shift;
778
779 return @{ $self->_data } unless @_;
780
781 my @list;
782 for my $file ( @_ ) {
783 push @list, grep { defined } $self->_find_entry( $file );
784 }
785
786 return @list;
787}
788
789=head2 $tar->get_content( $file )
790
791Return the content of the named file.
792
793=cut
794
795sub get_content {
796 my $self = shift;
797 my $entry = $self->_find_entry( shift ) or return;
798
799 return $entry->data;
800}
801
802=head2 $tar->replace_content( $file, $content )
803
804Make the string $content be the content for the file named $file.
805
806=cut
807
808sub replace_content {
809 my $self = shift;
810 my $entry = $self->_find_entry( shift ) or return;
811
812 return $entry->replace_content( shift );
813}
814
815=head2 $tar->rename( $file, $new_name )
816
817Rename the file of the in-memory archive to $new_name.
818
819Note that you must specify a Unix path for $new_name, since per tar
820standard, all files in the archive must be Unix paths.
821
822Returns true on success and false on failure.
823
824=cut
825
826sub rename {
827 my $self = shift;
828 my $file = shift; return unless defined $file;
829 my $new = shift; return unless defined $new;
830
831 my $entry = $self->_find_entry( $file ) or return;
832
833 return $entry->rename( $new );
834}
835
836=head2 $tar->remove (@filenamelist)
837
838Removes any entries with names matching any of the given filenames
839from the in-memory archive. Returns a list of C<Archive::Tar::File>
840objects that remain.
841
842=cut
843
844sub remove {
845 my $self = shift;
846 my @list = @_;
847
848 my %seen = map { $_->full_path => $_ } @{$self->_data};
849 delete $seen{ $_ } for @list;
850
851 $self->_data( [values %seen] );
852
853 return values %seen;
854}
855
856=head2 $tar->clear
857
858C<clear> clears the current in-memory archive. This effectively gives
859you a 'blank' object, ready to be filled again. Note that C<clear>
860only has effect on the object, not the underlying tarfile.
861
862=cut
863
864sub clear {
865 my $self = shift or return;
866
867 $self->_data( [] );
868 $self->_file( '' );
869
870 return 1;
871}
872
873
874=head2 $tar->write ( [$file, $compressed, $prefix] )
875
876Write the in-memory archive to disk. The first argument can either
877be the name of a file or a reference to an already open filehandle (a
878GLOB reference). If the second argument is true, the module will use
879IO::Zlib to write the file in a compressed format. If IO::Zlib is
880not available, the C<write> method will fail and return.
881
882Note that when you pass in a filehandle, the compression argument
883is ignored, as all files are printed verbatim to your filehandle.
884If you wish to enable compression with filehandles, use an
885C<IO::Zlib> filehandle instead.
886
887Specific levels of compression can be chosen by passing the values 2
888through 9 as the second parameter.
889
890The third argument is an optional prefix. All files will be tucked
891away in the directory you specify as prefix. So if you have files
892'a' and 'b' in your archive, and you specify 'foo' as prefix, they
893will be written to the archive as 'foo/a' and 'foo/b'.
894
895If no arguments are given, C<write> returns the entire formatted
896archive as a string, which could be useful if you'd like to stuff the
897archive into a socket or a pipe to gzip or something.
898
899=cut
900
901sub write {
902 my $self = shift;
903 my $file = shift; $file = '' unless defined $file;
904 my $gzip = shift || 0;
905 my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
906 my $dummy = '';
907
908 ### only need a handle if we have a file to print to ###
909 my $handle = length($file)
910 ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
911 or return )
912 : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h }
913 : $HAS_IO_STRING ? IO::String->new
914 : __PACKAGE__->no_string_support();
915
916
917
918 for my $entry ( @{$self->_data} ) {
919 ### entries to be written to the tarfile ###
920 my @write_me;
921
922 ### only now will we change the object to reflect the current state
923 ### of the name and prefix fields -- this needs to be limited to
924 ### write() only!
925 my $clone = $entry->clone;
926
927
928 ### so, if you don't want use to use the prefix, we'll stuff
929 ### everything in the name field instead
930 if( $DO_NOT_USE_PREFIX ) {
931
932 ### you might have an extended prefix, if so, set it in the clone
933 ### XXX is ::Unix right?
934 $clone->name( length $ext_prefix
935 ? File::Spec::Unix->catdir( $ext_prefix,
936 $clone->full_path)
937 : $clone->full_path );
938 $clone->prefix( '' );
939
940 ### otherwise, we'll have to set it properly -- prefix part in the
941 ### prefix and name part in the name field.
942 } else {
943
944 ### split them here, not before!
945 my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
946
947 ### you might have an extended prefix, if so, set it in the clone
948 ### XXX is ::Unix right?
949 $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
950 if length $ext_prefix;
951
952 $clone->prefix( $prefix );
953 $clone->name( $name );
954 }
955
956 ### names are too long, and will get truncated if we don't add a
957 ### '@LongLink' file...
958 my $make_longlink = ( length($clone->name) > NAME_LENGTH or
959 length($clone->prefix) > PREFIX_LENGTH
960 ) || 0;
961
962 ### perhaps we need to make a longlink file?
963 if( $make_longlink ) {
964 my $longlink = Archive::Tar::File->new(
965 data => LONGLINK_NAME,
966 $clone->full_path,
967 { type => LONGLINK }
968 );
969
970 unless( $longlink ) {
971 $self->_error( qq[Could not create 'LongLink' entry for ] .
972 qq[oversize file '] . $clone->full_path ."'" );
973 return;
974 };
975
976 push @write_me, $longlink;
977 }
978
979 push @write_me, $clone;
980
981 ### write the one, optionally 2 a::t::file objects to the handle
982 for my $clone (@write_me) {
983
984 ### if the file is a symlink, there are 2 options:
985 ### either we leave the symlink intact, but then we don't write any
986 ### data OR we follow the symlink, which means we actually make a
987 ### copy. if we do the latter, we have to change the TYPE of the
988 ### clone to 'FILE'
989 my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
990 my $data_ok = !$clone->is_symlink && $clone->has_content;
991
992 ### downgrade to a 'normal' file if it's a symlink we're going to
993 ### treat as a regular file
994 $clone->_downgrade_to_plainfile if $link_ok;
995
996 ### get the header for this block
997 my $header = $self->_format_tar_entry( $clone );
998 unless( $header ) {
999 $self->_error(q[Could not format header for: ] .
1000 $clone->full_path );
1001 return;
1002 }
1003
1004 unless( print $handle $header ) {
1005 $self->_error(q[Could not write header for: ] .
1006 $clone->full_path);
1007 return;
1008 }
1009
1010 if( $link_ok or $data_ok ) {
1011 unless( print $handle $clone->data ) {
1012 $self->_error(q[Could not write data for: ] .
1013 $clone->full_path);
1014 return;
1015 }
1016
1017 ### pad the end of the clone if required ###
1018 print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
1019 }
1020
1021 } ### done writing these entries
1022 }
1023
1024 ### write the end markers ###
1025 print $handle TAR_END x 2 or
1026 return $self->_error( qq[Could not write tar end markers] );
b30bcf62 1027
39713df4 1028 ### did you want it written to a file, or returned as a string? ###
b30bcf62 1029 my $rv = length($file) ? 1
39713df4 1030 : $HAS_PERLIO ? $dummy
b30bcf62
RGS
1031 : do { seek $handle, 0, 0; local $/; <$handle> };
1032
1033 ### make sure to close the handle;
1034 close $handle;
1035
1036 return $rv;
39713df4
RGS
1037}
1038
1039sub _format_tar_entry {
1040 my $self = shift;
1041 my $entry = shift or return;
1042 my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix;
1043 my $no_prefix = shift || 0;
1044
1045 my $file = $entry->name;
1046 my $prefix = $entry->prefix; $prefix = '' unless defined $prefix;
1047
1048 ### remove the prefix from the file name
1049 ### not sure if this is still neeeded --kane
1050 ### no it's not -- Archive::Tar::File->_new_from_file will take care of
1051 ### this for us. Even worse, this would break if we tried to add a file
1052 ### like x/x.
1053 #if( length $prefix ) {
1054 # $file =~ s/^$match//;
1055 #}
1056
1057 $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
1058 if length $ext_prefix;
1059
1060 ### not sure why this is... ###
1061 my $l = PREFIX_LENGTH; # is ambiguous otherwise...
1062 substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
1063
1064 my $f1 = "%06o"; my $f2 = "%11o";
1065
1066 ### this might be optimizable with a 'changed' flag in the file objects ###
1067 my $tar = pack (
1068 PACK,
1069 $file,
1070
1071 (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
1072 (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
1073
1074 "", # checksum field - space padded a bit down
1075
1076 (map { $entry->$_() } qw[type linkname magic]),
1077
1078 $entry->version || TAR_VERSION,
1079
1080 (map { $entry->$_() } qw[uname gname]),
1081 (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
1082
1083 ($no_prefix ? '' : $prefix)
1084 );
1085
1086 ### add the checksum ###
1087 substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
1088
1089 return $tar;
1090}
1091
1092=head2 $tar->add_files( @filenamelist )
1093
1094Takes a list of filenames and adds them to the in-memory archive.
1095
1096The path to the file is automatically converted to a Unix like
1097equivalent for use in the archive, and, if on MacOS, the file's
1098modification time is converted from the MacOS epoch to the Unix epoch.
1099So tar archives created on MacOS with B<Archive::Tar> can be read
1100both with I<tar> on Unix and applications like I<suntar> or
1101I<Stuffit Expander> on MacOS.
1102
1103Be aware that the file's type/creator and resource fork will be lost,
1104which is usually what you want in cross-platform archives.
1105
1106Returns a list of C<Archive::Tar::File> objects that were just added.
1107
1108=cut
1109
1110sub add_files {
1111 my $self = shift;
1112 my @files = @_ or return;
1113
1114 my @rv;
1115 for my $file ( @files ) {
1116 unless( -e $file ) {
1117 $self->_error( qq[No such file: '$file'] );
1118 next;
1119 }
1120
1121 my $obj = Archive::Tar::File->new( file => $file );
1122 unless( $obj ) {
1123 $self->_error( qq[Unable to add file: '$file'] );
1124 next;
1125 }
1126
1127 push @rv, $obj;
1128 }
1129
1130 push @{$self->{_data}}, @rv;
1131
1132 return @rv;
1133}
1134
1135=head2 $tar->add_data ( $filename, $data, [$opthashref] )
1136
1137Takes a filename, a scalar full of data and optionally a reference to
1138a hash with specific options.
1139
1140Will add a file to the in-memory archive, with name C<$filename> and
1141content C<$data>. Specific properties can be set using C<$opthashref>.
1142The following list of properties is supported: name, size, mtime
1143(last modified date), mode, uid, gid, linkname, uname, gname,
b3200c5d 1144devmajor, devminor, prefix, type. (On MacOS, the file's path and
39713df4
RGS
1145modification times are converted to Unix equivalents.)
1146
b3200c5d
SP
1147Valid values for the file type are the following constants defined in
1148Archive::Tar::Constants:
1149
1150=over 4
1151
1152=item FILE
1153
1154Regular file.
1155
1156=item HARDLINK
1157
1158=item SYMLINK
1159
1160Hard and symbolic ("soft") links; linkname should specify target.
1161
1162=item CHARDEV
1163
1164=item BLOCKDEV
1165
1166Character and block devices. devmajor and devminor should specify the major
1167and minor device numbers.
1168
1169=item DIR
1170
1171Directory.
1172
1173=item FIFO
1174
1175FIFO (named pipe).
1176
1177=item SOCKET
1178
1179Socket.
1180
1181=back
1182
39713df4
RGS
1183Returns the C<Archive::Tar::File> object that was just added, or
1184C<undef> on failure.
1185
1186=cut
1187
1188sub add_data {
1189 my $self = shift;
1190 my ($file, $data, $opt) = @_;
1191
1192 my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
1193 unless( $obj ) {
1194 $self->_error( qq[Unable to add file: '$file'] );
1195 return;
1196 }
1197
1198 push @{$self->{_data}}, $obj;
1199
1200 return $obj;
1201}
1202
1203=head2 $tar->error( [$BOOL] )
1204
1205Returns the current errorstring (usually, the last error reported).
1206If a true value was specified, it will give the C<Carp::longmess>
1207equivalent of the error, in effect giving you a stacktrace.
1208
1209For backwards compatibility, this error is also available as
1210C<$Archive::Tar::error> although it is much recommended you use the
1211method call instead.
1212
1213=cut
1214
1215{
1216 $error = '';
1217 my $longmess;
1218
1219 sub _error {
1220 my $self = shift;
1221 my $msg = $error = shift;
1222 $longmess = Carp::longmess($error);
1223
1224 ### set Archive::Tar::WARN to 0 to disable printing
1225 ### of errors
1226 if( $WARN ) {
1227 carp $DEBUG ? $longmess : $msg;
1228 }
1229
1230 return;
1231 }
1232
1233 sub error {
1234 my $self = shift;
1235 return shift() ? $longmess : $error;
1236 }
1237}
1238
1239
1240=head2 $bool = $tar->has_io_string
1241
1242Returns true if we currently have C<IO::String> support loaded.
1243
1244Either C<IO::String> or C<perlio> support is needed to support writing
3c4b39be 1245stringified archives. Currently, C<perlio> is the preferred method, if
39713df4
RGS
1246available.
1247
1248See the C<GLOBAL VARIABLES> section to see how to change this preference.
1249
1250=cut
1251
1252sub has_io_string { return $HAS_IO_STRING; }
1253
1254=head2 $bool = $tar->has_perlio
1255
1256Returns true if we currently have C<perlio> support loaded.
1257
1258This requires C<perl-5.8> or higher, compiled with C<perlio>
1259
1260Either C<IO::String> or C<perlio> support is needed to support writing
3c4b39be 1261stringified archives. Currently, C<perlio> is the preferred method, if
39713df4
RGS
1262available.
1263
1264See the C<GLOBAL VARIABLES> section to see how to change this preference.
1265
1266=cut
1267
1268sub has_perlio { return $HAS_PERLIO; }
1269
1270
1271=head1 Class Methods
1272
1273=head2 Archive::Tar->create_archive($file, $compression, @filelist)
1274
1275Creates a tar file from the list of files provided. The first
1276argument can either be the name of the tar file to create or a
1277reference to an open file handle (e.g. a GLOB reference).
1278
1279The second argument specifies the level of compression to be used, if
1280any. Compression of tar files requires the installation of the
1281IO::Zlib module. Specific levels of compression may be
1282requested by passing a value between 2 and 9 as the second argument.
1283Any other value evaluating as true will result in the default
1284compression level being used.
1285
1286Note that when you pass in a filehandle, the compression argument
1287is ignored, as all files are printed verbatim to your filehandle.
1288If you wish to enable compression with filehandles, use an
1289C<IO::Zlib> filehandle instead.
1290
1291The remaining arguments list the files to be included in the tar file.
1292These files must all exist. Any files which don't exist or can't be
1293read are silently ignored.
1294
1295If the archive creation fails for any reason, C<create_archive> will
1296return false. Please use the C<error> method to find the cause of the
1297failure.
1298
1299Note that this method does not write C<on the fly> as it were; it
1300still reads all the files into memory before writing out the archive.
1301Consult the FAQ below if this is a problem.
1302
1303=cut
1304
1305sub create_archive {
1306 my $class = shift;
1307
1308 my $file = shift; return unless defined $file;
1309 my $gzip = shift || 0;
1310 my @files = @_;
1311
1312 unless( @files ) {
1313 return $class->_error( qq[Cowardly refusing to create empty archive!] );
1314 }
1315
1316 my $tar = $class->new;
1317 $tar->add_files( @files );
1318 return $tar->write( $file, $gzip );
1319}
1320
1321=head2 Archive::Tar->list_archive ($file, $compressed, [\@properties])
1322
1323Returns a list of the names of all the files in the archive. The
1324first argument can either be the name of the tar file to list or a
1325reference to an open file handle (e.g. a GLOB reference).
1326
1327If C<list_archive()> is passed an array reference as its third
1328argument it returns a list of hash references containing the requested
1329properties of each file. The following list of properties is
b3200c5d
SP
1330supported: full_path, name, size, mtime (last modified date), mode,
1331uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
1332
1333See C<Archive::Tar::File> for details about supported properties.
39713df4
RGS
1334
1335Passing an array reference containing only one element, 'name', is
1336special cased to return a list of names rather than a list of hash
1337references.
1338
1339=cut
1340
1341sub list_archive {
1342 my $class = shift;
1343 my $file = shift; return unless defined $file;
1344 my $gzip = shift || 0;
1345
1346 my $tar = $class->new($file, $gzip);
1347 return unless $tar;
1348
1349 return $tar->list_files( @_ );
1350}
1351
1352=head2 Archive::Tar->extract_archive ($file, $gzip)
1353
1354Extracts the contents of the tar file. The first argument can either
1355be the name of the tar file to create or a reference to an open file
1356handle (e.g. a GLOB reference). All relative paths in the tar file will
1357be created underneath the current working directory.
1358
1359C<extract_archive> will return a list of files it extracted.
1360If the archive extraction fails for any reason, C<extract_archive>
1361will return false. Please use the C<error> method to find the cause
1362of the failure.
1363
1364=cut
1365
1366sub extract_archive {
1367 my $class = shift;
1368 my $file = shift; return unless defined $file;
1369 my $gzip = shift || 0;
1370
1371 my $tar = $class->new( ) or return;
1372
1373 return $tar->read( $file, $gzip, { extract => 1 } );
1374}
1375
1376=head2 Archive::Tar->can_handle_compressed_files
1377
1378A simple checking routine, which will return true if C<Archive::Tar>
1379is able to uncompress compressed archives on the fly with C<IO::Zlib>,
1380or false if C<IO::Zlib> is not installed.
1381
1382You can use this as a shortcut to determine whether C<Archive::Tar>
1383will do what you think before passing compressed archives to its
1384C<read> method.
1385
1386=cut
1387
1388sub can_handle_compressed_files { return ZLIB ? 1 : 0 }
1389
1390sub no_string_support {
1391 croak("You have to install IO::String to support writing archives to strings");
1392}
1393
13941;
1395
1396__END__
1397
1398=head1 GLOBAL VARIABLES
1399
1400=head2 $Archive::Tar::FOLLOW_SYMLINK
1401
1402Set this variable to C<1> to make C<Archive::Tar> effectively make a
1403copy of the file when extracting. Default is C<0>, which
1404means the symlink stays intact. Of course, you will have to pack the
1405file linked to as well.
1406
1407This option is checked when you write out the tarfile using C<write>
1408or C<create_archive>.
1409
1410This works just like C</bin/tar>'s C<-h> option.
1411
1412=head2 $Archive::Tar::CHOWN
1413
1414By default, C<Archive::Tar> will try to C<chown> your files if it is
1415able to. In some cases, this may not be desired. In that case, set
1416this variable to C<0> to disable C<chown>-ing, even if it were
1417possible.
1418
1419The default is C<1>.
1420
1421=head2 $Archive::Tar::CHMOD
1422
1423By default, C<Archive::Tar> will try to C<chmod> your files to
1424whatever mode was specified for the particular file in the archive.
1425In some cases, this may not be desired. In that case, set this
1426variable to C<0> to disable C<chmod>-ing.
1427
1428The default is C<1>.
1429
1430=head2 $Archive::Tar::DO_NOT_USE_PREFIX
1431
1432By default, C<Archive::Tar> will try to put paths that are over
1433100 characters in the C<prefix> field of your tar header. However,
1434some older tar programs do not implement this spec. To retain
1435compatibility with these older versions, you can set the
1436C<$DO_NOT_USE_PREFIX> variable to a true value, and C<Archive::Tar>
1437will use an alternate way of dealing with paths over 100 characters
1438by using the C<GNU Extended Header> feature.
1439
1440The default is C<0>.
1441
1442=head2 $Archive::Tar::DEBUG
1443
1444Set this variable to C<1> to always get the C<Carp::longmess> output
1445of the warnings, instead of the regular C<carp>. This is the same
1446message you would get by doing:
1447
1448 $tar->error(1);
1449
1450Defaults to C<0>.
1451
1452=head2 $Archive::Tar::WARN
1453
1454Set this variable to C<0> if you do not want any warnings printed.
1455Personally I recommend against doing this, but people asked for the
1456option. Also, be advised that this is of course not threadsafe.
1457
1458Defaults to C<1>.
1459
1460=head2 $Archive::Tar::error
1461
1462Holds the last reported error. Kept for historical reasons, but its
1463use is very much discouraged. Use the C<error()> method instead:
1464
1465 warn $tar->error unless $tar->extract;
1466
1467=head2 $Archive::Tar::HAS_PERLIO
1468
1469This variable holds a boolean indicating if we currently have
1470C<perlio> support loaded. This will be enabled for any perl
1471greater than C<5.8> compiled with C<perlio>.
1472
1473If you feel strongly about disabling it, set this variable to
1474C<false>. Note that you will then need C<IO::String> installed
1475to support writing stringified archives.
1476
1477Don't change this variable unless you B<really> know what you're
1478doing.
1479
1480=head2 $Archive::Tar::HAS_IO_STRING
1481
1482This variable holds a boolean indicating if we currently have
1483C<IO::String> support loaded. This will be enabled for any perl
1484that has a loadable C<IO::String> module.
1485
1486If you feel strongly about disabling it, set this variable to
1487C<false>. Note that you will then need C<perlio> support from
1488your perl to be able to write stringified archives.
1489
1490Don't change this variable unless you B<really> know what you're
1491doing.
1492
1493=head1 FAQ
1494
1495=over 4
1496
1497=item What's the minimum perl version required to run Archive::Tar?
1498
1499You will need perl version 5.005_03 or newer.
1500
1501=item Isn't Archive::Tar slow?
1502
1503Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar>
1504However, it's very portable. If speed is an issue, consider using
1505C</bin/tar> instead.
1506
1507=item Isn't Archive::Tar heavier on memory than /bin/tar?
1508
1509Yes it is, see previous answer. Since C<Compress::Zlib> and therefore
1510C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
1511choice but to read the archive into memory.
1512This is ok if you want to do in-memory manipulation of the archive.
1513If you just want to extract, use the C<extract_archive> class method
1514instead. It will optimize and write to disk immediately.
1515
1516=item Can't you lazy-load data instead?
1517
1518No, not easily. See previous question.
1519
1520=item How much memory will an X kb tar file need?
1521
1522Probably more than X kb, since it will all be read into memory. If
1523this is a problem, and you don't need to do in memory manipulation
1524of the archive, consider using C</bin/tar> instead.
1525
1526=item What do you do with unsupported filetypes in an archive?
1527
1528C<Unix> has a few filetypes that aren't supported on other platforms,
1529like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just
1530try to make a copy of the original file, rather than throwing an error.
1531
1532This does require you to read the entire archive in to memory first,
1533since otherwise we wouldn't know what data to fill the copy with.
1534(This means that you cannot use the class methods on archives that
1535have incompatible filetypes and still expect things to work).
1536
1537For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
1538the extraction of this particular item didn't work.
1539
b30bcf62
RGS
1540=item How do I extract only files that have property X from an archive?
1541
1542Sometimes, you might not wish to extract a complete archive, just
1543the files that are relevant to you, based on some criteria.
1544
1545You can do this by filtering a list of C<Archive::Tar::File> objects
1546based on your criteria. For example, to extract only files that have
1547the string C<foo> in their title, you would use:
1548
1549 $tar->extract(
1550 grep { $_->full_path =~ /foo/ } $tar->get_files
1551 );
1552
1553This way, you can filter on any attribute of the files in the archive.
1554Consult the C<Archive::Tar::File> documentation on how to use these
1555objects.
1556
81a5970e
RGS
1557=item How do I access .tar.Z files?
1558
1559The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
1560the C<IO::Zlib> module) to access tar files that have been compressed
1561with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
1562utility cannot be read by C<Compress::Zlib> and so cannot be directly
1563accesses by C<Archive::Tar>.
1564
1565If the C<uncompress> or C<gunzip> programs are available, you can use
1566one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
1567
1568Firstly with C<uncompress>
1569
1570 use Archive::Tar;
1571
1572 open F, "uncompress -c $filename |";
1573 my $tar = Archive::Tar->new(*F);
1574 ...
1575
1576and this with C<gunzip>
1577
1578 use Archive::Tar;
1579
1580 open F, "gunzip -c $filename |";
1581 my $tar = Archive::Tar->new(*F);
1582 ...
1583
1584Similarly, if the C<compress> program is available, you can use this to
1585write a C<.tar.Z> file
1586
1587 use Archive::Tar;
1588 use IO::File;
1589
1590 my $fh = new IO::File "| compress -c >$filename";
1591 my $tar = Archive::Tar->new();
1592 ...
1593 $tar->write($fh);
1594 $fh->close ;
1595
1596
39713df4
RGS
1597=back
1598
1599=head1 TODO
1600
1601=over 4
1602
1603=item Check if passed in handles are open for read/write
1604
1605Currently I don't know of any portable pure perl way to do this.
1606Suggestions welcome.
1607
b3200c5d
SP
1608=item Allow archives to be passed in as string
1609
1610Currently, we only allow opened filehandles or filenames, but
1611not strings. The internals would need some reworking to facilitate
1612stringified archives.
1613
1614=item Facilitate processing an opened filehandle of a compressed archive
1615
1616Currently, we only support this if the filehandle is an IO::Zlib object.
1617Environments, like apache, will present you with an opened filehandle
1618to an uploaded file, which might be a compressed archive.
1619
39713df4
RGS
1620=back
1621
1622=head1 AUTHOR
1623
1624This module by
1625Jos Boumans E<lt>kane@cpan.orgE<gt>.
1626
1627=head1 ACKNOWLEDGEMENTS
1628
1629Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney and
1630especially Andrew Savige for their help and suggestions.
1631
1632=head1 COPYRIGHT
1633
1634This module is
1635copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>.
1636All rights reserved.
1637
1638This library is free software;
1639you may redistribute and/or modify it under the same
1640terms as Perl itself.
1641
1642=cut