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                 = qw[ COMPRESS_GZIP COMPRESS_BZIP ];
  31 $DEBUG                  = 0;
  32 $WARN                   = 1;
  33 $FOLLOW_SYMLINK         = 0;
  34 $VERSION                = "1.46";
  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', COMPRESS_GZIP);    # gzip compressed
  72     $tar->write('files.tbz', COMPRESS_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         ### '.' is the directory delimiter on VMS, which has to be escaped
 693         ### or changed to '_' on vms.  vmsify is used, because older versions
 694         ### of vmspath do not handle this properly.
 695         ### Must not add a '/' to an empty directory though.
 696         map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS;
 697
 698         my ($cwd_vol,$cwd_dir,$cwd_file)
 699                     = File::Spec->splitpath( $cwd );
 700         my @cwd     = File::Spec->splitdir( $cwd_dir );
 701         push @cwd, $cwd_file if length $cwd_file;
 702
 703         ### We need to pass '' as the last elemant to catpath. Craig Berry
 704         ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
 705         ### The root problem is that splitpath on UNIX always returns the
 706         ### final path element as a file even if it is a directory, and of
 707         ### course there is no way it can know the difference without checking
 708         ### against the filesystem, which it is documented as not doing.  When
 709         ### you turn around and call catpath, on VMS you have to know which bits
 710         ### are directory bits and which bits are file bits.  In this case we
 711         ### know the result should be a directory.  I had thought you could omit
 712         ### the file argument to catpath in such a case, but apparently on UNIX
 713         ### you can't.
 714         $dir        = File::Spec->catpath(
 715                             $cwd_vol, File::Spec->catdir( @cwd, @dirs ), ''
 716                         );
 717
 718         ### catdir() returns undef if the path is longer than 255 chars on
 719         ### older VMS systems.
 720         unless ( defined $dir ) {
 721             $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
 722             return;
 723         }
 724
 725     }
 726
 727     if( -e $dir && !-d _ ) {
 728         $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
 729         return;
 730     }
 731
 732     unless ( -d _ ) {
 733         eval { File::Path::mkpath( $dir, 0, 0777 ) };
 734         if( $@ ) {
 735             my $fp = $entry->full_path;
 736             $self->_error(qq[Could not create directory '$dir' for '$fp': $@]);
 737             return;
 738         }
 739
 740         ### XXX chown here? that might not be the same as in the archive
 741         ### as we're only chown'ing to the owner of the file we're extracting
 742         ### not to the owner of the directory itself, which may or may not
 743         ### be another entry in the archive
 744         ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
 745         ### way to go.
 746         #if( $CHOWN && CAN_CHOWN ) {
 747         #    chown $entry->uid, $entry->gid, $dir or
 748         #        $self->_error( qq[Could not set uid/gid on '$dir'] );
 749         #}
 750     }
 751
 752     ### we're done if we just needed to create a dir ###
 753     return 1 if $entry->is_dir;
 754
 755     my $full = File::Spec->catfile( $dir, $file );
 756
 757     if( $entry->is_unknown ) {
 758         $self->_error( qq[Unknown file type for file '$full'] );
 759         return;
 760     }
 761
 762     if( length $entry->type && $entry->is_file ) {
 763         my $fh = IO::File->new;
 764         $fh->open( '>' . $full ) or (
 765             $self->_error( qq[Could not open file '$full': $!] ),
 766             return
 767         );
 768
 769         if( $entry->size ) {
 770             binmode $fh;
 771             syswrite $fh, $entry->data or (
 772                 $self->_error( qq[Could not write data to '$full'] ),
 773                 return
 774             );
 775         }
 776
 777         close $fh or (
 778             $self->_error( qq[Could not close file '$full'] ),
 779             return
 780         );
 781
 782     } else {
 783         $self->_make_special_file( $entry, $full ) or return;
 784     }
 785
 786     ### only update the timestamp if it's not a symlink; that will change the
 787     ### timestamp of the original. This addresses bug #33669: Could not update
 788     ### timestamp warning on symlinks
 789     if( not -l $full ) {
 790         utime time, $entry->mtime - TIME_OFFSET, $full or
 791             $self->_error( qq[Could not update timestamp] );
 792     }
 793
 794     if( $CHOWN && CAN_CHOWN->() ) {
 795         chown $entry->uid, $entry->gid, $full or
 796             $self->_error( qq[Could not set uid/gid on '$full'] );
 797     }
 798
 799     ### only chmod if we're allowed to, but never chmod symlinks, since they'll
 800     ### change the perms on the file they're linking too...
 801     if( $CHMOD and not -l $full ) {
 802         chmod $entry->mode, $full or
 803             $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
 804     }
 805
 806     return 1;
 807 }
 808
 809 sub _make_special_file {
 810     my $self    = shift;
 811     my $entry   = shift     or return;
 812     my $file    = shift;    return unless defined $file;
 813
 814     my $err;
 815
 816     if( $entry->is_symlink ) {
 817         my $fail;
 818         if( ON_UNIX ) {
 819             symlink( $entry->linkname, $file ) or $fail++;
 820
 821         } else {
 822             $self->_extract_special_file_as_plain_file( $entry, $file )
 823                 or $fail++;
 824         }
 825
 826         $err =  qq[Making symbolic link '$file' to '] .
 827                 $entry->linkname .q[' failed] if $fail;
 828
 829     } elsif ( $entry->is_hardlink ) {
 830         my $fail;
 831         if( ON_UNIX ) {
 832             link( $entry->linkname, $file ) or $fail++;
 833
 834         } else {
 835             $self->_extract_special_file_as_plain_file( $entry, $file )
 836                 or $fail++;
 837         }
 838
 839         $err =  qq[Making hard link from '] . $entry->linkname .
 840                 qq[' to '$file' failed] if $fail;
 841
 842     } elsif ( $entry->is_fifo ) {
 843         ON_UNIX && !system('mknod', $file, 'p') or
 844             $err = qq[Making fifo ']. $entry->name .qq[' failed];
 845
 846     } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
 847         my $mode = $entry->is_blockdev ? 'b' : 'c';
 848
 849         ON_UNIX && !system('mknod', $file, $mode,
 850                             $entry->devmajor, $entry->devminor) or
 851             $err =  qq[Making block device ']. $entry->name .qq[' (maj=] .
 852                     $entry->devmajor . qq[ min=] . $entry->devminor .
 853                     qq[) failed.];
 854
 855     } elsif ( $entry->is_socket ) {
 856         ### the original doesn't do anything special for sockets.... ###
 857         1;
 858     }
 859
 860     return $err ? $self->_error( $err ) : 1;
 861 }
 862
 863 ### don't know how to make symlinks, let's just extract the file as
 864 ### a plain file
 865 sub _extract_special_file_as_plain_file {
 866     my $self    = shift;
 867     my $entry   = shift     or return;
 868     my $file    = shift;    return unless defined $file;
 869
 870     my $err;
 871     TRY: {
 872         my $orig = $self->_find_entry( $entry->linkname );
 873
 874         unless( $orig ) {
 875             $err =  qq[Could not find file '] . $entry->linkname .
 876                     qq[' in memory.];
 877             last TRY;
 878         }
 879
 880         ### clone the entry, make it appear as a normal file ###
 881         my $clone = $entry->clone;
 882         $clone->_downgrade_to_plainfile;
 883         $self->_extract_file( $clone, $file ) or last TRY;
 884
 885         return 1;
 886     }
 887
 888     return $self->_error($err);
 889 }
 890
 891 =head2 $tar->list_files( [\@properties] )
 892
 893 Returns a list of the names of all the files in the archive.
 894
 895 If C<list_files()> is passed an array reference as its first argument
 896 it returns a list of hash references containing the requested
 897 properties of each file.  The following list of properties is
 898 supported: name, size, mtime (last modified date), mode, uid, gid,
 899 linkname, uname, gname, devmajor, devminor, prefix.
 900
 901 Passing an array reference containing only one element, 'name', is
 902 special cased to return a list of names rather than a list of hash
 903 references, making it equivalent to calling C<list_files> without
 904 arguments.
 905
 906 =cut
 907
 908 sub list_files {
 909     my $self = shift;
 910     my $aref = shift || [ ];
 911
 912     unless( $self->_data ) {
 913         $self->read() or return;
 914     }
 915
 916     if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
 917         return map { $_->full_path } @{$self->_data};
 918     } else {
 919
 920         #my @rv;
 921         #for my $obj ( @{$self->_data} ) {
 922         #    push @rv, { map { $_ => $obj->$_() } @$aref };
 923         #}
 924         #return @rv;
 925
 926         ### this does the same as the above.. just needs a +{ }
 927         ### to make sure perl doesn't confuse it for a block
 928         return map {    my $o=$_;
 929                         +{ map { $_ => $o->$_() } @$aref }
 930                     } @{$self->_data};
 931     }
 932 }
 933
 934 sub _find_entry {
 935     my $self = shift;
 936     my $file = shift;
 937
 938     unless( defined $file ) {
 939         $self->_error( qq[No file specified] );
 940         return;
 941     }
 942
 943     ### it's an object already
 944     return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
 945
 946     for my $entry ( @{$self->_data} ) {
 947         my $path = $entry->full_path;
 948         return $entry if $path eq $file;
 949     }
 950
 951     $self->_error( qq[No such file in archive: '$file'] );
 952     return;
 953 }
 954
 955 =head2 $tar->get_files( [@filenames] )
 956
 957 Returns the C<Archive::Tar::File> objects matching the filenames
 958 provided. If no filename list was passed, all C<Archive::Tar::File>
 959 objects in the current Tar object are returned.
 960
 961 Please refer to the C<Archive::Tar::File> documentation on how to
 962 handle these objects.
 963
 964 =cut
 965
 966 sub get_files {
 967     my $self = shift;
 968
 969     return @{ $self->_data } unless @_;
 970
 971     my @list;
 972     for my $file ( @_ ) {
 973         push @list, grep { defined } $self->_find_entry( $file );
 974     }
 975
 976     return @list;
 977 }
 978
 979 =head2 $tar->get_content( $file )
 980
 981 Return the content of the named file.
 982
 983 =cut
 984
 985 sub get_content {
 986     my $self = shift;
 987     my $entry = $self->_find_entry( shift ) or return;
 988
 989     return $entry->data;
 990 }
 991
 992 =head2 $tar->replace_content( $file, $content )
 993
 994 Make the string $content be the content for the file named $file.
 995
 996 =cut
 997
 998 sub replace_content {
 999     my $self = shift;
1000     my $entry = $self->_find_entry( shift ) or return;
1001
1002     return $entry->replace_content( shift );
1003 }
1004
1005 =head2 $tar->rename( $file, $new_name )
1006
1007 Rename the file of the in-memory archive to $new_name.
1008
1009 Note that you must specify a Unix path for $new_name, since per tar
1010 standard, all files in the archive must be Unix paths.
1011
1012 Returns true on success and false on failure.
1013
1014 =cut
1015
1016 sub rename {
1017     my $self = shift;
1018     my $file = shift; return unless defined $file;
1019     my $new  = shift; return unless defined $new;
1020
1021     my $entry = $self->_find_entry( $file ) or return;
1022
1023     return $entry->rename( $new );
1024 }
1025
1026 =head2 $tar->remove (@filenamelist)
1027
1028 Removes any entries with names matching any of the given filenames
1029 from the in-memory archive. Returns a list of C<Archive::Tar::File>
1030 objects that remain.
1031
1032 =cut
1033
1034 sub remove {
1035     my $self = shift;
1036     my @list = @_;
1037
1038     my %seen = map { $_->full_path => $_ } @{$self->_data};
1039     delete $seen{ $_ } for @list;
1040
1041     $self->_data( [values %seen] );
1042
1043     return values %seen;
1044 }
1045
1046 =head2 $tar->clear
1047
1048 C<clear> clears the current in-memory archive. This effectively gives
1049 you a 'blank' object, ready to be filled again. Note that C<clear>
1050 only has effect on the object, not the underlying tarfile.
1051
1052 =cut
1053
1054 sub clear {
1055     my $self = shift or return;
1056
1057     $self->_data( [] );
1058     $self->_file( '' );
1059
1060     return 1;
1061 }
1062
1063
1064 =head2 $tar->write ( [$file, $compressed, $prefix] )
1065
1066 Write the in-memory archive to disk.  The first argument can either
1067 be the name of a file or a reference to an already open filehandle (a
1068 GLOB reference).
1069
1070 The second argument is used to indicate compression. You can either
1071 compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
1072 to be the C<gzip> compression level (between 1 and 9), but the use of
1073 constants is prefered:
1074
1075   # write a gzip compressed file
1076   $tar->write( 'out.tgz', COMPRESS_GZIP );
1077
1078   # write a bzip compressed file
1079   $tar->write( 'out.tbz', COMPRESS_BZIP );
1080
1081 Note that when you pass in a filehandle, the compression argument
1082 is ignored, as all files are printed verbatim to your filehandle.
1083 If you wish to enable compression with filehandles, use an
1084 C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
1085
1086 The third argument is an optional prefix. All files will be tucked
1087 away in the directory you specify as prefix. So if you have files
1088 'a' and 'b' in your archive, and you specify 'foo' as prefix, they
1089 will be written to the archive as 'foo/a' and 'foo/b'.
1090
1091 If no arguments are given, C<write> returns the entire formatted
1092 archive as a string, which could be useful if you'd like to stuff the
1093 archive into a socket or a pipe to gzip or something.
1094
1095
1096 =cut
1097
1098 sub write {
1099     my $self        = shift;
1100     my $file        = shift; $file = '' unless defined $file;
1101     my $gzip        = shift || 0;
1102     my $ext_prefix  = shift; $ext_prefix = '' unless defined $ext_prefix;
1103     my $dummy       = '';
1104
1105     ### only need a handle if we have a file to print to ###
1106     my $handle = length($file)
1107                     ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
1108                         or return )
1109                     : $HAS_PERLIO    ? do { open my $h, '>', \$dummy; $h }
1110                     : $HAS_IO_STRING ? IO::String->new
1111                     : __PACKAGE__->no_string_support();
1112
1113     ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a
1114     ### corrupt TAR file. Must clear out $\ to make sure no garbage is
1115     ### printed to the archive
1116     local $\;
1117
1118     for my $entry ( @{$self->_data} ) {
1119         ### entries to be written to the tarfile ###
1120         my @write_me;
1121
1122         ### only now will we change the object to reflect the current state
1123         ### of the name and prefix fields -- this needs to be limited to
1124         ### write() only!
1125         my $clone = $entry->clone;
1126
1127
1128         ### so, if you don't want use to use the prefix, we'll stuff
1129         ### everything in the name field instead
1130         if( $DO_NOT_USE_PREFIX ) {
1131
1132             ### you might have an extended prefix, if so, set it in the clone
1133             ### XXX is ::Unix right?
1134             $clone->name( length $ext_prefix
1135                             ? File::Spec::Unix->catdir( $ext_prefix,
1136                                                         $clone->full_path)
1137                             : $clone->full_path );
1138             $clone->prefix( '' );
1139
1140         ### otherwise, we'll have to set it properly -- prefix part in the
1141         ### prefix and name part in the name field.
1142         } else {
1143
1144             ### split them here, not before!
1145             my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
1146
1147             ### you might have an extended prefix, if so, set it in the clone
1148             ### XXX is ::Unix right?
1149             $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
1150                 if length $ext_prefix;
1151
1152             $clone->prefix( $prefix );
1153             $clone->name( $name );
1154         }
1155
1156         ### names are too long, and will get truncated if we don't add a
1157         ### '@LongLink' file...
1158         my $make_longlink = (   length($clone->name)    > NAME_LENGTH or
1159                                 length($clone->prefix)  > PREFIX_LENGTH
1160                             ) || 0;
1161
1162         ### perhaps we need to make a longlink file?
1163         if( $make_longlink ) {
1164             my $longlink = Archive::Tar::File->new(
1165                             data => LONGLINK_NAME,
1166                             $clone->full_path,
1167                             { type => LONGLINK }
1168                         );
1169
1170             unless( $longlink ) {
1171                 $self->_error(  qq[Could not create 'LongLink' entry for ] .
1172                                 qq[oversize file '] . $clone->full_path ."'" );
1173                 return;
1174             };
1175
1176             push @write_me, $longlink;
1177         }
1178
1179         push @write_me, $clone;
1180
1181         ### write the one, optionally 2 a::t::file objects to the handle
1182         for my $clone (@write_me) {
1183
1184             ### if the file is a symlink, there are 2 options:
1185             ### either we leave the symlink intact, but then we don't write any
1186             ### data OR we follow the symlink, which means we actually make a
1187             ### copy. if we do the latter, we have to change the TYPE of the
1188             ### clone to 'FILE'
1189             my $link_ok =  $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
1190             my $data_ok = !$clone->is_symlink && $clone->has_content;
1191
1192             ### downgrade to a 'normal' file if it's a symlink we're going to
1193             ### treat as a regular file
1194             $clone->_downgrade_to_plainfile if $link_ok;
1195
1196             ### get the header for this block
1197             my $header = $self->_format_tar_entry( $clone );
1198             unless( $header ) {
1199                 $self->_error(q[Could not format header for: ] .
1200                                     $clone->full_path );
1201                 return;
1202             }
1203
1204             unless( print $handle $header ) {
1205                 $self->_error(q[Could not write header for: ] .
1206                                     $clone->full_path);
1207                 return;
1208             }
1209
1210             if( $link_ok or $data_ok ) {
1211                 unless( print $handle $clone->data ) {
1212                     $self->_error(q[Could not write data for: ] .
1213                                     $clone->full_path);
1214                     return;
1215                 }
1216
1217                 ### pad the end of the clone if required ###
1218                 print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
1219             }
1220
1221         } ### done writing these entries
1222     }
1223
1224     ### write the end markers ###
1225     print $handle TAR_END x 2 or
1226             return $self->_error( qq[Could not write tar end markers] );
1227
1228     ### did you want it written to a file, or returned as a string? ###
1229     my $rv =  length($file) ? 1
1230                         : $HAS_PERLIO ? $dummy
1231                         : do { seek $handle, 0, 0; local $/; <$handle> };
1232
1233     ### make sure to close the handle;
1234     close $handle;
1235
1236     return $rv;
1237 }
1238
1239 sub _format_tar_entry {
1240     my $self        = shift;
1241     my $entry       = shift or return;
1242     my $ext_prefix  = shift; $ext_prefix = '' unless defined $ext_prefix;
1243     my $no_prefix   = shift || 0;
1244
1245     my $file    = $entry->name;
1246     my $prefix  = $entry->prefix; $prefix = '' unless defined $prefix;
1247
1248     ### remove the prefix from the file name
1249     ### not sure if this is still neeeded --kane
1250     ### no it's not -- Archive::Tar::File->_new_from_file will take care of
1251     ### this for us. Even worse, this would break if we tried to add a file
1252     ### like x/x.
1253     #if( length $prefix ) {
1254     #    $file =~ s/^$match//;
1255     #}
1256
1257     $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
1258                 if length $ext_prefix;
1259
1260     ### not sure why this is... ###
1261     my $l = PREFIX_LENGTH; # is ambiguous otherwise...
1262     substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
1263
1264     my $f1 = "%06o"; my $f2  = "%11o";
1265
1266     ### this might be optimizable with a 'changed' flag in the file objects ###
1267     my $tar = pack (
1268                 PACK,
1269                 $file,
1270
1271                 (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
1272                 (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
1273
1274                 "",  # checksum field - space padded a bit down
1275
1276                 (map { $entry->$_() }                 qw[type linkname magic]),
1277
1278                 $entry->version || TAR_VERSION,
1279
1280                 (map { $entry->$_() }                 qw[uname gname]),
1281                 (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
1282
1283                 ($no_prefix ? '' : $prefix)
1284     );
1285
1286     ### add the checksum ###
1287     substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
1288
1289     return $tar;
1290 }
1291
1292 =head2 $tar->add_files( @filenamelist )
1293
1294 Takes a list of filenames and adds them to the in-memory archive.
1295
1296 The path to the file is automatically converted to a Unix like
1297 equivalent for use in the archive, and, if on MacOS, the file's
1298 modification time is converted from the MacOS epoch to the Unix epoch.
1299 So tar archives created on MacOS with B<Archive::Tar> can be read
1300 both with I<tar> on Unix and applications like I<suntar> or
1301 I<Stuffit Expander> on MacOS.
1302
1303 Be aware that the file's type/creator and resource fork will be lost,
1304 which is usually what you want in cross-platform archives.
1305
1306 Instead of a filename, you can also pass it an existing C<Archive::Tar::File>
1307 object from, for example, another archive. The object will be clone, and
1308 effectively be a copy of the original, not an alias.
1309
1310 Returns a list of C<Archive::Tar::File> objects that were just added.
1311
1312 =cut
1313
1314 sub add_files {
1315     my $self    = shift;
1316     my @files   = @_ or return;
1317
1318     my @rv;
1319     for my $file ( @files ) {
1320
1321         ### you passed an Archive::Tar::File object
1322         ### clone it so we don't accidentally have a reference to
1323         ### an object from another archive
1324         if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) {
1325             push @rv, $file->clone;
1326             next;
1327         }
1328
1329         unless( -e $file || -l $file ) {
1330             $self->_error( qq[No such file: '$file'] );
1331             next;
1332         }
1333
1334         my $obj = Archive::Tar::File->new( file => $file );
1335         unless( $obj ) {
1336             $self->_error( qq[Unable to add file: '$file'] );
1337             next;
1338         }
1339
1340         push @rv, $obj;
1341     }
1342
1343     push @{$self->{_data}}, @rv;
1344
1345     return @rv;
1346 }
1347
1348 =head2 $tar->add_data ( $filename, $data, [$opthashref] )
1349
1350 Takes a filename, a scalar full of data and optionally a reference to
1351 a hash with specific options.
1352
1353 Will add a file to the in-memory archive, with name C<$filename> and
1354 content C<$data>. Specific properties can be set using C<$opthashref>.
1355 The following list of properties is supported: name, size, mtime
1356 (last modified date), mode, uid, gid, linkname, uname, gname,
1357 devmajor, devminor, prefix, type.  (On MacOS, the file's path and
1358 modification times are converted to Unix equivalents.)
1359
1360 Valid values for the file type are the following constants defined in
1361 Archive::Tar::Constants:
1362
1363 =over 4
1364
1365 =item FILE
1366
1367 Regular file.
1368
1369 =item HARDLINK
1370
1371 =item SYMLINK
1372
1373 Hard and symbolic ("soft") links; linkname should specify target.
1374
1375 =item CHARDEV
1376
1377 =item BLOCKDEV
1378
1379 Character and block devices. devmajor and devminor should specify the major
1380 and minor device numbers.
1381
1382 =item DIR
1383
1384 Directory.
1385
1386 =item FIFO
1387
1388 FIFO (named pipe).
1389
1390 =item SOCKET
1391
1392 Socket.
1393
1394 =back
1395
1396 Returns the C<Archive::Tar::File> object that was just added, or
1397 C<undef> on failure.
1398
1399 =cut
1400
1401 sub add_data {
1402     my $self    = shift;
1403     my ($file, $data, $opt) = @_;
1404
1405     my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
1406     unless( $obj ) {
1407         $self->_error( qq[Unable to add file: '$file'] );
1408         return;
1409     }
1410
1411     push @{$self->{_data}}, $obj;
1412
1413     return $obj;
1414 }
1415
1416 =head2 $tar->error( [$BOOL] )
1417
1418 Returns the current errorstring (usually, the last error reported).
1419 If a true value was specified, it will give the C<Carp::longmess>
1420 equivalent of the error, in effect giving you a stacktrace.
1421
1422 For backwards compatibility, this error is also available as
1423 C<$Archive::Tar::error> although it is much recommended you use the
1424 method call instead.
1425
1426 =cut
1427
1428 {
1429     $error = '';
1430     my $longmess;
1431
1432     sub _error {
1433         my $self    = shift;
1434         my $msg     = $error = shift;
1435         $longmess   = Carp::longmess($error);
1436
1437         ### set Archive::Tar::WARN to 0 to disable printing
1438         ### of errors
1439         if( $WARN ) {
1440             carp $DEBUG ? $longmess : $msg;
1441         }
1442
1443         return;
1444     }
1445
1446     sub error {
1447         my $self = shift;
1448         return shift() ? $longmess : $error;
1449     }
1450 }
1451
1452 =head2 $tar->setcwd( $cwd );
1453
1454 C<Archive::Tar> needs to know the current directory, and it will run
1455 C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
1456 tarfile and saves it in the file system. (As of version 1.30, however,
1457 C<Archive::Tar> will use the speed optimization described below
1458 automatically, so it's only relevant if you're using C<extract_file()>).
1459
1460 Since C<Archive::Tar> doesn't change the current directory internally
1461 while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
1462 can be avoided if we can guarantee that the current directory doesn't
1463 get changed externally.
1464
1465 To use this performance boost, set the current directory via
1466
1467     use Cwd;
1468     $tar->setcwd( cwd() );
1469
1470 once before calling a function like C<extract_file> and
1471 C<Archive::Tar> will use the current directory setting from then on
1472 and won't call C<Cwd::cwd()> internally.
1473
1474 To switch back to the default behaviour, use
1475
1476     $tar->setcwd( undef );
1477
1478 and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
1479
1480 If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
1481 be called for you.
1482
1483 =cut
1484
1485 sub setcwd {
1486     my $self     = shift;
1487     my $cwd      = shift;
1488
1489     $self->{cwd} = $cwd;
1490 }
1491
1492 =head1 Class Methods
1493
1494 =head2 Archive::Tar->create_archive($file, $compressed, @filelist)
1495
1496 Creates a tar file from the list of files provided.  The first
1497 argument can either be the name of the tar file to create or a
1498 reference to an open file handle (e.g. a GLOB reference).
1499
1500 The second argument is used to indicate compression. You can either
1501 compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
1502 to be the C<gzip> compression level (between 1 and 9), but the use of
1503 constants is prefered:
1504
1505   # write a gzip compressed file
1506   Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist );
1507
1508   # write a bzip compressed file
1509   Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist );
1510
1511 Note that when you pass in a filehandle, the compression argument
1512 is ignored, as all files are printed verbatim to your filehandle.
1513 If you wish to enable compression with filehandles, use an
1514 C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead.
1515
1516 The remaining arguments list the files to be included in the tar file.
1517 These files must all exist. Any files which don't exist or can't be
1518 read are silently ignored.
1519
1520 If the archive creation fails for any reason, C<create_archive> will
1521 return false. Please use the C<error> method to find the cause of the
1522 failure.
1523
1524 Note that this method does not write C<on the fly> as it were; it
1525 still reads all the files into memory before writing out the archive.
1526 Consult the FAQ below if this is a problem.
1527
1528 =cut
1529
1530 sub create_archive {
1531     my $class = shift;
1532
1533     my $file    = shift; return unless defined $file;
1534     my $gzip    = shift || 0;
1535     my @files   = @_;
1536
1537     unless( @files ) {
1538         return $class->_error( qq[Cowardly refusing to create empty archive!] );
1539     }
1540
1541     my $tar = $class->new;
1542     $tar->add_files( @files );
1543     return $tar->write( $file, $gzip );
1544 }
1545
1546 =head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] )
1547
1548 Returns an iterator function that reads the tar file without loading
1549 it all in memory.  Each time the function is called it will return the
1550 next file in the tarball. The files are returned as
1551 C<Archive::Tar::File> objects. The iterator function returns the
1552 empty list once it has exhausted the the files contained.
1553
1554 The second argument can be a hash reference with options, which are
1555 identical to the arguments passed to C<read()>.
1556
1557 Example usage:
1558
1559     my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} );
1560
1561     while( my $f = $next->() ) {
1562         print $f->name, "\n";
1563
1564         $f->extract or warn "Extraction failed";
1565
1566         # ....
1567     }
1568
1569 =cut
1570
1571
1572 sub iter {
1573     my $class       = shift;
1574     my $filename    = shift or return;
1575     my $compressed  = shift or 0;
1576     my $opts        = shift || {};
1577
1578     ### get a handle to read from.
1579     my $handle = $class->_get_handle(
1580         $filename,
1581         $compressed,
1582         READ_ONLY->( ZLIB )
1583     ) or return;
1584
1585     my @data;
1586     return sub {
1587         return shift(@data)     if @data;       # more than one file returned?
1588         return                  unless $handle; # handle exhausted?
1589
1590         ### read data, should only return file
1591         @data = @{ $class->_read_tar($handle, { %$opts, limit => 1 }) };
1592
1593         ### return one piece of data
1594         return shift(@data)     if @data;
1595
1596         ### data is exhausted, free the filehandle
1597         undef $handle;
1598         return;
1599     };
1600 }
1601
1602 =head2 Archive::Tar->list_archive($file, $compressed, [\@properties])
1603
1604 Returns a list of the names of all the files in the archive.  The
1605 first argument can either be the name of the tar file to list or a
1606 reference to an open file handle (e.g. a GLOB reference).
1607
1608 If C<list_archive()> is passed an array reference as its third
1609 argument it returns a list of hash references containing the requested
1610 properties of each file.  The following list of properties is
1611 supported: full_path, name, size, mtime (last modified date), mode,
1612 uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
1613
1614 See C<Archive::Tar::File> for details about supported properties.
1615
1616 Passing an array reference containing only one element, 'name', is
1617 special cased to return a list of names rather than a list of hash
1618 references.
1619
1620 =cut
1621
1622 sub list_archive {
1623     my $class   = shift;
1624     my $file    = shift; return unless defined $file;
1625     my $gzip    = shift || 0;
1626
1627     my $tar = $class->new($file, $gzip);
1628     return unless $tar;
1629
1630     return $tar->list_files( @_ );
1631 }
1632
1633 =head2 Archive::Tar->extract_archive($file, $compressed)
1634
1635 Extracts the contents of the tar file.  The first argument can either
1636 be the name of the tar file to create or a reference to an open file
1637 handle (e.g. a GLOB reference).  All relative paths in the tar file will
1638 be created underneath the current working directory.
1639
1640 C<extract_archive> will return a list of files it extracted.
1641 If the archive extraction fails for any reason, C<extract_archive>
1642 will return false.  Please use the C<error> method to find the cause
1643 of the failure.
1644
1645 =cut
1646
1647 sub extract_archive {
1648     my $class   = shift;
1649     my $file    = shift; return unless defined $file;
1650     my $gzip    = shift || 0;
1651
1652     my $tar = $class->new( ) or return;
1653
1654     return $tar->read( $file, $gzip, { extract => 1 } );
1655 }
1656
1657 =head2 $bool = Archive::Tar->has_io_string
1658
1659 Returns true if we currently have C<IO::String> support loaded.
1660
1661 Either C<IO::String> or C<perlio> support is needed to support writing
1662 stringified archives. Currently, C<perlio> is the preferred method, if
1663 available.
1664
1665 See the C<GLOBAL VARIABLES> section to see how to change this preference.
1666
1667 =cut
1668
1669 sub has_io_string { return $HAS_IO_STRING; }
1670
1671 =head2 $bool = Archive::Tar->has_perlio
1672
1673 Returns true if we currently have C<perlio> support loaded.
1674
1675 This requires C<perl-5.8> or higher, compiled with C<perlio>
1676
1677 Either C<IO::String> or C<perlio> support is needed to support writing
1678 stringified archives. Currently, C<perlio> is the preferred method, if
1679 available.
1680
1681 See the C<GLOBAL VARIABLES> section to see how to change this preference.
1682
1683 =cut
1684
1685 sub has_perlio { return $HAS_PERLIO; }
1686
1687 =head2 $bool = Archive::Tar->has_zlib_support
1688
1689 Returns true if C<Archive::Tar> can extract C<zlib> compressed archives
1690
1691 =cut
1692
1693 sub has_zlib_support { return ZLIB }
1694
1695 =head2 $bool = Archive::Tar->has_bzip2_support
1696
1697 Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives
1698
1699 =cut
1700
1701 sub has_bzip2_support { return BZIP }
1702
1703 =head2 Archive::Tar->can_handle_compressed_files
1704
1705 A simple checking routine, which will return true if C<Archive::Tar>
1706 is able to uncompress compressed archives on the fly with C<IO::Zlib>
1707 and C<IO::Compress::Bzip2> or false if not both are installed.
1708
1709 You can use this as a shortcut to determine whether C<Archive::Tar>
1710 will do what you think before passing compressed archives to its
1711 C<read> method.
1712
1713 =cut
1714
1715 sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 }
1716
1717 sub no_string_support {
1718     croak("You have to install IO::String to support writing archives to strings");
1719 }
1720
1721 1;
1722
1723 __END__
1724
1725 =head1 GLOBAL VARIABLES
1726
1727 =head2 $Archive::Tar::FOLLOW_SYMLINK
1728
1729 Set this variable to C<1> to make C<Archive::Tar> effectively make a
1730 copy of the file when extracting. Default is C<0>, which
1731 means the symlink stays intact. Of course, you will have to pack the
1732 file linked to as well.
1733
1734 This option is checked when you write out the tarfile using C<write>
1735 or C<create_archive>.
1736
1737 This works just like C</bin/tar>'s C<-h> option.
1738
1739 =head2 $Archive::Tar::CHOWN
1740
1741 By default, C<Archive::Tar> will try to C<chown> your files if it is
1742 able to. In some cases, this may not be desired. In that case, set
1743 this variable to C<0> to disable C<chown>-ing, even if it were
1744 possible.
1745
1746 The default is C<1>.
1747
1748 =head2 $Archive::Tar::CHMOD
1749
1750 By default, C<Archive::Tar> will try to C<chmod> your files to
1751 whatever mode was specified for the particular file in the archive.
1752 In some cases, this may not be desired. In that case, set this
1753 variable to C<0> to disable C<chmod>-ing.
1754
1755 The default is C<1>.
1756
1757 =head2 $Archive::Tar::DO_NOT_USE_PREFIX
1758
1759 By default, C<Archive::Tar> will try to put paths that are over
1760 100 characters in the C<prefix> field of your tar header, as
1761 defined per POSIX-standard. However, some (older) tar programs
1762 do not implement this spec. To retain compatibility with these older
1763 or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
1764 variable to a true value, and C<Archive::Tar> will use an alternate
1765 way of dealing with paths over 100 characters by using the
1766 C<GNU Extended Header> feature.
1767
1768 Note that clients who do not support the C<GNU Extended Header>
1769 feature will not be able to read these archives. Such clients include
1770 tars on C<Solaris>, C<Irix> and C<AIX>.
1771
1772 The default is C<0>.
1773
1774 =head2 $Archive::Tar::DEBUG
1775
1776 Set this variable to C<1> to always get the C<Carp::longmess> output
1777 of the warnings, instead of the regular C<carp>. This is the same
1778 message you would get by doing:
1779
1780     $tar->error(1);
1781
1782 Defaults to C<0>.
1783
1784 =head2 $Archive::Tar::WARN
1785
1786 Set this variable to C<0> if you do not want any warnings printed.
1787 Personally I recommend against doing this, but people asked for the
1788 option. Also, be advised that this is of course not threadsafe.
1789
1790 Defaults to C<1>.
1791
1792 =head2 $Archive::Tar::error
1793
1794 Holds the last reported error. Kept for historical reasons, but its
1795 use is very much discouraged. Use the C<error()> method instead:
1796
1797     warn $tar->error unless $tar->extract;
1798
1799 =head2 $Archive::Tar::INSECURE_EXTRACT_MODE
1800
1801 This variable indicates whether C<Archive::Tar> should allow
1802 files to be extracted outside their current working directory.
1803
1804 Allowing this could have security implications, as a malicious
1805 tar archive could alter or replace any file the extracting user
1806 has permissions to. Therefor, the default is to not allow
1807 insecure extractions.
1808
1809 If you trust the archive, or have other reasons to allow the
1810 archive to write files outside your current working directory,
1811 set this variable to C<true>.
1812
1813 Note that this is a backwards incompatible change from version
1814 C<1.36> and before.
1815
1816 =head2 $Archive::Tar::HAS_PERLIO
1817
1818 This variable holds a boolean indicating if we currently have
1819 C<perlio> support loaded. This will be enabled for any perl
1820 greater than C<5.8> compiled with C<perlio>.
1821
1822 If you feel strongly about disabling it, set this variable to
1823 C<false>. Note that you will then need C<IO::String> installed
1824 to support writing stringified archives.
1825
1826 Don't change this variable unless you B<really> know what you're
1827 doing.
1828
1829 =head2 $Archive::Tar::HAS_IO_STRING
1830
1831 This variable holds a boolean indicating if we currently have
1832 C<IO::String> support loaded. This will be enabled for any perl
1833 that has a loadable C<IO::String> module.
1834
1835 If you feel strongly about disabling it, set this variable to
1836 C<false>. Note that you will then need C<perlio> support from
1837 your perl to be able to  write stringified archives.
1838
1839 Don't change this variable unless you B<really> know what you're
1840 doing.
1841
1842 =head1 FAQ
1843
1844 =over 4
1845
1846 =item What's the minimum perl version required to run Archive::Tar?
1847
1848 You will need perl version 5.005_03 or newer.
1849
1850 =item Isn't Archive::Tar slow?
1851
1852 Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar>
1853 However, it's very portable. If speed is an issue, consider using
1854 C</bin/tar> instead.
1855
1856 =item Isn't Archive::Tar heavier on memory than /bin/tar?
1857
1858 Yes it is, see previous answer. Since C<Compress::Zlib> and therefore
1859 C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
1860 choice but to read the archive into memory.
1861 This is ok if you want to do in-memory manipulation of the archive.
1862
1863 If you just want to extract, use the C<extract_archive> class method
1864 instead. It will optimize and write to disk immediately.
1865
1866 Another option is to use the C<iter> class method to iterate over
1867 the files in the tarball without reading them all in memory at once.
1868
1869 =item Can you lazy-load data instead?
1870
1871 In some cases, yes. You can use the C<iter> class method to iterate
1872 over the files in the tarball without reading them all in memory at once.
1873
1874 =item How much memory will an X kb tar file need?
1875
1876 Probably more than X kb, since it will all be read into memory. If
1877 this is a problem, and you don't need to do in memory manipulation
1878 of the archive, consider using the C<iter> class method, or C</bin/tar>
1879 instead.
1880
1881 =item What do you do with unsupported filetypes in an archive?
1882
1883 C<Unix> has a few filetypes that aren't supported on other platforms,
1884 like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just
1885 try to make a copy of the original file, rather than throwing an error.
1886
1887 This does require you to read the entire archive in to memory first,
1888 since otherwise we wouldn't know what data to fill the copy with.
1889 (This means that you cannot use the class methods, including C<iter>
1890 on archives that have incompatible filetypes and still expect things
1891 to work).
1892
1893 For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
1894 the extraction of this particular item didn't work.
1895
1896 =item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly!
1897
1898 By default, C<Archive::Tar> is in a completely POSIX-compatible
1899 mode, which uses the POSIX-specification of C<tar> to store files.
1900 For paths greather than 100 characters, this is done using the
1901 C<POSIX header prefix>. Non-POSIX-compatible clients may not support
1902 this part of the specification, and may only support the C<GNU Extended
1903 Header> functionality. To facilitate those clients, you can set the
1904 C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
1905 C<GLOBAL VARIABLES> section for details on this variable.
1906
1907 Note that GNU tar earlier than version 1.14 does not cope well with
1908 the C<POSIX header prefix>. If you use such a version, consider setting
1909 the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>.
1910
1911 =item How do I extract only files that have property X from an archive?
1912
1913 Sometimes, you might not wish to extract a complete archive, just
1914 the files that are relevant to you, based on some criteria.
1915
1916 You can do this by filtering a list of C<Archive::Tar::File> objects
1917 based on your criteria. For example, to extract only files that have
1918 the string C<foo> in their title, you would use:
1919
1920     $tar->extract(
1921         grep { $_->full_path =~ /foo/ } $tar->get_files
1922     );
1923
1924 This way, you can filter on any attribute of the files in the archive.
1925 Consult the C<Archive::Tar::File> documentation on how to use these
1926 objects.
1927
1928 =item How do I access .tar.Z files?
1929
1930 The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
1931 the C<IO::Zlib> module) to access tar files that have been compressed
1932 with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
1933 utility cannot be read by C<Compress::Zlib> and so cannot be directly
1934 accesses by C<Archive::Tar>.
1935
1936 If the C<uncompress> or C<gunzip> programs are available, you can use
1937 one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
1938
1939 Firstly with C<uncompress>
1940
1941     use Archive::Tar;
1942
1943     open F, "uncompress -c $filename |";
1944     my $tar = Archive::Tar->new(*F);
1945     ...
1946
1947 and this with C<gunzip>
1948
1949     use Archive::Tar;
1950
1951     open F, "gunzip -c $filename |";
1952     my $tar = Archive::Tar->new(*F);
1953     ...
1954
1955 Similarly, if the C<compress> program is available, you can use this to
1956 write a C<.tar.Z> file
1957
1958     use Archive::Tar;
1959     use IO::File;
1960
1961     my $fh = new IO::File "| compress -c >$filename";
1962     my $tar = Archive::Tar->new();
1963     ...
1964     $tar->write($fh);
1965     $fh->close ;
1966
1967 =item How do I handle Unicode strings?
1968
1969 C<Archive::Tar> uses byte semantics for any files it reads from or writes
1970 to disk. This is not a problem if you only deal with files and never
1971 look at their content or work solely with byte strings. But if you use
1972 Unicode strings with character semantics, some additional steps need
1973 to be taken.
1974
1975 For example, if you add a Unicode string like
1976
1977     # Problem
1978     $tar->add_data('file.txt', "Euro: \x{20AC}");
1979
1980 then there will be a problem later when the tarfile gets written out
1981 to disk via C<$tar->write()>:
1982
1983     Wide character in print at .../Archive/Tar.pm line 1014.
1984
1985 The data was added as a Unicode string and when writing it out to disk,
1986 the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl
1987 tried to convert the string to ISO-8859 and failed. The written file
1988 now contains garbage.
1989
1990 For this reason, Unicode strings need to be converted to UTF-8-encoded
1991 bytestrings before they are handed off to C<add_data()>:
1992
1993     use Encode;
1994     my $data = "Accented character: \x{20AC}";
1995     $data = encode('utf8', $data);
1996
1997     $tar->add_data('file.txt', $data);
1998
1999 A opposite problem occurs if you extract a UTF8-encoded file from a
2000 tarball. Using C<get_content()> on the C<Archive::Tar::File> object
2001 will return its content as a bytestring, not as a Unicode string.
2002
2003 If you want it to be a Unicode string (because you want character
2004 semantics with operations like regular expression matching), you need
2005 to decode the UTF8-encoded content and have Perl convert it into
2006 a Unicode string:
2007
2008     use Encode;
2009     my $data = $tar->get_content();
2010
2011     # Make it a Unicode string
2012     $data = decode('utf8', $data);
2013
2014 There is no easy way to provide this functionality in C<Archive::Tar>,
2015 because a tarball can contain many files, and each of which could be
2016 encoded in a different way.
2017
2018 =back
2019
2020 =head1 TODO
2021
2022 =over 4
2023
2024 =item Check if passed in handles are open for read/write
2025
2026 Currently I don't know of any portable pure perl way to do this.
2027 Suggestions welcome.
2028
2029 =item Allow archives to be passed in as string
2030
2031 Currently, we only allow opened filehandles or filenames, but
2032 not strings. The internals would need some reworking to facilitate
2033 stringified archives.
2034
2035 =item Facilitate processing an opened filehandle of a compressed archive
2036
2037 Currently, we only support this if the filehandle is an IO::Zlib object.
2038 Environments, like apache, will present you with an opened filehandle
2039 to an uploaded file, which might be a compressed archive.
2040
2041 =back
2042
2043 =head1 SEE ALSO
2044
2045 =over 4
2046
2047 =item The GNU tar specification
2048
2049 C<http://www.gnu.org/software/tar/manual/tar.html>
2050
2051 =item The PAX format specication
2052
2053 The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
2054
2055 =item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html>
2056
2057 =item GNU tar intends to switch to POSIX compatibility
2058
2059 GNU Tar authors have expressed their intention to become completely
2060 POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html>
2061
2062 =item A Comparison between various tar implementations
2063
2064 Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs>
2065
2066 =back
2067
2068 =head1 AUTHOR
2069
2070 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
2071
2072 Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>.
2073
2074 =head1 ACKNOWLEDGEMENTS
2075
2076 Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas
2077 and especially Andrew Savige for their help and suggestions.
2078
2079 =head1 COPYRIGHT
2080
2081 This module is copyright (c) 2002 - 2008 Jos Boumans
2082 E<lt>kane@cpan.orgE<gt>. All rights reserved.
2083
2084 This library is free software; you may redistribute and/or modify
2085 it under the same terms as Perl itself.
2086
2087 =cut