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