lib/Archive/Tar.pm

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