Update Archive::Tar to 1.52
[perl.git] / lib / Archive / Tar.pm
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 use Cwd;
11 use IO::Zlib;
12 use IO::File;
13 use Carp                qw(carp croak);
14 use File::Spec          ();
15 use File::Spec::Unix    ();
16 use File::Path          ();
17
18 use Archive::Tar::File;
19 use Archive::Tar::Constant;
20
21 require Exporter;
22
23 use strict;
24 use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
25             $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS
26             $INSECURE_EXTRACT_MODE @ISA @EXPORT
27          ];
28
29 @ISA                    = qw[Exporter];
30 @EXPORT                 = qw[ COMPRESS_GZIP COMPRESS_BZIP ];
31 $DEBUG                  = 0;
32 $WARN                   = 1;
33 $FOLLOW_SYMLINK         = 0;
34 $VERSION                = "1.52";
35 $CHOWN                  = 1;
36 $CHMOD                  = 1;
37 $SAME_PERMISSIONS       = $> == 0 ? 1 : 0;
38 $DO_NOT_USE_PREFIX      = 0;
39 $INSECURE_EXTRACT_MODE  = 0;
40
41 BEGIN {
42     use Config;
43     $HAS_PERLIO = $Config::Config{useperlio};
44
45     ### try and load IO::String anyway, so you can dynamically
46     ### switch between perlio and IO::String
47     $HAS_IO_STRING = eval {
48         require IO::String;
49         import IO::String;
50         1;
51     } || 0;
52 }
53
54 =head1 NAME
55
56 Archive::Tar - module for manipulations of tar archives
57
58 =head1 SYNOPSIS
59
60     use Archive::Tar;
61     my $tar = Archive::Tar->new;
62
63     $tar->read('origin.tgz');
64     $tar->extract();
65
66     $tar->add_files('file/foo.pl', 'docs/README');
67     $tar->add_data('file/baz.txt', 'This is the contents now');
68
69     $tar->rename('oldname', 'new/file/name');
70
71     $tar->write('files.tar');                   # plain tar
72     $tar->write('files.tgz', COMPRESS_GZIP);    # gzip compressed
73     $tar->write('files.tbz', COMPRESS_BZIP);    # bzip2 compressed
74
75 =head1 DESCRIPTION
76
77 Archive::Tar provides an object oriented mechanism for handling tar
78 files.  It provides class methods for quick and easy files handling
79 while also allowing for the creation of tar file objects for custom
80 manipulation.  If you have the IO::Zlib module installed,
81 Archive::Tar will also support compressed or gzipped tar files.
82
83 An object of class Archive::Tar represents a .tar(.gz) archive full
84 of files and things.
85
86 =head1 Object Methods
87
88 =head2 Archive::Tar->new( [$file, $compressed] )
89
90 Returns a new Tar object. If given any arguments, C<new()> calls the
91 C<read()> method automatically, passing on the arguments provided to
92 the C<read()> method.
93
94 If C<new()> is invoked with arguments and the C<read()> method fails
95 for any reason, C<new()> returns undef.
96
97 =cut
98
99 my $tmpl = {
100     _data   => [ ],
101     _file   => 'Unknown',
102 };
103
104 ### install get/set accessors for this object.
105 for my $key ( keys %$tmpl ) {
106     no strict 'refs';
107     *{__PACKAGE__."::$key"} = sub {
108         my $self = shift;
109         $self->{$key} = $_[0] if @_;
110         return $self->{$key};
111     }
112 }
113
114 sub new {
115     my $class = shift;
116     $class = ref $class if ref $class;
117
118     ### copying $tmpl here since a shallow copy makes it use the
119     ### same aref, causing for files to remain in memory always.
120     my $obj = bless { _data => [ ], _file => 'Unknown' }, $class;
121
122     if (@_) {
123         unless ( $obj->read( @_ ) ) {
124             $obj->_error(qq[No data could be read from file]);
125             return;
126         }
127     }
128
129     return $obj;
130 }
131
132 =head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] )
133
134 Read the given tar file into memory.
135 The first argument can either be the name of a file or a reference to
136 an already open filehandle (or an IO::Zlib object if it's compressed)
137
138 The C<read> will I<replace> any previous content in C<$tar>!
139
140 The second argument may be considered optional, but remains for
141 backwards compatibility. Archive::Tar now looks at the file
142 magic to determine what class should be used to open the file
143 and will transparently Do The Right Thing.
144
145 Archive::Tar will warn if you try to pass a bzip2 compressed file and the
146 IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return.
147
148 Note that you can currently B<not> pass a C<gzip> compressed
149 filehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed
150 filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string
151 containing the full archive information (either compressed or
152 uncompressed). These are worth while features, but not currently
153 implemented. See the C<TODO> section.
154
155 The third argument can be a hash reference with options. Note that
156 all options are case-sensitive.
157
158 =over 4
159
160 =item limit
161
162 Do not read more than C<limit> files. This is useful if you have
163 very big archives, and are only interested in the first few files.
164
165 =item filter
166
167 Can be set to a regular expression.  Only files with names that match
168 the expression will be read.
169
170 =item extract
171
172 If set to true, immediately extract entries when reading them. This
173 gives you the same memory break as the C<extract_archive> function.
174 Note however that entries will not be read into memory, but written
175 straight to disk. This means no C<Archive::Tar::File> objects are
176 created for you to inspect.
177
178 =back
179
180 All files are stored internally as C<Archive::Tar::File> objects.
181 Please consult the L<Archive::Tar::File> documentation for details.
182
183 Returns the number of files read in scalar context, and a list of
184 C<Archive::Tar::File> objects in list context.
185
186 =cut
187
188 sub read {
189     my $self = shift;
190     my $file = shift;
191     my $gzip = shift || 0;
192     my $opts = shift || {};
193
194     unless( defined $file ) {
195         $self->_error( qq[No file to read from!] );
196         return;
197     } else {
198         $self->_file( $file );
199     }
200
201     my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) )
202                     or return;
203
204     my $data = $self->_read_tar( $handle, $opts ) or return;
205
206     $self->_data( $data );
207
208     return wantarray ? @$data : scalar @$data;
209 }
210
211 sub _get_handle {
212     my $self     = shift;
213     my $file     = shift;   return unless defined $file;
214                             return $file if ref $file;
215     my $compress = shift || 0;
216     my $mode     = shift || READ_ONLY->( ZLIB ); # default to read only
217
218
219     ### get a FH opened to the right class, so we can use it transparently
220     ### throughout the program
221     my $fh;
222     {   ### reading magic only makes sense if we're opening a file for
223         ### reading. otherwise, just use what the user requested.
224         my $magic = '';
225         if( MODE_READ->($mode) ) {
226             open my $tmp, $file or do {
227                 $self->_error( qq[Could not open '$file' for reading: $!] );
228                 return;
229             };
230
231             ### read the first 4 bites of the file to figure out which class to
232             ### use to open the file.
233             sysread( $tmp, $magic, 4 );
234             close $tmp;
235         }
236
237         ### is it bzip?
238         ### if you asked specifically for bzip compression, or if we're in
239         ### read mode and the magic numbers add up, use bzip
240         if( BZIP and (
241                 ($compress eq COMPRESS_BZIP) or
242                 ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM )
243             )
244         ) {
245
246             ### different reader/writer modules, different error vars... sigh
247             if( MODE_READ->($mode) ) {
248                 $fh = IO::Uncompress::Bunzip2->new( $file ) or do {
249                     $self->_error( qq[Could not read '$file': ] .
250                         $IO::Uncompress::Bunzip2::Bunzip2Error
251                     );
252                     return;
253                 };
254
255             } else {
256                 $fh = IO::Compress::Bzip2->new( $file ) or do {
257                     $self->_error( qq[Could not write to '$file': ] .
258                         $IO::Compress::Bzip2::Bzip2Error
259                     );
260                     return;
261                 };
262             }
263
264         ### is it gzip?
265         ### if you asked for compression, if you wanted to read or the gzip
266         ### magic number is present (redundant with read)
267         } elsif( ZLIB and (
268                     $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM
269                  )
270         ) {
271             $fh = IO::Zlib->new;
272
273             unless( $fh->open( $file, $mode ) ) {
274                 $self->_error(qq[Could not create filehandle for '$file': $!]);
275                 return;
276             }
277
278         ### is it plain tar?
279         } else {
280             $fh = IO::File->new;
281
282             unless( $fh->open( $file, $mode ) ) {
283                 $self->_error(qq[Could not create filehandle for '$file': $!]);
284                 return;
285             }
286
287             ### enable bin mode on tar archives
288             binmode $fh;
289         }
290     }
291
292     return $fh;
293 }
294
295
296 sub _read_tar {
297     my $self    = shift;
298     my $handle  = shift or return;
299     my $opts    = shift || {};
300
301     my $count   = $opts->{limit}    || 0;
302     my $filter  = $opts->{filter};
303     my $extract = $opts->{extract}  || 0;
304
305     ### set a cap on the amount of files to extract ###
306     my $limit   = 0;
307     $limit = 1 if $count > 0;
308
309     my $tarfile = [ ];
310     my $chunk;
311     my $read = 0;
312     my $real_name;  # to set the name of a file when
313                     # we're encountering @longlink
314     my $data;
315
316     LOOP:
317     while( $handle->read( $chunk, HEAD ) ) {
318         ### IO::Zlib doesn't support this yet
319         my $offset = eval { tell $handle } || 'unknown';
320
321         unless( $read++ ) {
322             my $gzip = GZIP_MAGIC_NUM;
323             if( $chunk =~ /$gzip/ ) {
324                 $self->_error( qq[Cannot read compressed format in tar-mode] );
325                 return;
326             }
327             
328             ### size is < HEAD, which means a corrupted file, as the minimum
329             ### length is _at least_ HEAD
330             if (length $chunk != HEAD) {
331                 $self->_error( qq[Cannot read enough bytes from the tarfile] );
332                 return;
333             }
334         }
335
336         ### if we can't read in all bytes... ###
337         last if length $chunk != HEAD;
338
339         ### Apparently this should really be two blocks of 512 zeroes,
340         ### but GNU tar sometimes gets it wrong. See comment in the
341         ### source code (tar.c) to GNU cpio.
342         next if $chunk eq TAR_END;
343
344         ### according to the posix spec, the last 12 bytes of the header are
345         ### null bytes, to pad it to a 512 byte block. That means if these
346         ### bytes are NOT null bytes, it's a corrrupt header. See:
347         ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx
348         ### line 111
349         {   my $nulls = join '', "\0" x 12;
350             unless( $nulls eq substr( $chunk, 500, 12 ) ) {
351                 $self->_error( qq[Invalid header block at offset $offset] );
352                 next LOOP;
353             }
354         }
355
356         ### pass the realname, so we can set it 'proper' right away
357         ### some of the heuristics are done on the name, so important
358         ### to set it ASAP
359         my $entry;
360         {   my %extra_args = ();
361             $extra_args{'name'} = $$real_name if defined $real_name;
362
363             unless( $entry = Archive::Tar::File->new(   chunk => $chunk,
364                                                         %extra_args )
365             ) {
366                 $self->_error( qq[Couldn't read chunk at offset $offset] );
367                 next LOOP;
368             }
369         }
370
371         ### ignore labels:
372         ### http://www.gnu.org/manual/tar/html_node/tar_139.html
373         next if $entry->is_label;
374
375         if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) {
376
377             if ( $entry->is_file && !$entry->validate ) {
378                 ### sometimes the chunk is rather fux0r3d and a whole 512
379                 ### bytes ends up in the ->name area.
380                 ### clean it up, if need be
381                 my $name = $entry->name;
382                 $name = substr($name, 0, 100) if length $name > 100;
383                 $name =~ s/\n/ /g;
384
385                 $self->_error( $name . qq[: checksum error] );
386                 next LOOP;
387             }
388
389             my $block = BLOCK_SIZE->( $entry->size );
390
391             $data = $entry->get_content_by_ref;
392
393             ### just read everything into memory
394             ### can't do lazy loading since IO::Zlib doesn't support 'seek'
395             ### this is because Compress::Zlib doesn't support it =/
396             ### this reads in the whole data in one read() call.
397             if( $handle->read( $$data, $block ) < $block ) {
398                 $self->_error( qq[Read error on tarfile (missing data) '].
399                                     $entry->full_path ."' at offset $offset" );
400                 next LOOP;
401             }
402
403             ### throw away trailing garbage ###
404             substr ($$data, $entry->size) = "" if defined $$data;
405
406             ### part II of the @LongLink munging -- need to do /after/
407             ### the checksum check.
408             if( $entry->is_longlink ) {
409                 ### weird thing in tarfiles -- if the file is actually a
410                 ### @LongLink, the data part seems to have a trailing ^@
411                 ### (unprintable) char. to display, pipe output through less.
412                 ### but that doesn't *always* happen.. so check if the last
413                 ### character is a control character, and if so remove it
414                 ### at any rate, we better remove that character here, or tests
415                 ### like 'eq' and hashlook ups based on names will SO not work
416                 ### remove it by calculating the proper size, and then
417                 ### tossing out everything that's longer than that size.
418
419                 ### count number of nulls
420                 my $nulls = $$data =~ tr/\0/\0/;
421
422                 ### cut data + size by that many bytes
423                 $entry->size( $entry->size - $nulls );
424                 substr ($$data, $entry->size) = "";
425             }
426         }
427
428         ### clean up of the entries.. posix tar /apparently/ has some
429         ### weird 'feature' that allows for filenames > 255 characters
430         ### they'll put a header in with as name '././@LongLink' and the
431         ### contents will be the name of the /next/ file in the archive
432         ### pretty crappy and kludgy if you ask me
433
434         ### set the name for the next entry if this is a @LongLink;
435         ### this is one ugly hack =/ but needed for direct extraction
436         if( $entry->is_longlink ) {
437             $real_name = $data;
438             next LOOP;
439         } elsif ( defined $real_name ) {
440             $entry->name( $$real_name );
441             $entry->prefix('');
442             undef $real_name;
443         }
444
445         ### skip this entry if we're filtering
446         if ($filter && $entry->name !~ $filter) {
447             next LOOP;
448
449         ### skip this entry if it's a pax header. This is a special file added
450         ### by, among others, git-generated tarballs. It holds comments and is
451         ### not meant for extracting. See #38932: pax_global_header extracted
452         } elsif ( $entry->name eq PAX_HEADER ) {
453             next LOOP;
454         }
455
456         $self->_extract_file( $entry ) if $extract
457                                             && !$entry->is_longlink
458                                             && !$entry->is_unknown
459                                             && !$entry->is_label;
460
461         ### Guard against tarfiles with garbage at the end
462             last LOOP if $entry->name eq '';
463
464         ### push only the name on the rv if we're extracting
465         ### -- for extract_archive
466         push @$tarfile, ($extract ? $entry->name : $entry);
467
468         if( $limit ) {
469             $count-- unless $entry->is_longlink || $entry->is_dir;
470             last LOOP unless $count;
471         }
472     } continue {
473         undef $data;
474     }
475
476     return $tarfile;
477 }
478
479 =head2 $tar->contains_file( $filename )
480
481 Check if the archive contains a certain file.
482 It will return true if the file is in the archive, false otherwise.
483
484 Note however, that this function does an exact match using C<eq>
485 on the full path. So it cannot compensate for case-insensitive file-
486 systems or compare 2 paths to see if they would point to the same
487 underlying file.
488
489 =cut
490
491 sub contains_file {
492     my $self = shift;
493     my $full = shift;
494
495     return unless defined $full;
496
497     ### don't warn if the entry isn't there.. that's what this function
498     ### is for after all.
499     local $WARN = 0;
500     return 1 if $self->_find_entry($full);
501     return;
502 }
503
504 =head2 $tar->extract( [@filenames] )
505
506 Write files whose names are equivalent to any of the names in
507 C<@filenames> to disk, creating subdirectories as necessary. This
508 might not work too well under VMS.
509 Under MacPerl, the file's modification time will be converted to the
510 MacOS zero of time, and appropriate conversions will be done to the
511 path.  However, the length of each element of the path is not
512 inspected to see whether it's longer than MacOS currently allows (32
513 characters).
514
515 If C<extract> is called without a list of file names, the entire
516 contents of the archive are extracted.
517
518 Returns a list of filenames extracted.
519
520 =cut
521
522 sub extract {
523     my $self    = shift;
524     my @args    = @_;
525     my @files;
526
527     # use the speed optimization for all extracted files
528     local($self->{cwd}) = cwd() unless $self->{cwd};
529
530     ### you requested the extraction of only certian files
531     if( @args ) {
532         for my $file ( @args ) {
533
534             ### it's already an object?
535             if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
536                 push @files, $file;
537                 next;
538
539             ### go find it then
540             } else {
541
542                 my $found;
543                 for my $entry ( @{$self->_data} ) {
544                     next unless $file eq $entry->full_path;
545
546                     ### we found the file you're looking for
547                     push @files, $entry;
548                     $found++;
549                 }
550
551                 unless( $found ) {
552                     return $self->_error(
553                         qq[Could not find '$file' in archive] );
554                 }
555             }
556         }
557
558     ### just grab all the file items
559     } else {
560         @files = $self->get_files;
561     }
562
563     ### nothing found? that's an error
564     unless( scalar @files ) {
565         $self->_error( qq[No files found for ] . $self->_file );
566         return;
567     }
568
569     ### now extract them
570     for my $entry ( @files ) {
571         unless( $self->_extract_file( $entry ) ) {
572             $self->_error(q[Could not extract ']. $entry->full_path .q['] );
573             return;
574         }
575     }
576
577     return @files;
578 }
579
580 =head2 $tar->extract_file( $file, [$extract_path] )
581
582 Write an entry, whose name is equivalent to the file name provided to
583 disk. Optionally takes a second parameter, which is the full native
584 path (including filename) the entry will be written to.
585
586 For example:
587
588     $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
589
590     $tar->extract_file( $at_file_object,   'name/i/want/to/give/it' );
591
592 Returns true on success, false on failure.
593
594 =cut
595
596 sub extract_file {
597     my $self = shift;
598     my $file = shift;   return unless defined $file;
599     my $alt  = shift;
600
601     my $entry = $self->_find_entry( $file )
602         or $self->_error( qq[Could not find an entry for '$file'] ), return;
603
604     return $self->_extract_file( $entry, $alt );
605 }
606
607 sub _extract_file {
608     my $self    = shift;
609     my $entry   = shift or return;
610     my $alt     = shift;
611
612     ### you wanted an alternate extraction location ###
613     my $name = defined $alt ? $alt : $entry->full_path;
614
615                             ### splitpath takes a bool at the end to indicate
616                             ### that it's splitting a dir
617     my ($vol,$dirs,$file);
618     if ( defined $alt ) { # It's a local-OS path
619         ($vol,$dirs,$file) = File::Spec->splitpath(       $alt,
620                                                           $entry->is_dir );
621     } else {
622         ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
623                                                           $entry->is_dir );
624     }
625
626     my $dir;
627     ### is $name an absolute path? ###
628     if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) {
629
630         ### absolute names are not allowed to be in tarballs under
631         ### strict mode, so only allow it if a user tells us to do it
632         if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
633             $self->_error(
634                 q[Entry ']. $entry->full_path .q[' is an absolute path. ].
635                 q[Not extracting absolute paths under SECURE EXTRACT MODE]
636             );
637             return;
638         }
639
640         ### user asked us to, it's fine.
641         $dir = File::Spec->catpath( $vol, $dirs, "" );
642
643     ### it's a relative path ###
644     } else {
645         my $cwd     = (ref $self and defined $self->{cwd})
646                         ? $self->{cwd}
647                         : cwd();
648
649         my @dirs = defined $alt
650             ? File::Spec->splitdir( $dirs )         # It's a local-OS path
651             : File::Spec::Unix->splitdir( $dirs );  # it's UNIX-style, likely
652                                                     # straight from the tarball
653
654         if( not defined $alt            and
655             not $INSECURE_EXTRACT_MODE
656         ) {
657
658             ### paths that leave the current directory are not allowed under
659             ### strict mode, so only allow it if a user tells us to do this.
660             if( grep { $_ eq '..' } @dirs ) {
661
662                 $self->_error(
663                     q[Entry ']. $entry->full_path .q[' is attempting to leave ].
664                     q[the current working directory. Not extracting under ].
665                     q[SECURE EXTRACT MODE]
666                 );
667                 return;
668             }
669
670             ### the archive may be asking us to extract into a symlink. This
671             ### is not sane and a possible security issue, as outlined here:
672             ### https://rt.cpan.org/Ticket/Display.html?id=30380
673             ### https://bugzilla.redhat.com/show_bug.cgi?id=295021
674             ### https://issues.rpath.com/browse/RPL-1716
675             my $full_path = $cwd;
676             for my $d ( @dirs ) {
677                 $full_path = File::Spec->catdir( $full_path, $d );
678
679                 ### we've already checked this one, and it's safe. Move on.
680                 next if ref $self and $self->{_link_cache}->{$full_path};
681
682                 if( -l $full_path ) {
683                     my $to   = readlink $full_path;
684                     my $diag = "symlinked directory ($full_path => $to)";
685
686                     $self->_error(
687                         q[Entry ']. $entry->full_path .q[' is attempting to ].
688                         qq[extract to a $diag. This is considered a security ].
689                         q[vulnerability and not allowed under SECURE EXTRACT ].
690                         q[MODE]
691                     );
692                     return;
693                 }
694
695                 ### XXX keep a cache if possible, so the stats become cheaper:
696                 $self->{_link_cache}->{$full_path} = 1 if ref $self;
697             }
698         }
699
700         ### '.' is the directory delimiter on VMS, which has to be escaped
701         ### or changed to '_' on vms.  vmsify is used, because older versions
702         ### of vmspath do not handle this properly.
703         ### Must not add a '/' to an empty directory though.
704         map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;
705
706         my ($cwd_vol,$cwd_dir,$cwd_file)
707                     = File::Spec->splitpath( $cwd );
708         my @cwd     = File::Spec->splitdir( $cwd_dir );
709         push @cwd, $cwd_file if length $cwd_file;
710
711         ### We need to pass '' as the last elemant to catpath. Craig Berry
712         ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
713         ### The root problem is that splitpath on UNIX always returns the
714         ### final path element as a file even if it is a directory, and of
715         ### course there is no way it can know the difference without checking
716         ### against the filesystem, which it is documented as not doing.  When
717         ### you turn around and call catpath, on VMS you have to know which bits
718         ### are directory bits and which bits are file bits.  In this case we
719         ### know the result should be a directory.  I had thought you could omit
720         ### the file argument to catpath in such a case, but apparently on UNIX
721         ### you can't.
722         $dir        = File::Spec->catpath(
723                             $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
724                         );
725
726         ### catdir() returns undef if the path is longer than 255 chars on
727         ### older VMS systems.
728         unless ( defined $dir ) {
729             $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
730             return;
731         }
732
733     }
734
735     if( -e $dir && !-d _ ) {
736         $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
737         return;
738     }
739
740     unless ( -d _ ) {
741         eval { File::Path::mkpath( $dir, 0, 0777 ) };
742         if( $@ ) {
743             my $fp = $entry->full_path;
744             $self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
745             return;
746         }
747
748         ### XXX chown here? that might not be the same as in the archive
749         ### as we're only chown'ing to the owner of the file we're extracting
750         ### not to the owner of the directory itself, which may or may not
751         ### be another entry in the archive
752         ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
753         ### way to go.
754         #if( $CHOWN && CAN_CHOWN ) {
755         #    chown $entry->uid, $entry->gid, $dir or
756         #        $self->_error( qq[Could not set uid/gid on '$dir'] );
757         #}
758     }
759
760     ### we're done if we just needed to create a dir ###
761     return 1 if $entry->is_dir;
762
763     my $full = File::Spec->catfile( $dir, $file );
764
765     if( $entry->is_unknown ) {
766         $self->_error( qq[Unknown file type for file '$full'] );
767         return;
768     }
769
770     if( length $entry->type && $entry->is_file ) {
771         my $fh = IO::File->new;
772         $fh->open( '>' . $full ) or (
773             $self->_error( qq[Could not open file '$full': $!] ),
774             return
775         );
776
777         if( $entry->size ) {
778             binmode $fh;
779             syswrite $fh, $entry->data or (
780                 $self->_error( qq[Could not write data to '$full'] ),
781                 return
782             );
783         }
784
785         close $fh or (
786             $self->_error( qq[Could not close file '$full'] ),
787             return
788         );
789
790     } else {
791         $self->_make_special_file( $entry, $full ) or return;
792     }
793
794     ### only update the timestamp if it's not a symlink; that will change the
795     ### timestamp of the original. This addresses bug #33669: Could not update
796     ### timestamp warning on symlinks
797     if( not -l $full ) {
798         utime time, $entry->mtime - TIME_OFFSET, $full or
799             $self->_error( qq[Could not update timestamp] );
800     }
801
802     if( $CHOWN && CAN_CHOWN->() ) {
803         chown $entry->uid, $entry->gid, $full or
804             $self->_error( qq[Could not set uid/gid on '$full'] );
805     }
806
807     ### only chmod if we're allowed to, but never chmod symlinks, since they'll
808     ### change the perms on the file they're linking too...
809     if( $CHMOD and not -l $full ) {
810         my $mode = $entry->mode;
811         unless ($SAME_PERMISSIONS) {
812             $mode &= ~(oct(7000) | umask);
813         }
814         chmod $mode, $full or
815             $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
816     }
817
818     return 1;
819 }
820
821 sub _make_special_file {
822     my $self    = shift;
823     my $entry   = shift     or return;
824     my $file    = shift;    return unless defined $file;
825
826     my $err;
827
828     if( $entry->is_symlink ) {
829         my $fail;
830         if( ON_UNIX ) {
831             symlink( $entry->linkname, $file ) or $fail++;
832
833         } else {
834             $self->_extract_special_file_as_plain_file( $entry, $file )
835                 or $fail++;
836         }
837
838         $err =  qq[Making symbolic link '$file' to '] .
839                 $entry->linkname .q[' failed] if $fail;
840
841     } elsif ( $entry->is_hardlink ) {
842         my $fail;
843         if( ON_UNIX ) {
844             link( $entry->linkname, $file ) or $fail++;
845
846         } else {
847             $self->_extract_special_file_as_plain_file( $entry, $file )
848                 or $fail++;
849         }
850
851         $err =  qq[Making hard link from '] . $entry->linkname .
852                 qq[' to '$file' failed] if $fail;
853
854     } elsif ( $entry->is_fifo ) {
855         ON_UNIX && !system('mknod', $file, 'p') or
856             $err = qq[Making fifo ']. $entry->name .qq[' failed];
857
858     } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
859         my $mode = $entry->is_blockdev ? 'b' : 'c';
860
861         ON_UNIX && !system('mknod', $file, $mode,
862                             $entry->devmajor, $entry->devminor) or
863             $err =  qq[Making block device ']. $entry->name .qq[' (maj=] .
864                     $entry->devmajor . qq[ min=] . $entry->devminor .
865                     qq[) failed.];
866
867     } elsif ( $entry->is_socket ) {
868         ### the original doesn't do anything special for sockets.... ###
869         1;
870     }
871
872     return $err ? $self->_error( $err ) : 1;
873 }
874
875 ### don't know how to make symlinks, let's just extract the file as
876 ### a plain file
877 sub _extract_special_file_as_plain_file {
878     my $self    = shift;
879     my $entry   = shift     or return;
880     my $file    = shift;    return unless defined $file;
881
882     my $err;
883     TRY: {
884         my $orig = $self->_find_entry( $entry->linkname );
885
886         unless( $orig ) {
887             $err =  qq[Could not find file '] . $entry->linkname .
888                     qq[' in memory.];
889             last TRY;
890         }
891
892         ### clone the entry, make it appear as a normal file ###
893         my $clone = $entry->clone;
894         $clone->_downgrade_to_plainfile;
895         $self->_extract_file( $clone, $file ) or last TRY;
896
897         return 1;
898     }
899
900     return $self->_error($err);
901 }
902
903 =head2 $tar->list_files( [\@properties] )
904
905 Returns a list of the names of all the files in the archive.
906
907 If C<list_files()> is passed an array reference as its first argument
908 it returns a list of hash references containing the requested
909 properties of each file.  The following list of properties is
910 supported: name, size, mtime (last modified date), mode, uid, gid,
911 linkname, uname, gname, devmajor, devminor, prefix.
912
913 Passing an array reference containing only one element, 'name', is
914 special cased to return a list of names rather than a list of hash
915 references, making it equivalent to calling C<list_files> without
916 arguments.
917
918 =cut
919
920 sub list_files {
921     my $self = shift;
922     my $aref = shift || [ ];
923
924     unless( $self->_data ) {
925         $self->read() or return;
926     }
927
928     if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
929         return map { $_->full_path } @{$self->_data};
930     } else {
931
932         #my @rv;
933         #for my $obj ( @{$self->_data} ) {
934         #    push @rv, { map { $_ => $obj->$_() } @$aref };
935         #}
936         #return @rv;
937
938         ### this does the same as the above.. just needs a +{ }
939         ### to make sure perl doesn't confuse it for a block
940         return map {    my $o=$_;
941                         +{ map { $_ => $o->$_() } @$aref }
942                     } @{$self->_data};
943     }
944 }
945
946 sub _find_entry {
947     my $self = shift;
948     my $file = shift;
949
950     unless( defined $file ) {
951         $self->_error( qq[No file specified] );
952         return;
953     }
954
955     ### it's an object already
956     return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
957
958     for my $entry ( @{$self->_data} ) {
959         my $path = $entry->full_path;
960         return $entry if $path eq $file;
961     }
962
963     $self->_error( qq[No such file in archive: '$file'] );
964     return;
965 }
966
967 =head2 $tar->get_files( [@filenames] )
968
969 Returns the C<Archive::Tar::File> objects matching the filenames
970 provided. If no filename list was passed, all C<Archive::Tar::File>
971 objects in the current Tar object are returned.
972
973 Please refer to the C<Archive::Tar::File> documentation on how to
974 handle these objects.
975
976 =cut
977
978 sub get_files {
979     my $self = shift;
980
981     return @{ $self->_data } unless @_;
982
983     my @list;
984     for my $file ( @_ ) {
985         push @list, grep { defined } $self->_find_entry( $file );
986     }
987
988     return @list;
989 }
990
991 =head2 $tar->get_content( $file )
992
993 Return the content of the named file.
994
995 =cut
996
997 sub get_content {
998     my $self = shift;
999     my $entry = $self->_find_entry( shift ) or return;
1000
1001     return $entry->data;
1002 }
1003
1004 =head2 $tar->replace_content( $file, $content )
1005
1006 Make the string $content be the content for the file named $file.
1007
1008 =cut
1009
1010 sub replace_content {
1011     my $self = shift;
1012     my $entry = $self->_find_entry( shift ) or return;
1013
1014     return $entry->replace_content( shift );
1015 }
1016
1017 =head2 $tar->rename( $file, $new_name )
1018
1019 Rename the file of the in-memory archive to $new_name.
1020
1021 Note that you must specify a Unix path for $new_name, since per tar
1022 standard, all files in the archive must be Unix paths.
1023
1024 Returns true on success and false on failure.
1025
1026 =cut
1027
1028 sub rename {
1029     my $self = shift;
1030     my $file = shift; return unless defined $file;
1031     my $new  = shift; return unless defined $new;
1032
1033     my $entry = $self->_find_entry( $file ) or return;
1034
1035     return $entry->rename( $new );
1036 }
1037
1038 =head2 $tar->remove (@filenamelist)
1039
1040 Removes any entries with names matching any of the given filenames
1041 from the in-memory archive. Returns a list of C<Archive::Tar::File>
1042 objects that remain.
1043
1044 =cut
1045
1046 sub remove {
1047     my $self = shift;
1048     my @list = @_;
1049
1050     my %seen = map { $_->full_path => $_ } @{$self->_data};
1051     delete $seen{ $_ } for @list;
1052
1053     $self->_data( [values %seen] );
1054
1055     return values %seen;
1056 }
1057
1058 =head2 $tar->clear
1059
1060 C<clear> clears the current in-memory archive. This effectively gives
1061 you a 'blank' object, ready to be filled again. Note that C<clear>
1062 only has effect on the object, not the underlying tarfile.
1063
1064 =cut
1065
1066 sub clear {
1067     my $self = shift or return;
1068
1069     $self->_data( [] );
1070     $self->_file( '' );
1071
1072     return 1;
1073 }
1074
1075
1076 =head2 $tar->write ( [$file, $compressed, $prefix] )
1077
1078 Write the in-memory archive to disk.  The first argument can either
1079 be the name of a file or a reference to an already open filehandle (a
1080 GLOB reference).
1081
1082 The second argument is used to indicate compression. You can either
1083 compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
1084 to be the C<gzip> compression level (between 1 and 9), but the use of
1085 constants is prefered:
1086
1087   # write a gzip compressed file
1088   $tar->write( 'out.tgz', COMPRESS_GZIP );
1089
1090   # write a bzip compressed file
1091   $tar->write( 'out.tbz', COMPRESS_BZIP );
1092
1093 Note that when you pass in a filehandle, the compression argument
1094 is ignored, as all files are printed verbatim to your filehandle.
1095 If you wish to enable compression with filehandles, use an
1096 C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
1097
1098 The third argument is an optional prefix. All files will be tucked
1099 away in the directory you specify as prefix. So if you have files
1100 'a' and 'b' in your archive, and you specify 'foo' as prefix, they
1101 will be written to the archive as 'foo/a' and 'foo/b'.
1102
1103 If no arguments are given, C<write> returns the entire formatted
1104 archive as a string, which could be useful if you'd like to stuff the
1105 archive into a socket or a pipe to gzip or something.
1106
1107
1108 =cut
1109
1110 sub write {
1111     my $self        = shift;
1112     my $file        = shift; $file = '' unless defined $file;
1113     my $gzip        = shift || 0;
1114     my $ext_prefix  = shift; $ext_prefix = '' unless defined $ext_prefix;
1115     my $dummy       = '';
1116
1117     ### only need a handle if we have a file to print to ###
1118     my $handle = length($file)
1119                     ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
1120                         or return )
1121                     : $HAS_PERLIO    ? do { open my $h, '>', \$dummy; $h }
1122                     : $HAS_IO_STRING ? IO::String->new
1123                     : __PACKAGE__->no_string_support();
1124
1125     ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a
1126     ### corrupt TAR file. Must clear out $\ to make sure no garbage is
1127     ### printed to the archive
1128     local $\;
1129
1130     for my $entry ( @{$self->_data} ) {
1131         ### entries to be written to the tarfile ###
1132         my @write_me;
1133
1134         ### only now will we change the object to reflect the current state
1135         ### of the name and prefix fields -- this needs to be limited to
1136         ### write() only!
1137         my $clone = $entry->clone;
1138
1139
1140         ### so, if you don't want use to use the prefix, we'll stuff
1141         ### everything in the name field instead
1142         if( $DO_NOT_USE_PREFIX ) {
1143
1144             ### you might have an extended prefix, if so, set it in the clone
1145             ### XXX is ::Unix right?
1146             $clone->name( length $ext_prefix
1147                             ? File::Spec::Unix->catdir( $ext_prefix,
1148                                                         $clone->full_path)
1149                             : $clone->full_path );
1150             $clone->prefix( '' );
1151
1152         ### otherwise, we'll have to set it properly -- prefix part in the
1153         ### prefix and name part in the name field.
1154         } else {
1155
1156             ### split them here, not before!
1157             my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
1158
1159             ### you might have an extended prefix, if so, set it in the clone
1160             ### XXX is ::Unix right?
1161             $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
1162                 if length $ext_prefix;
1163
1164             $clone->prefix( $prefix );
1165             $clone->name( $name );
1166         }
1167
1168         ### names are too long, and will get truncated if we don't add a
1169         ### '@LongLink' file...
1170         my $make_longlink = (   length($clone->name)    > NAME_LENGTH or
1171                                 length($clone->prefix)  > PREFIX_LENGTH
1172                             ) || 0;
1173
1174         ### perhaps we need to make a longlink file?
1175         if( $make_longlink ) {
1176             my $longlink = Archive::Tar::File->new(
1177                             data => LONGLINK_NAME,
1178                             $clone->full_path,
1179                             { type => LONGLINK }
1180                         );
1181
1182             unless( $longlink ) {
1183                 $self->_error(  qq[Could not create 'LongLink' entry for ] .
1184                                 qq[oversize file '] . $clone->full_path ."'" );
1185                 return;
1186             };
1187
1188             push @write_me, $longlink;
1189         }
1190
1191         push @write_me, $clone;
1192
1193         ### write the one, optionally 2 a::t::file objects to the handle
1194         for my $clone (@write_me) {
1195
1196             ### if the file is a symlink, there are 2 options:
1197             ### either we leave the symlink intact, but then we don't write any
1198             ### data OR we follow the symlink, which means we actually make a
1199             ### copy. if we do the latter, we have to change the TYPE of the
1200             ### clone to 'FILE'
1201             my $link_ok =  $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
1202             my $data_ok = !$clone->is_symlink && $clone->has_content;
1203
1204             ### downgrade to a 'normal' file if it's a symlink we're going to
1205             ### treat as a regular file
1206             $clone->_downgrade_to_plainfile if $link_ok;
1207
1208             ### get the header for this block
1209             my $header = $self->_format_tar_entry( $clone );
1210             unless( $header ) {
1211                 $self->_error(q[Could not format header for: ] .
1212                                     $clone->full_path );
1213                 return;
1214             }
1215
1216             unless( print $handle $header ) {
1217                 $self->_error(q[Could not write header for: ] .
1218                                     $clone->full_path);
1219                 return;
1220             }
1221
1222             if( $link_ok or $data_ok ) {
1223                 unless( print $handle $clone->data ) {
1224                     $self->_error(q[Could not write data for: ] .
1225                                     $clone->full_path);
1226                     return;
1227                 }
1228
1229                 ### pad the end of the clone if required ###
1230                 print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
1231             }
1232
1233         } ### done writing these entries
1234     }
1235
1236     ### write the end markers ###
1237     print $handle TAR_END x 2 or
1238             return $self->_error( qq[Could not write tar end markers] );
1239
1240     ### did you want it written to a file, or returned as a string? ###
1241     my $rv =  length($file) ? 1
1242                         : $HAS_PERLIO ? $dummy
1243                         : do { seek $handle, 0, 0; local $/; <$handle> };
1244
1245     ### make sure to close the handle;
1246     close $handle;
1247
1248     return $rv;
1249 }
1250
1251 sub _format_tar_entry {
1252     my $self        = shift;
1253     my $entry       = shift or return;
1254     my $ext_prefix  = shift; $ext_prefix = '' unless defined $ext_prefix;
1255     my $no_prefix   = shift || 0;
1256
1257     my $file    = $entry->name;
1258     my $prefix  = $entry->prefix; $prefix = '' unless defined $prefix;
1259
1260     ### remove the prefix from the file name
1261     ### not sure if this is still neeeded --kane
1262     ### no it's not -- Archive::Tar::File->_new_from_file will take care of
1263     ### this for us. Even worse, this would break if we tried to add a file
1264     ### like x/x.
1265     #if( length $prefix ) {
1266     #    $file =~ s/^$match//;
1267     #}
1268
1269     $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
1270                 if length $ext_prefix;
1271
1272     ### not sure why this is... ###
1273     my $l = PREFIX_LENGTH; # is ambiguous otherwise...
1274     substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
1275
1276     my $f1 = "%06o"; my $f2  = "%11o";
1277
1278     ### this might be optimizable with a 'changed' flag in the file objects ###
1279     my $tar = pack (
1280                 PACK,
1281                 $file,
1282
1283                 (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
1284                 (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
1285
1286                 "",  # checksum field - space padded a bit down
1287
1288                 (map { $entry->$_() }                 qw[type linkname magic]),
1289
1290                 $entry->version || TAR_VERSION,
1291
1292                 (map { $entry->$_() }                 qw[uname gname]),
1293                 (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
1294
1295                 ($no_prefix ? '' : $prefix)
1296     );
1297
1298     ### add the checksum ###
1299     substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
1300
1301     return $tar;
1302 }
1303
1304 =head2 $tar->add_files( @filenamelist )
1305
1306 Takes a list of filenames and adds them to the in-memory archive.
1307
1308 The path to the file is automatically converted to a Unix like
1309 equivalent for use in the archive, and, if on MacOS, the file's
1310 modification time is converted from the MacOS epoch to the Unix epoch.
1311 So tar archives created on MacOS with B<Archive::Tar> can be read
1312 both with I<tar> on Unix and applications like I<suntar> or
1313 I<Stuffit Expander> on MacOS.
1314
1315 Be aware that the file's type/creator and resource fork will be lost,
1316 which is usually what you want in cross-platform archives.
1317
1318 Instead of a filename, you can also pass it an existing C<Archive::Tar::File>
1319 object from, for example, another archive. The object will be clone, and
1320 effectively be a copy of the original, not an alias.
1321
1322 Returns a list of C<Archive::Tar::File> objects that were just added.
1323
1324 =cut
1325
1326 sub add_files {
1327     my $self    = shift;
1328     my @files   = @_ or return;
1329
1330     my @rv;
1331     for my $file ( @files ) {
1332
1333         ### you passed an Archive::Tar::File object
1334         ### clone it so we don't accidentally have a reference to
1335         ### an object from another archive
1336         if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) {
1337             push @rv, $file->clone;
1338             next;
1339         }
1340
1341         unless( -e $file || -l $file ) {
1342             $self->_error( qq[No such file: '$file'] );
1343             next;
1344         }
1345
1346         my $obj = Archive::Tar::File->new( file => $file );
1347         unless( $obj ) {
1348             $self->_error( qq[Unable to add file: '$file'] );
1349             next;
1350         }
1351
1352         push @rv, $obj;
1353     }
1354
1355     push @{$self->{_data}}, @rv;
1356
1357     return @rv;
1358 }
1359
1360 =head2 $tar->add_data ( $filename, $data, [$opthashref] )
1361
1362 Takes a filename, a scalar full of data and optionally a reference to
1363 a hash with specific options.
1364
1365 Will add a file to the in-memory archive, with name C<$filename> and
1366 content C<$data>. Specific properties can be set using C<$opthashref>.
1367 The following list of properties is supported: name, size, mtime
1368 (last modified date), mode, uid, gid, linkname, uname, gname,
1369 devmajor, devminor, prefix, type.  (On MacOS, the file's path and
1370 modification times are converted to Unix equivalents.)
1371
1372 Valid values for the file type are the following constants defined in
1373 Archive::Tar::Constants:
1374
1375 =over 4
1376
1377 =item FILE
1378
1379 Regular file.
1380
1381 =item HARDLINK
1382
1383 =item SYMLINK
1384
1385 Hard and symbolic ("soft") links; linkname should specify target.
1386
1387 =item CHARDEV
1388
1389 =item BLOCKDEV
1390
1391 Character and block devices. devmajor and devminor should specify the major
1392 and minor device numbers.
1393
1394 =item DIR
1395
1396 Directory.
1397
1398 =item FIFO
1399
1400 FIFO (named pipe).
1401
1402 =item SOCKET
1403
1404 Socket.
1405
1406 =back
1407
1408 Returns the C<Archive::Tar::File> object that was just added, or
1409 C<undef> on failure.
1410
1411 =cut
1412
1413 sub add_data {
1414     my $self    = shift;
1415     my ($file, $data, $opt) = @_;
1416
1417     my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
1418     unless( $obj ) {
1419         $self->_error( qq[Unable to add file: '$file'] );
1420         return;
1421     }
1422
1423     push @{$self->{_data}}, $obj;
1424
1425     return $obj;
1426 }
1427
1428 =head2 $tar->error( [$BOOL] )
1429
1430 Returns the current errorstring (usually, the last error reported).
1431 If a true value was specified, it will give the C<Carp::longmess>
1432 equivalent of the error, in effect giving you a stacktrace.
1433
1434 For backwards compatibility, this error is also available as
1435 C<$Archive::Tar::error> although it is much recommended you use the
1436 method call instead.
1437
1438 =cut
1439
1440 {
1441     $error = '';
1442     my $longmess;
1443
1444     sub _error {
1445         my $self    = shift;
1446         my $msg     = $error = shift;
1447         $longmess   = Carp::longmess($error);
1448
1449         ### set Archive::Tar::WARN to 0 to disable printing
1450         ### of errors
1451         if( $WARN ) {
1452             carp $DEBUG ? $longmess : $msg;
1453         }
1454
1455         return;
1456     }
1457
1458     sub error {
1459         my $self = shift;
1460         return shift() ? $longmess : $error;
1461     }
1462 }
1463
1464 =head2 $tar->setcwd( $cwd );
1465
1466 C<Archive::Tar> needs to know the current directory, and it will run
1467 C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
1468 tarfile and saves it in the file system. (As of version 1.30, however,
1469 C<Archive::Tar> will use the speed optimization described below
1470 automatically, so it's only relevant if you're using C<extract_file()>).
1471
1472 Since C<Archive::Tar> doesn't change the current directory internally
1473 while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
1474 can be avoided if we can guarantee that the current directory doesn't
1475 get changed externally.
1476
1477 To use this performance boost, set the current directory via
1478
1479     use Cwd;
1480     $tar->setcwd( cwd() );
1481
1482 once before calling a function like C<extract_file> and
1483 C<Archive::Tar> will use the current directory setting from then on
1484 and won't call C<Cwd::cwd()> internally.
1485
1486 To switch back to the default behaviour, use
1487
1488     $tar->setcwd( undef );
1489
1490 and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
1491
1492 If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
1493 be called for you.
1494
1495 =cut
1496
1497 sub setcwd {
1498     my $self     = shift;
1499     my $cwd      = shift;
1500
1501     $self->{cwd} = $cwd;
1502 }
1503
1504 =head1 Class Methods
1505
1506 =head2 Archive::Tar->create_archive($file, $compressed, @filelist)
1507
1508 Creates a tar file from the list of files provided.  The first
1509 argument can either be the name of the tar file to create or a
1510 reference to an open file handle (e.g. a GLOB reference).
1511
1512 The second argument is used to indicate compression. You can either
1513 compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
1514 to be the C<gzip> compression level (between 1 and 9), but the use of
1515 constants is prefered:
1516
1517   # write a gzip compressed file
1518   Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist );
1519
1520   # write a bzip compressed file
1521   Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist );
1522
1523 Note that when you pass in a filehandle, the compression argument
1524 is ignored, as all files are printed verbatim to your filehandle.
1525 If you wish to enable compression with filehandles, use an
1526 C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
1527
1528 The remaining arguments list the files to be included in the tar file.
1529 These files must all exist. Any files which don't exist or can't be
1530 read are silently ignored.
1531
1532 If the archive creation fails for any reason, C<create_archive> will
1533 return false. Please use the C<error> method to find the cause of the
1534 failure.
1535
1536 Note that this method does not write C<on the fly> as it were; it
1537 still reads all the files into memory before writing out the archive.
1538 Consult the FAQ below if this is a problem.
1539
1540 =cut
1541
1542 sub create_archive {
1543     my $class = shift;
1544
1545     my $file    = shift; return unless defined $file;
1546     my $gzip    = shift || 0;
1547     my @files   = @_;
1548
1549     unless( @files ) {
1550         return $class->_error( qq[Cowardly refusing to create empty archive!] );
1551     }
1552
1553     my $tar = $class->new;
1554     $tar->add_files( @files );
1555     return $tar->write( $file, $gzip );
1556 }
1557
1558 =head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] )
1559
1560 Returns an iterator function that reads the tar file without loading
1561 it all in memory.  Each time the function is called it will return the
1562 next file in the tarball. The files are returned as
1563 C<Archive::Tar::File> objects. The iterator function returns the
1564 empty list once it has exhausted the the files contained.
1565
1566 The second argument can be a hash reference with options, which are
1567 identical to the arguments passed to C<read()>.
1568
1569 Example usage:
1570
1571     my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} );
1572
1573     while( my $f = $next->() ) {
1574         print $f->name, "\n";
1575
1576         $f->extract or warn "Extraction failed";
1577
1578         # ....
1579     }
1580
1581 =cut
1582
1583
1584 sub iter {
1585     my $class       = shift;
1586     my $filename    = shift or return;
1587     my $compressed  = shift or 0;
1588     my $opts        = shift || {};
1589
1590     ### get a handle to read from.
1591     my $handle = $class->_get_handle(
1592         $filename,
1593         $compressed,
1594         READ_ONLY->( ZLIB )
1595     ) or return;
1596
1597     my @data;
1598     return sub {
1599         return shift(@data)     if @data;       # more than one file returned?
1600         return                  unless $handle; # handle exhausted?
1601
1602         ### read data, should only return file
1603         @data = @{ $class->_read_tar($handle, { %$opts, limit => 1 }) };
1604
1605         ### return one piece of data
1606         return shift(@data)     if @data;
1607
1608         ### data is exhausted, free the filehandle
1609         undef $handle;
1610         return;
1611     };
1612 }
1613
1614 =head2 Archive::Tar->list_archive($file, $compressed, [\@properties])
1615
1616 Returns a list of the names of all the files in the archive.  The
1617 first argument can either be the name of the tar file to list or a
1618 reference to an open file handle (e.g. a GLOB reference).
1619
1620 If C<list_archive()> is passed an array reference as its third
1621 argument it returns a list of hash references containing the requested
1622 properties of each file.  The following list of properties is
1623 supported: full_path, name, size, mtime (last modified date), mode,
1624 uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
1625
1626 See C<Archive::Tar::File> for details about supported properties.
1627
1628 Passing an array reference containing only one element, 'name', is
1629 special cased to return a list of names rather than a list of hash
1630 references.
1631
1632 =cut
1633
1634 sub list_archive {
1635     my $class   = shift;
1636     my $file    = shift; return unless defined $file;
1637     my $gzip    = shift || 0;
1638
1639     my $tar = $class->new($file, $gzip);
1640     return unless $tar;
1641
1642     return $tar->list_files( @_ );
1643 }
1644
1645 =head2 Archive::Tar->extract_archive($file, $compressed)
1646
1647 Extracts the contents of the tar file.  The first argument can either
1648 be the name of the tar file to create or a reference to an open file
1649 handle (e.g. a GLOB reference).  All relative paths in the tar file will
1650 be created underneath the current working directory.
1651
1652 C<extract_archive> will return a list of files it extracted.
1653 If the archive extraction fails for any reason, C<extract_archive>
1654 will return false.  Please use the C<error> method to find the cause
1655 of the failure.
1656
1657 =cut
1658
1659 sub extract_archive {
1660     my $class   = shift;
1661     my $file    = shift; return unless defined $file;
1662     my $gzip    = shift || 0;
1663
1664     my $tar = $class->new( ) or return;
1665
1666     return $tar->read( $file, $gzip, { extract => 1 } );
1667 }
1668
1669 =head2 $bool = Archive::Tar->has_io_string
1670
1671 Returns true if we currently have C<IO::String> support loaded.
1672
1673 Either C<IO::String> or C<perlio> support is needed to support writing
1674 stringified archives. Currently, C<perlio> is the preferred method, if
1675 available.
1676
1677 See the C<GLOBAL VARIABLES> section to see how to change this preference.
1678
1679 =cut
1680
1681 sub has_io_string { return $HAS_IO_STRING; }
1682
1683 =head2 $bool = Archive::Tar->has_perlio
1684
1685 Returns true if we currently have C<perlio> support loaded.
1686
1687 This requires C<perl-5.8> or higher, compiled with C<perlio>
1688
1689 Either C<IO::String> or C<perlio> support is needed to support writing
1690 stringified archives. Currently, C<perlio> is the preferred method, if
1691 available.
1692
1693 See the C<GLOBAL VARIABLES> section to see how to change this preference.
1694
1695 =cut
1696
1697 sub has_perlio { return $HAS_PERLIO; }
1698
1699 =head2 $bool = Archive::Tar->has_zlib_support
1700
1701 Returns true if C<Archive::Tar> can extract C<zlib> compressed archives
1702
1703 =cut
1704
1705 sub has_zlib_support { return ZLIB }
1706
1707 =head2 $bool = Archive::Tar->has_bzip2_support
1708
1709 Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives
1710
1711 =cut
1712
1713 sub has_bzip2_support { return BZIP }
1714
1715 =head2 Archive::Tar->can_handle_compressed_files
1716
1717 A simple checking routine, which will return true if C<Archive::Tar>
1718 is able to uncompress compressed archives on the fly with C<IO::Zlib>
1719 and C<IO::Compress::Bzip2> or false if not both are installed.
1720
1721 You can use this as a shortcut to determine whether C<Archive::Tar>
1722 will do what you think before passing compressed archives to its
1723 C<read> method.
1724
1725 =cut
1726
1727 sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 }
1728
1729 sub no_string_support {
1730     croak("You have to install IO::String to support writing archives to strings");
1731 }
1732
1733 1;
1734
1735 __END__
1736
1737 =head1 GLOBAL VARIABLES
1738
1739 =head2 $Archive::Tar::FOLLOW_SYMLINK
1740
1741 Set this variable to C<1> to make C<Archive::Tar> effectively make a
1742 copy of the file when extracting. Default is C<0>, which
1743 means the symlink stays intact. Of course, you will have to pack the
1744 file linked to as well.
1745
1746 This option is checked when you write out the tarfile using C<write>
1747 or C<create_archive>.
1748
1749 This works just like C</bin/tar>'s C<-h> option.
1750
1751 =head2 $Archive::Tar::CHOWN
1752
1753 By default, C<Archive::Tar> will try to C<chown> your files if it is
1754 able to. In some cases, this may not be desired. In that case, set
1755 this variable to C<0> to disable C<chown>-ing, even if it were
1756 possible.
1757
1758 The default is C<1>.
1759
1760 =head2 $Archive::Tar::CHMOD
1761
1762 By default, C<Archive::Tar> will try to C<chmod> your files to
1763 whatever mode was specified for the particular file in the archive.
1764 In some cases, this may not be desired. In that case, set this
1765 variable to C<0> to disable C<chmod>-ing.
1766
1767 The default is C<1>.
1768
1769 =head2 $Archive::Tar::SAME_PERMISSIONS
1770
1771 When, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether
1772 the permissions on files from the archive are used without modification
1773 of if they are filtered by removing any setid bits and applying the
1774 current umask.
1775
1776 The default is C<1> for the root user and C<0> for normal users.
1777
1778 =head2 $Archive::Tar::DO_NOT_USE_PREFIX
1779
1780 By default, C<Archive::Tar> will try to put paths that are over
1781 100 characters in the C<prefix> field of your tar header, as
1782 defined per POSIX-standard. However, some (older) tar programs
1783 do not implement this spec. To retain compatibility with these older
1784 or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
1785 variable to a true value, and C<Archive::Tar> will use an alternate
1786 way of dealing with paths over 100 characters by using the
1787 C<GNU Extended Header> feature.
1788
1789 Note that clients who do not support the C<GNU Extended Header>
1790 feature will not be able to read these archives. Such clients include
1791 tars on C<Solaris>, C<Irix> and C<AIX>.
1792
1793 The default is C<0>.
1794
1795 =head2 $Archive::Tar::DEBUG
1796
1797 Set this variable to C<1> to always get the C<Carp::longmess> output
1798 of the warnings, instead of the regular C<carp>. This is the same
1799 message you would get by doing:
1800
1801     $tar->error(1);
1802
1803 Defaults to C<0>.
1804
1805 =head2 $Archive::Tar::WARN
1806
1807 Set this variable to C<0> if you do not want any warnings printed.
1808 Personally I recommend against doing this, but people asked for the
1809 option. Also, be advised that this is of course not threadsafe.
1810
1811 Defaults to C<1>.
1812
1813 =head2 $Archive::Tar::error
1814
1815 Holds the last reported error. Kept for historical reasons, but its
1816 use is very much discouraged. Use the C<error()> method instead:
1817
1818     warn $tar->error unless $tar->extract;
1819
1820 =head2 $Archive::Tar::INSECURE_EXTRACT_MODE
1821
1822 This variable indicates whether C<Archive::Tar> should allow
1823 files to be extracted outside their current working directory.
1824
1825 Allowing this could have security implications, as a malicious
1826 tar archive could alter or replace any file the extracting user
1827 has permissions to. Therefor, the default is to not allow
1828 insecure extractions.
1829
1830 If you trust the archive, or have other reasons to allow the
1831 archive to write files outside your current working directory,
1832 set this variable to C<true>.
1833
1834 Note that this is a backwards incompatible change from version
1835 C<1.36> and before.
1836
1837 =head2 $Archive::Tar::HAS_PERLIO
1838
1839 This variable holds a boolean indicating if we currently have
1840 C<perlio> support loaded. This will be enabled for any perl
1841 greater than C<5.8> compiled with C<perlio>.
1842
1843 If you feel strongly about disabling it, set this variable to
1844 C<false>. Note that you will then need C<IO::String> installed
1845 to support writing stringified archives.
1846
1847 Don't change this variable unless you B<really> know what you're
1848 doing.
1849
1850 =head2 $Archive::Tar::HAS_IO_STRING
1851
1852 This variable holds a boolean indicating if we currently have
1853 C<IO::String> support loaded. This will be enabled for any perl
1854 that has a loadable C<IO::String> module.
1855
1856 If you feel strongly about disabling it, set this variable to
1857 C<false>. Note that you will then need C<perlio> support from
1858 your perl to be able to  write stringified archives.
1859
1860 Don't change this variable unless you B<really> know what you're
1861 doing.
1862
1863 =head1 FAQ
1864
1865 =over 4
1866
1867 =item What's the minimum perl version required to run Archive::Tar?
1868
1869 You will need perl version 5.005_03 or newer.
1870
1871 =item Isn't Archive::Tar slow?
1872
1873 Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar>
1874 However, it's very portable. If speed is an issue, consider using
1875 C</bin/tar> instead.
1876
1877 =item Isn't Archive::Tar heavier on memory than /bin/tar?
1878
1879 Yes it is, see previous answer. Since C<Compress::Zlib> and therefore
1880 C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
1881 choice but to read the archive into memory.
1882 This is ok if you want to do in-memory manipulation of the archive.
1883
1884 If you just want to extract, use the C<extract_archive> class method
1885 instead. It will optimize and write to disk immediately.
1886
1887 Another option is to use the C<iter> class method to iterate over
1888 the files in the tarball without reading them all in memory at once.
1889
1890 =item Can you lazy-load data instead?
1891
1892 In some cases, yes. You can use the C<iter> class method to iterate
1893 over the files in the tarball without reading them all in memory at once.
1894
1895 =item How much memory will an X kb tar file need?
1896
1897 Probably more than X kb, since it will all be read into memory. If
1898 this is a problem, and you don't need to do in memory manipulation
1899 of the archive, consider using the C<iter> class method, or C</bin/tar>
1900 instead.
1901
1902 =item What do you do with unsupported filetypes in an archive?
1903
1904 C<Unix> has a few filetypes that aren't supported on other platforms,
1905 like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just
1906 try to make a copy of the original file, rather than throwing an error.
1907
1908 This does require you to read the entire archive in to memory first,
1909 since otherwise we wouldn't know what data to fill the copy with.
1910 (This means that you cannot use the class methods, including C<iter>
1911 on archives that have incompatible filetypes and still expect things
1912 to work).
1913
1914 For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
1915 the extraction of this particular item didn't work.
1916
1917 =item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly!
1918
1919 By default, C<Archive::Tar> is in a completely POSIX-compatible
1920 mode, which uses the POSIX-specification of C<tar> to store files.
1921 For paths greather than 100 characters, this is done using the
1922 C<POSIX header prefix>. Non-POSIX-compatible clients may not support
1923 this part of the specification, and may only support the C<GNU Extended
1924 Header> functionality. To facilitate those clients, you can set the
1925 C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
1926 C<GLOBAL VARIABLES> section for details on this variable.
1927
1928 Note that GNU tar earlier than version 1.14 does not cope well with
1929 the C<POSIX header prefix>. If you use such a version, consider setting
1930 the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>.
1931
1932 =item How do I extract only files that have property X from an archive?
1933
1934 Sometimes, you might not wish to extract a complete archive, just
1935 the files that are relevant to you, based on some criteria.
1936
1937 You can do this by filtering a list of C<Archive::Tar::File> objects
1938 based on your criteria. For example, to extract only files that have
1939 the string C<foo> in their title, you would use:
1940
1941     $tar->extract(
1942         grep { $_->full_path =~ /foo/ } $tar->get_files
1943     );
1944
1945 This way, you can filter on any attribute of the files in the archive.
1946 Consult the C<Archive::Tar::File> documentation on how to use these
1947 objects.
1948
1949 =item How do I access .tar.Z files?
1950
1951 The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
1952 the C<IO::Zlib> module) to access tar files that have been compressed
1953 with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
1954 utility cannot be read by C<Compress::Zlib> and so cannot be directly
1955 accesses by C<Archive::Tar>.
1956
1957 If the C<uncompress> or C<gunzip> programs are available, you can use
1958 one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
1959
1960 Firstly with C<uncompress>
1961
1962     use Archive::Tar;
1963
1964     open F, "uncompress -c $filename |";
1965     my $tar = Archive::Tar->new(*F);
1966     ...
1967
1968 and this with C<gunzip>
1969
1970     use Archive::Tar;
1971
1972     open F, "gunzip -c $filename |";
1973     my $tar = Archive::Tar->new(*F);
1974     ...
1975
1976 Similarly, if the C<compress> program is available, you can use this to
1977 write a C<.tar.Z> file
1978
1979     use Archive::Tar;
1980     use IO::File;
1981
1982     my $fh = new IO::File "| compress -c >$filename";
1983     my $tar = Archive::Tar->new();
1984     ...
1985     $tar->write($fh);
1986     $fh->close ;
1987
1988 =item How do I handle Unicode strings?
1989
1990 C<Archive::Tar> uses byte semantics for any files it reads from or writes
1991 to disk. This is not a problem if you only deal with files and never
1992 look at their content or work solely with byte strings. But if you use
1993 Unicode strings with character semantics, some additional steps need
1994 to be taken.
1995
1996 For example, if you add a Unicode string like
1997
1998     # Problem
1999     $tar->add_data('file.txt', "Euro: \x{20AC}");
2000
2001 then there will be a problem later when the tarfile gets written out
2002 to disk via C<$tar->write()>:
2003
2004     Wide character in print at .../Archive/Tar.pm line 1014.
2005
2006 The data was added as a Unicode string and when writing it out to disk,
2007 the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl
2008 tried to convert the string to ISO-8859 and failed. The written file
2009 now contains garbage.
2010
2011 For this reason, Unicode strings need to be converted to UTF-8-encoded
2012 bytestrings before they are handed off to C<add_data()>:
2013
2014     use Encode;
2015     my $data = "Accented character: \x{20AC}";
2016     $data = encode('utf8', $data);
2017
2018     $tar->add_data('file.txt', $data);
2019
2020 A opposite problem occurs if you extract a UTF8-encoded file from a
2021 tarball. Using C<get_content()> on the C<Archive::Tar::File> object
2022 will return its content as a bytestring, not as a Unicode string.
2023
2024 If you want it to be a Unicode string (because you want character
2025 semantics with operations like regular expression matching), you need
2026 to decode the UTF8-encoded content and have Perl convert it into
2027 a Unicode string:
2028
2029     use Encode;
2030     my $data = $tar->get_content();
2031
2032     # Make it a Unicode string
2033     $data = decode('utf8', $data);
2034
2035 There is no easy way to provide this functionality in C<Archive::Tar>,
2036 because a tarball can contain many files, and each of which could be
2037 encoded in a different way.
2038
2039 =back
2040
2041 =head1 CAVEATS
2042
2043 The AIX tar does not fill all unused space in the tar archive with 0x00. 
2044 This sometimes leads to warning messages from C<Archive::Tar>.
2045
2046   Invalid header block at offset nnn
2047
2048 A fix for that problem is scheduled to be released in the following levels
2049 of AIX, all of which should be coming out in the 4th quarter of 2009:
2050
2051  AIX 5.3 TL7 SP10
2052  AIX 5.3 TL8 SP8
2053  AIX 5.3 TL9 SP5
2054  AIX 5.3 TL10 SP2
2055  
2056  AIX 6.1 TL0 SP11
2057  AIX 6.1 TL1 SP7
2058  AIX 6.1 TL2 SP6
2059  AIX 6.1 TL3 SP3
2060
2061 The IBM APAR number for this problem is IZ50240 (Reported component ID: 
2062 5765G0300 / AIX 5.3). It is possible to get an ifix for that problem. 
2063 If you need an ifix please contact your local IBM AIX support.
2064
2065 =head1 TODO
2066
2067 =over 4
2068
2069 =item Check if passed in handles are open for read/write
2070
2071 Currently I don't know of any portable pure perl way to do this.
2072 Suggestions welcome.
2073
2074 =item Allow archives to be passed in as string
2075
2076 Currently, we only allow opened filehandles or filenames, but
2077 not strings. The internals would need some reworking to facilitate
2078 stringified archives.
2079
2080 =item Facilitate processing an opened filehandle of a compressed archive
2081
2082 Currently, we only support this if the filehandle is an IO::Zlib object.
2083 Environments, like apache, will present you with an opened filehandle
2084 to an uploaded file, which might be a compressed archive.
2085
2086 =back
2087
2088 =head1 SEE ALSO
2089
2090 =over 4
2091
2092 =item The GNU tar specification
2093
2094 C<http://www.gnu.org/software/tar/manual/tar.html>
2095
2096 =item The PAX format specication
2097
2098 The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
2099
2100 =item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html>
2101
2102 =item GNU tar intends to switch to POSIX compatibility
2103
2104 GNU Tar authors have expressed their intention to become completely
2105 POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html>
2106
2107 =item A Comparison between various tar implementations
2108
2109 Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs>
2110
2111 =back
2112
2113 =head1 AUTHOR
2114
2115 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
2116
2117 Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>.
2118
2119 =head1 ACKNOWLEDGEMENTS
2120
2121 Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas,
2122 Rainer Tammer and especially Andrew Savige for their help and suggestions.
2123
2124 =head1 COPYRIGHT
2125
2126 This module is copyright (c) 2002 - 2009 Jos Boumans
2127 E<lt>kane@cpan.orgE<gt>. All rights reserved.
2128
2129 This library is free software; you may redistribute and/or modify
2130 it under the same terms as Perl itself.
2131
2132 =cut