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 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.34_01";
  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 up 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;
 410
 411     return unless defined $full;
 412
 413     ### don't warn if the entry isn't there.. that's what this function
 414     ### is for after all.
 415     local $WARN = 0;
 416     return 1 if $self->_find_entry($full);
 417     return;
 418 }
 419
 420 =head2 $tar->extract( [@filenames] )
 421
 422 Write files whose names are equivalent to any of the names in
 423 C<@filenames> to disk, creating subdirectories as necessary. This
 424 might not work too well under VMS.
 425 Under MacPerl, the file's modification time will be converted to the
 426 MacOS zero of time, and appropriate conversions will be done to the
 427 path.  However, the length of each element of the path is not
 428 inspected to see whether it's longer than MacOS currently allows (32
 429 characters).
 430
 431 If C<extract> is called without a list of file names, the entire
 432 contents of the archive are extracted.
 433
 434 Returns a list of filenames extracted.
 435
 436 =cut
 437
 438 sub extract {
 439     my $self    = shift;
 440     my @args    = @_;
 441     my @files;
 442
 443     # use the speed optimization for all extracted files
 444     local($self->{cwd}) = cwd() unless $self->{cwd};
 445
 446     ### you requested the extraction of only certian files
 447     if( @args ) {
 448         for my $file ( @args ) {
 449
 450             ### it's already an object?
 451             if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) {
 452                 push @files, $file;
 453                 next;
 454
 455             ### go find it then
 456             } else {
 457
 458                 my $found;
 459                 for my $entry ( @{$self->_data} ) {
 460                     next unless $file eq $entry->full_path;
 461
 462                     ### we found the file you're looking for
 463                     push @files, $entry;
 464                     $found++;
 465                 }
 466
 467                 unless( $found ) {
 468                     return $self->_error(
 469                         qq[Could not find '$file' in archive] );
 470                 }
 471             }
 472         }
 473
 474     ### just grab all the file items
 475     } else {
 476         @files = $self->get_files;
 477     }
 478
 479     ### nothing found? that's an error
 480     unless( scalar @files ) {
 481         $self->_error( qq[No files found for ] . $self->_file );
 482         return;
 483     }
 484
 485     ### now extract them
 486     for my $entry ( @files ) {
 487         unless( $self->_extract_file( $entry ) ) {
 488             $self->_error(q[Could not extract ']. $entry->full_path .q['] );
 489             return;
 490         }
 491     }
 492
 493     return @files;
 494 }
 495
 496 =head2 $tar->extract_file( $file, [$extract_path] )
 497
 498 Write an entry, whose name is equivalent to the file name provided to
 499 disk. Optionally takes a second parameter, which is the full native
 500 path (including filename) the entry will be written to.
 501
 502 For example:
 503
 504     $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );
 505
 506     $tar->extract_file( $at_file_object,   'name/i/want/to/give/it' );
 507
 508 Returns true on success, false on failure.
 509
 510 =cut
 511
 512 sub extract_file {
 513     my $self = shift;
 514     my $file = shift;   return unless defined $file;
 515     my $alt  = shift;
 516
 517     my $entry = $self->_find_entry( $file )
 518         or $self->_error( qq[Could not find an entry for '$file'] ), return;
 519
 520     return $self->_extract_file( $entry, $alt );
 521 }
 522
 523 sub _extract_file {
 524     my $self    = shift;
 525     my $entry   = shift or return;
 526     my $alt     = shift;
 527
 528     ### you wanted an alternate extraction location ###
 529     my $name = defined $alt ? $alt : $entry->full_path;
 530
 531                             ### splitpath takes a bool at the end to indicate
 532                             ### that it's splitting a dir
 533     my ($vol,$dirs,$file);
 534     if ( defined $alt ) { # It's a local-OS path
 535         ($vol,$dirs,$file) = File::Spec->splitpath(       $alt,
 536                                                           $entry->is_dir );
 537     } else {
 538         ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
 539                                                           $entry->is_dir );
 540     }
 541
 542     my $dir;
 543     ### is $name an absolute path? ###
 544     if( File::Spec->file_name_is_absolute( $dirs ) ) {
 545         $dir = $dirs;
 546
 547     ### it's a relative path ###
 548     } else {
 549         my $cwd     = (defined $self->{cwd} ? $self->{cwd} : cwd());
 550         my @dirs;
 551         if ( defined $alt ) { # It's a local-OS path
 552             @dirs   = File::Spec->splitdir( $dirs );
 553         } else {              # it's UNIX-style, likely straight from the tarball
 554             @dirs   = File::Spec::Unix->splitdir( $dirs );
 555         }
 556         map tr/\./_/, @dirs if $^O eq 'VMS'; # '.' is the directory delimiter
 557         my ($cwd_vol,$cwd_dir,$cwd_file)
 558                     = File::Spec->splitpath( $cwd );
 559         my @cwd     = File::Spec->splitdir( $cwd_dir );
 560         push @cwd, $cwd_file if length $cwd_file;
 561         $dir        = File::Spec->catpath( $cwd_vol, File::Spec->catdir( @cwd, @dirs ) );
 562
 563         # catdir() returns undef if the path is longer than 255 chars on VMS
 564         unless ( defined $dir ) {
 565             $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
 566             return;
 567         }
 568
 569     }
 570
 571     if( -e $dir && !-d _ ) {
 572         $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
 573         return;
 574     }
 575
 576     unless ( -d _ ) {
 577         eval { File::Path::mkpath( $dir, 0, 0777 ) };
 578         if( $@ ) {
 579             $self->_error( qq[Could not create directory '$dir': $@] );
 580             return;
 581         }
 582
 583         ### XXX chown here? that might not be the same as in the archive
 584         ### as we're only chown'ing to the owner of the file we're extracting
 585         ### not to the owner of the directory itself, which may or may not
 586         ### be another entry in the archive
 587         ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
 588         ### way to go.
 589         #if( $CHOWN && CAN_CHOWN ) {
 590         #    chown $entry->uid, $entry->gid, $dir or
 591         #        $self->_error( qq[Could not set uid/gid on '$dir'] );
 592         #}
 593     }
 594
 595     ### we're done if we just needed to create a dir ###
 596     return 1 if $entry->is_dir;
 597
 598     my $full = File::Spec->catfile( $dir, $file );
 599
 600     if( $entry->is_unknown ) {
 601         $self->_error( qq[Unknown file type for file '$full'] );
 602         return;
 603     }
 604
 605     if( length $entry->type && $entry->is_file ) {
 606         my $fh = IO::File->new;
 607         $fh->open( '>' . $full ) or (
 608             $self->_error( qq[Could not open file '$full': $!] ),
 609             return
 610         );
 611
 612         if( $entry->size ) {
 613             binmode $fh;
 614             syswrite $fh, $entry->data or (
 615                 $self->_error( qq[Could not write data to '$full'] ),
 616                 return
 617             );
 618         }
 619
 620         close $fh or (
 621             $self->_error( qq[Could not close file '$full'] ),
 622             return
 623         );
 624
 625     } else {
 626         $self->_make_special_file( $entry, $full ) or return;
 627     }
 628
 629     utime time, $entry->mtime - TIME_OFFSET, $full or
 630         $self->_error( qq[Could not update timestamp] );
 631
 632     if( $CHOWN && CAN_CHOWN ) {
 633         chown $entry->uid, $entry->gid, $full or
 634             $self->_error( qq[Could not set uid/gid on '$full'] );
 635     }
 636
 637     ### only chmod if we're allowed to, but never chmod symlinks, since they'll
 638     ### change the perms on the file they're linking too...
 639     if( $CHMOD and not -l $full ) {
 640         chmod $entry->mode, $full or
 641             $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
 642     }
 643
 644     return 1;
 645 }
 646
 647 sub _make_special_file {
 648     my $self    = shift;
 649     my $entry   = shift     or return;
 650     my $file    = shift;    return unless defined $file;
 651
 652     my $err;
 653
 654     if( $entry->is_symlink ) {
 655         my $fail;
 656         if( ON_UNIX ) {
 657             symlink( $entry->linkname, $file ) or $fail++;
 658
 659         } else {
 660             $self->_extract_special_file_as_plain_file( $entry, $file )
 661                 or $fail++;
 662         }
 663
 664         $err =  qq[Making symbolink link from '] . $entry->linkname .
 665                 qq[' to '$file' failed] if $fail;
 666
 667     } elsif ( $entry->is_hardlink ) {
 668         my $fail;
 669         if( ON_UNIX ) {
 670             link( $entry->linkname, $file ) or $fail++;
 671
 672         } else {
 673             $self->_extract_special_file_as_plain_file( $entry, $file )
 674                 or $fail++;
 675         }
 676
 677         $err =  qq[Making hard link from '] . $entry->linkname .
 678                 qq[' to '$file' failed] if $fail;
 679
 680     } elsif ( $entry->is_fifo ) {
 681         ON_UNIX && !system('mknod', $file, 'p') or
 682             $err = qq[Making fifo ']. $entry->name .qq[' failed];
 683
 684     } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
 685         my $mode = $entry->is_blockdev ? 'b' : 'c';
 686
 687         ON_UNIX && !system('mknod', $file, $mode,
 688                             $entry->devmajor, $entry->devminor) or
 689             $err =  qq[Making block device ']. $entry->name .qq[' (maj=] .
 690                     $entry->devmajor . qq[ min=] . $entry->devminor .
 691                     qq[) failed.];
 692
 693     } elsif ( $entry->is_socket ) {
 694         ### the original doesn't do anything special for sockets.... ###
 695         1;
 696     }
 697
 698     return $err ? $self->_error( $err ) : 1;
 699 }
 700
 701 ### don't know how to make symlinks, let's just extract the file as
 702 ### a plain file
 703 sub _extract_special_file_as_plain_file {
 704     my $self    = shift;
 705     my $entry   = shift     or return;
 706     my $file    = shift;    return unless defined $file;
 707
 708     my $err;
 709     TRY: {
 710         my $orig = $self->_find_entry( $entry->linkname );
 711
 712         unless( $orig ) {
 713             $err =  qq[Could not find file '] . $entry->linkname .
 714                     qq[' in memory.];
 715             last TRY;
 716         }
 717
 718         ### clone the entry, make it appear as a normal file ###
 719         my $clone = $entry->clone;
 720         $clone->_downgrade_to_plainfile;
 721         $self->_extract_file( $clone, $file ) or last TRY;
 722
 723         return 1;
 724     }
 725
 726     return $self->_error($err);
 727 }
 728
 729 =head2 $tar->list_files( [\@properties] )
 730
 731 Returns a list of the names of all the files in the archive.
 732
 733 If C<list_files()> is passed an array reference as its first argument
 734 it returns a list of hash references containing the requested
 735 properties of each file.  The following list of properties is
 736 supported: name, size, mtime (last modified date), mode, uid, gid,
 737 linkname, uname, gname, devmajor, devminor, prefix.
 738
 739 Passing an array reference containing only one element, 'name', is
 740 special cased to return a list of names rather than a list of hash
 741 references, making it equivalent to calling C<list_files> without
 742 arguments.
 743
 744 =cut
 745
 746 sub list_files {
 747     my $self = shift;
 748     my $aref = shift || [ ];
 749
 750     unless( $self->_data ) {
 751         $self->read() or return;
 752     }
 753
 754     if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
 755         return map { $_->full_path } @{$self->_data};
 756     } else {
 757
 758         #my @rv;
 759         #for my $obj ( @{$self->_data} ) {
 760         #    push @rv, { map { $_ => $obj->$_() } @$aref };
 761         #}
 762         #return @rv;
 763
 764         ### this does the same as the above.. just needs a +{ }
 765         ### to make sure perl doesn't confuse it for a block
 766         return map {    my $o=$_;
 767                         +{ map { $_ => $o->$_() } @$aref }
 768                     } @{$self->_data};
 769     }
 770 }
 771
 772 sub _find_entry {
 773     my $self = shift;
 774     my $file = shift;
 775
 776     unless( defined $file ) {
 777         $self->_error( qq[No file specified] );
 778         return;
 779     }
 780
 781     ### it's an object already
 782     return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
 783
 784     for my $entry ( @{$self->_data} ) {
 785         my $path = $entry->full_path;
 786         return $entry if $path eq $file;
 787     }
 788
 789     $self->_error( qq[No such file in archive: '$file'] );
 790     return;
 791 }
 792
 793 =head2 $tar->get_files( [@filenames] )
 794
 795 Returns the C<Archive::Tar::File> objects matching the filenames
 796 provided. If no filename list was passed, all C<Archive::Tar::File>
 797 objects in the current Tar object are returned.
 798
 799 Please refer to the C<Archive::Tar::File> documentation on how to
 800 handle these objects.
 801
 802 =cut
 803
 804 sub get_files {
 805     my $self = shift;
 806
 807     return @{ $self->_data } unless @_;
 808
 809     my @list;
 810     for my $file ( @_ ) {
 811         push @list, grep { defined } $self->_find_entry( $file );
 812     }
 813
 814     return @list;
 815 }
 816
 817 =head2 $tar->get_content( $file )
 818
 819 Return the content of the named file.
 820
 821 =cut
 822
 823 sub get_content {
 824     my $self = shift;
 825     my $entry = $self->_find_entry( shift ) or return;
 826
 827     return $entry->data;
 828 }
 829
 830 =head2 $tar->replace_content( $file, $content )
 831
 832 Make the string $content be the content for the file named $file.
 833
 834 =cut
 835
 836 sub replace_content {
 837     my $self = shift;
 838     my $entry = $self->_find_entry( shift ) or return;
 839
 840     return $entry->replace_content( shift );
 841 }
 842
 843 =head2 $tar->rename( $file, $new_name )
 844
 845 Rename the file of the in-memory archive to $new_name.
 846
 847 Note that you must specify a Unix path for $new_name, since per tar
 848 standard, all files in the archive must be Unix paths.
 849
 850 Returns true on success and false on failure.
 851
 852 =cut
 853
 854 sub rename {
 855     my $self = shift;
 856     my $file = shift; return unless defined $file;
 857     my $new  = shift; return unless defined $new;
 858
 859     my $entry = $self->_find_entry( $file ) or return;
 860
 861     return $entry->rename( $new );
 862 }
 863
 864 =head2 $tar->remove (@filenamelist)
 865
 866 Removes any entries with names matching any of the given filenames
 867 from the in-memory archive. Returns a list of C<Archive::Tar::File>
 868 objects that remain.
 869
 870 =cut
 871
 872 sub remove {
 873     my $self = shift;
 874     my @list = @_;
 875
 876     my %seen = map { $_->full_path => $_ } @{$self->_data};
 877     delete $seen{ $_ } for @list;
 878
 879     $self->_data( [values %seen] );
 880
 881     return values %seen;
 882 }
 883
 884 =head2 $tar->clear
 885
 886 C<clear> clears the current in-memory archive. This effectively gives
 887 you a 'blank' object, ready to be filled again. Note that C<clear>
 888 only has effect on the object, not the underlying tarfile.
 889
 890 =cut
 891
 892 sub clear {
 893     my $self = shift or return;
 894
 895     $self->_data( [] );
 896     $self->_file( '' );
 897
 898     return 1;
 899 }
 900
 901
 902 =head2 $tar->write ( [$file, $compressed, $prefix] )
 903
 904 Write the in-memory archive to disk.  The first argument can either
 905 be the name of a file or a reference to an already open filehandle (a
 906 GLOB reference). If the second argument is true, the module will use
 907 IO::Zlib to write the file in a compressed format.  If IO::Zlib is
 908 not available, the C<write> method will fail and return.
 909
 910 Note that when you pass in a filehandle, the compression argument
 911 is ignored, as all files are printed verbatim to your filehandle.
 912 If you wish to enable compression with filehandles, use an
 913 C<IO::Zlib> filehandle instead.
 914
 915 Specific levels of compression can be chosen by passing the values 2
 916 through 9 as the second parameter.
 917
 918 The third argument is an optional prefix. All files will be tucked
 919 away in the directory you specify as prefix. So if you have files
 920 'a' and 'b' in your archive, and you specify 'foo' as prefix, they
 921 will be written to the archive as 'foo/a' and 'foo/b'.
 922
 923 If no arguments are given, C<write> returns the entire formatted
 924 archive as a string, which could be useful if you'd like to stuff the
 925 archive into a socket or a pipe to gzip or something.
 926
 927 =cut
 928
 929 sub write {
 930     my $self        = shift;
 931     my $file        = shift; $file = '' unless defined $file;
 932     my $gzip        = shift || 0;
 933     my $ext_prefix  = shift; $ext_prefix = '' unless defined $ext_prefix;
 934     my $dummy       = '';
 935
 936     ### only need a handle if we have a file to print to ###
 937     my $handle = length($file)
 938                     ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) )
 939                         or return )
 940                     : $HAS_PERLIO    ? do { open my $h, '>', \$dummy; $h }
 941                     : $HAS_IO_STRING ? IO::String->new
 942                     : __PACKAGE__->no_string_support();
 943
 944
 945
 946     for my $entry ( @{$self->_data} ) {
 947         ### entries to be written to the tarfile ###
 948         my @write_me;
 949
 950         ### only now will we change the object to reflect the current state
 951         ### of the name and prefix fields -- this needs to be limited to
 952         ### write() only!
 953         my $clone = $entry->clone;
 954
 955
 956         ### so, if you don't want use to use the prefix, we'll stuff
 957         ### everything in the name field instead
 958         if( $DO_NOT_USE_PREFIX ) {
 959
 960             ### you might have an extended prefix, if so, set it in the clone
 961             ### XXX is ::Unix right?
 962             $clone->name( length $ext_prefix
 963                             ? File::Spec::Unix->catdir( $ext_prefix,
 964                                                         $clone->full_path)
 965                             : $clone->full_path );
 966             $clone->prefix( '' );
 967
 968         ### otherwise, we'll have to set it properly -- prefix part in the
 969         ### prefix and name part in the name field.
 970         } else {
 971
 972             ### split them here, not before!
 973             my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path );
 974
 975             ### you might have an extended prefix, if so, set it in the clone
 976             ### XXX is ::Unix right?
 977             $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix )
 978                 if length $ext_prefix;
 979
 980             $clone->prefix( $prefix );
 981             $clone->name( $name );
 982         }
 983
 984         ### names are too long, and will get truncated if we don't add a
 985         ### '@LongLink' file...
 986         my $make_longlink = (   length($clone->name)    > NAME_LENGTH or
 987                                 length($clone->prefix)  > PREFIX_LENGTH
 988                             ) || 0;
 989
 990         ### perhaps we need to make a longlink file?
 991         if( $make_longlink ) {
 992             my $longlink = Archive::Tar::File->new(
 993                             data => LONGLINK_NAME,
 994                             $clone->full_path,
 995                             { type => LONGLINK }
 996                         );
 997
 998             unless( $longlink ) {
 999                 $self->_error(  qq[Could not create 'LongLink' entry for ] .
1000                                 qq[oversize file '] . $clone->full_path ."'" );
1001                 return;
1002             };
1003
1004             push @write_me, $longlink;
1005         }
1006
1007         push @write_me, $clone;
1008
1009         ### write the one, optionally 2 a::t::file objects to the handle
1010         for my $clone (@write_me) {
1011
1012             ### if the file is a symlink, there are 2 options:
1013             ### either we leave the symlink intact, but then we don't write any
1014             ### data OR we follow the symlink, which means we actually make a
1015             ### copy. if we do the latter, we have to change the TYPE of the
1016             ### clone to 'FILE'
1017             my $link_ok =  $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK;
1018             my $data_ok = !$clone->is_symlink && $clone->has_content;
1019
1020             ### downgrade to a 'normal' file if it's a symlink we're going to
1021             ### treat as a regular file
1022             $clone->_downgrade_to_plainfile if $link_ok;
1023
1024             ### get the header for this block
1025             my $header = $self->_format_tar_entry( $clone );
1026             unless( $header ) {
1027                 $self->_error(q[Could not format header for: ] .
1028                                     $clone->full_path );
1029                 return;
1030             }
1031
1032             unless( print $handle $header ) {
1033                 $self->_error(q[Could not write header for: ] .
1034                                     $clone->full_path);
1035                 return;
1036             }
1037
1038             if( $link_ok or $data_ok ) {
1039                 unless( print $handle $clone->data ) {
1040                     $self->_error(q[Could not write data for: ] .
1041                                     $clone->full_path);
1042                     return;
1043                 }
1044
1045                 ### pad the end of the clone if required ###
1046                 print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK
1047             }
1048
1049         } ### done writing these entries
1050     }
1051
1052     ### write the end markers ###
1053     print $handle TAR_END x 2 or
1054             return $self->_error( qq[Could not write tar end markers] );
1055
1056     ### did you want it written to a file, or returned as a string? ###
1057     my $rv =  length($file) ? 1
1058                         : $HAS_PERLIO ? $dummy
1059                         : do { seek $handle, 0, 0; local $/; <$handle> };
1060
1061     ### make sure to close the handle;
1062     close $handle;
1063
1064     return $rv;
1065 }
1066
1067 sub _format_tar_entry {
1068     my $self        = shift;
1069     my $entry       = shift or return;
1070     my $ext_prefix  = shift; $ext_prefix = '' unless defined $ext_prefix;
1071     my $no_prefix   = shift || 0;
1072
1073     my $file    = $entry->name;
1074     my $prefix  = $entry->prefix; $prefix = '' unless defined $prefix;
1075
1076     ### remove the prefix from the file name
1077     ### not sure if this is still neeeded --kane
1078     ### no it's not -- Archive::Tar::File->_new_from_file will take care of
1079     ### this for us. Even worse, this would break if we tried to add a file
1080     ### like x/x.
1081     #if( length $prefix ) {
1082     #    $file =~ s/^$match//;
1083     #}
1084
1085     $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix)
1086                 if length $ext_prefix;
1087
1088     ### not sure why this is... ###
1089     my $l = PREFIX_LENGTH; # is ambiguous otherwise...
1090     substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
1091
1092     my $f1 = "%06o"; my $f2  = "%11o";
1093
1094     ### this might be optimizable with a 'changed' flag in the file objects ###
1095     my $tar = pack (
1096                 PACK,
1097                 $file,
1098
1099                 (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]),
1100                 (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]),
1101
1102                 "",  # checksum field - space padded a bit down
1103
1104                 (map { $entry->$_() }                 qw[type linkname magic]),
1105
1106                 $entry->version || TAR_VERSION,
1107
1108                 (map { $entry->$_() }                 qw[uname gname]),
1109                 (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]),
1110
1111                 ($no_prefix ? '' : $prefix)
1112     );
1113
1114     ### add the checksum ###
1115     substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
1116
1117     return $tar;
1118 }
1119
1120 =head2 $tar->add_files( @filenamelist )
1121
1122 Takes a list of filenames and adds them to the in-memory archive.
1123
1124 The path to the file is automatically converted to a Unix like
1125 equivalent for use in the archive, and, if on MacOS, the file's
1126 modification time is converted from the MacOS epoch to the Unix epoch.
1127 So tar archives created on MacOS with B<Archive::Tar> can be read
1128 both with I<tar> on Unix and applications like I<suntar> or
1129 I<Stuffit Expander> on MacOS.
1130
1131 Be aware that the file's type/creator and resource fork will be lost,
1132 which is usually what you want in cross-platform archives.
1133
1134 Returns a list of C<Archive::Tar::File> objects that were just added.
1135
1136 =cut
1137
1138 sub add_files {
1139     my $self    = shift;
1140     my @files   = @_ or return;
1141
1142     my @rv;
1143     for my $file ( @files ) {
1144         unless( -e $file || -l $file ) {
1145             $self->_error( qq[No such file: '$file'] );
1146             next;
1147         }
1148
1149         my $obj = Archive::Tar::File->new( file => $file );
1150         unless( $obj ) {
1151             $self->_error( qq[Unable to add file: '$file'] );
1152             next;
1153         }
1154
1155         push @rv, $obj;
1156     }
1157
1158     push @{$self->{_data}}, @rv;
1159
1160     return @rv;
1161 }
1162
1163 =head2 $tar->add_data ( $filename, $data, [$opthashref] )
1164
1165 Takes a filename, a scalar full of data and optionally a reference to
1166 a hash with specific options.
1167
1168 Will add a file to the in-memory archive, with name C<$filename> and
1169 content C<$data>. Specific properties can be set using C<$opthashref>.
1170 The following list of properties is supported: name, size, mtime
1171 (last modified date), mode, uid, gid, linkname, uname, gname,
1172 devmajor, devminor, prefix, type.  (On MacOS, the file's path and
1173 modification times are converted to Unix equivalents.)
1174
1175 Valid values for the file type are the following constants defined in
1176 Archive::Tar::Constants:
1177
1178 =over 4
1179
1180 =item FILE
1181
1182 Regular file.
1183
1184 =item HARDLINK
1185
1186 =item SYMLINK
1187
1188 Hard and symbolic ("soft") links; linkname should specify target.
1189
1190 =item CHARDEV
1191
1192 =item BLOCKDEV
1193
1194 Character and block devices. devmajor and devminor should specify the major
1195 and minor device numbers.
1196
1197 =item DIR
1198
1199 Directory.
1200
1201 =item FIFO
1202
1203 FIFO (named pipe).
1204
1205 =item SOCKET
1206
1207 Socket.
1208
1209 =back
1210
1211 Returns the C<Archive::Tar::File> object that was just added, or
1212 C<undef> on failure.
1213
1214 =cut
1215
1216 sub add_data {
1217     my $self    = shift;
1218     my ($file, $data, $opt) = @_;
1219
1220     my $obj = Archive::Tar::File->new( data => $file, $data, $opt );
1221     unless( $obj ) {
1222         $self->_error( qq[Unable to add file: '$file'] );
1223         return;
1224     }
1225
1226     push @{$self->{_data}}, $obj;
1227
1228     return $obj;
1229 }
1230
1231 =head2 $tar->error( [$BOOL] )
1232
1233 Returns the current errorstring (usually, the last error reported).
1234 If a true value was specified, it will give the C<Carp::longmess>
1235 equivalent of the error, in effect giving you a stacktrace.
1236
1237 For backwards compatibility, this error is also available as
1238 C<$Archive::Tar::error> although it is much recommended you use the
1239 method call instead.
1240
1241 =cut
1242
1243 {
1244     $error = '';
1245     my $longmess;
1246
1247     sub _error {
1248         my $self    = shift;
1249         my $msg     = $error = shift;
1250         $longmess   = Carp::longmess($error);
1251
1252         ### set Archive::Tar::WARN to 0 to disable printing
1253         ### of errors
1254         if( $WARN ) {
1255             carp $DEBUG ? $longmess : $msg;
1256         }
1257
1258         return;
1259     }
1260
1261     sub error {
1262         my $self = shift;
1263         return shift() ? $longmess : $error;
1264     }
1265 }
1266
1267 =head2 $tar->setcwd( $cwd );
1268
1269 C<Archive::Tar> needs to know the current directory, and it will run
1270 C<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the
1271 tarfile and saves it in the file system. (As of version 1.30, however,
1272 C<Archive::Tar> will use the speed optimization described below
1273 automatically, so it's only relevant if you're using C<extract_file()>).
1274
1275 Since C<Archive::Tar> doesn't change the current directory internally
1276 while it is extracting the items in a tarball, all calls to C<Cwd::cwd()>
1277 can be avoided if we can guarantee that the current directory doesn't
1278 get changed externally.
1279
1280 To use this performance boost, set the current directory via
1281
1282     use Cwd;
1283     $tar->setcwd( cwd() );
1284
1285 once before calling a function like C<extract_file> and
1286 C<Archive::Tar> will use the current directory setting from then on
1287 and won't call C<Cwd::cwd()> internally.
1288
1289 To switch back to the default behaviour, use
1290
1291     $tar->setcwd( undef );
1292
1293 and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
1294
1295 If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
1296 be called for you.
1297
1298 =cut
1299
1300 sub setcwd {
1301     my $self     = shift;
1302     my $cwd      = shift;
1303
1304     $self->{cwd} = $cwd;
1305 }
1306
1307 =head2 $bool = $tar->has_io_string
1308
1309 Returns true if we currently have C<IO::String> support loaded.
1310
1311 Either C<IO::String> or C<perlio> support is needed to support writing
1312 stringified archives. Currently, C<perlio> is the preferred method, if
1313 available.
1314
1315 See the C<GLOBAL VARIABLES> section to see how to change this preference.
1316
1317 =cut
1318
1319 sub has_io_string { return $HAS_IO_STRING; }
1320
1321 =head2 $bool = $tar->has_perlio
1322
1323 Returns true if we currently have C<perlio> support loaded.
1324
1325 This requires C<perl-5.8> or higher, compiled with C<perlio>
1326
1327 Either C<IO::String> or C<perlio> support is needed to support writing
1328 stringified archives. Currently, C<perlio> is the preferred method, if
1329 available.
1330
1331 See the C<GLOBAL VARIABLES> section to see how to change this preference.
1332
1333 =cut
1334
1335 sub has_perlio { return $HAS_PERLIO; }
1336
1337
1338 =head1 Class Methods
1339
1340 =head2 Archive::Tar->create_archive($file, $compression, @filelist)
1341
1342 Creates a tar file from the list of files provided.  The first
1343 argument can either be the name of the tar file to create or a
1344 reference to an open file handle (e.g. a GLOB reference).
1345
1346 The second argument specifies the level of compression to be used, if
1347 any.  Compression of tar files requires the installation of the
1348 IO::Zlib module.  Specific levels of compression may be
1349 requested by passing a value between 2 and 9 as the second argument.
1350 Any other value evaluating as true will result in the default
1351 compression level being used.
1352
1353 Note that when you pass in a filehandle, the compression argument
1354 is ignored, as all files are printed verbatim to your filehandle.
1355 If you wish to enable compression with filehandles, use an
1356 C<IO::Zlib> filehandle instead.
1357
1358 The remaining arguments list the files to be included in the tar file.
1359 These files must all exist. Any files which don't exist or can't be
1360 read are silently ignored.
1361
1362 If the archive creation fails for any reason, C<create_archive> will
1363 return false. Please use the C<error> method to find the cause of the
1364 failure.
1365
1366 Note that this method does not write C<on the fly> as it were; it
1367 still reads all the files into memory before writing out the archive.
1368 Consult the FAQ below if this is a problem.
1369
1370 =cut
1371
1372 sub create_archive {
1373     my $class = shift;
1374
1375     my $file    = shift; return unless defined $file;
1376     my $gzip    = shift || 0;
1377     my @files   = @_;
1378
1379     unless( @files ) {
1380         return $class->_error( qq[Cowardly refusing to create empty archive!] );
1381     }
1382
1383     my $tar = $class->new;
1384     $tar->add_files( @files );
1385     return $tar->write( $file, $gzip );
1386 }
1387
1388 =head2 Archive::Tar->list_archive ($file, $compressed, [\@properties])
1389
1390 Returns a list of the names of all the files in the archive.  The
1391 first argument can either be the name of the tar file to list or a
1392 reference to an open file handle (e.g. a GLOB reference).
1393
1394 If C<list_archive()> is passed an array reference as its third
1395 argument it returns a list of hash references containing the requested
1396 properties of each file.  The following list of properties is
1397 supported: full_path, name, size, mtime (last modified date), mode,
1398 uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
1399
1400 See C<Archive::Tar::File> for details about supported properties.
1401
1402 Passing an array reference containing only one element, 'name', is
1403 special cased to return a list of names rather than a list of hash
1404 references.
1405
1406 =cut
1407
1408 sub list_archive {
1409     my $class   = shift;
1410     my $file    = shift; return unless defined $file;
1411     my $gzip    = shift || 0;
1412
1413     my $tar = $class->new($file, $gzip);
1414     return unless $tar;
1415
1416     return $tar->list_files( @_ );
1417 }
1418
1419 =head2 Archive::Tar->extract_archive ($file, $gzip)
1420
1421 Extracts the contents of the tar file.  The first argument can either
1422 be the name of the tar file to create or a reference to an open file
1423 handle (e.g. a GLOB reference).  All relative paths in the tar file will
1424 be created underneath the current working directory.
1425
1426 C<extract_archive> will return a list of files it extracted.
1427 If the archive extraction fails for any reason, C<extract_archive>
1428 will return false.  Please use the C<error> method to find the cause
1429 of the failure.
1430
1431 =cut
1432
1433 sub extract_archive {
1434     my $class   = shift;
1435     my $file    = shift; return unless defined $file;
1436     my $gzip    = shift || 0;
1437
1438     my $tar = $class->new( ) or return;
1439
1440     return $tar->read( $file, $gzip, { extract => 1 } );
1441 }
1442
1443 =head2 Archive::Tar->can_handle_compressed_files
1444
1445 A simple checking routine, which will return true if C<Archive::Tar>
1446 is able to uncompress compressed archives on the fly with C<IO::Zlib>,
1447 or false if C<IO::Zlib> is not installed.
1448
1449 You can use this as a shortcut to determine whether C<Archive::Tar>
1450 will do what you think before passing compressed archives to its
1451 C<read> method.
1452
1453 =cut
1454
1455 sub can_handle_compressed_files { return ZLIB ? 1 : 0 }
1456
1457 sub no_string_support {
1458     croak("You have to install IO::String to support writing archives to strings");
1459 }
1460
1461 1;
1462
1463 __END__
1464
1465 =head1 GLOBAL VARIABLES
1466
1467 =head2 $Archive::Tar::FOLLOW_SYMLINK
1468
1469 Set this variable to C<1> to make C<Archive::Tar> effectively make a
1470 copy of the file when extracting. Default is C<0>, which
1471 means the symlink stays intact. Of course, you will have to pack the
1472 file linked to as well.
1473
1474 This option is checked when you write out the tarfile using C<write>
1475 or C<create_archive>.
1476
1477 This works just like C</bin/tar>'s C<-h> option.
1478
1479 =head2 $Archive::Tar::CHOWN
1480
1481 By default, C<Archive::Tar> will try to C<chown> your files if it is
1482 able to. In some cases, this may not be desired. In that case, set
1483 this variable to C<0> to disable C<chown>-ing, even if it were
1484 possible.
1485
1486 The default is C<1>.
1487
1488 =head2 $Archive::Tar::CHMOD
1489
1490 By default, C<Archive::Tar> will try to C<chmod> your files to
1491 whatever mode was specified for the particular file in the archive.
1492 In some cases, this may not be desired. In that case, set this
1493 variable to C<0> to disable C<chmod>-ing.
1494
1495 The default is C<1>.
1496
1497 =head2 $Archive::Tar::DO_NOT_USE_PREFIX
1498
1499 By default, C<Archive::Tar> will try to put paths that are over
1500 100 characters in the C<prefix> field of your tar header, as
1501 defined per POSIX-standard. However, some (older) tar programs
1502 do not implement this spec. To retain compatibility with these older
1503 or non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX>
1504 variable to a true value, and C<Archive::Tar> will use an alternate
1505 way of dealing with paths over 100 characters by using the
1506 C<GNU Extended Header> feature.
1507
1508 Note that clients who do not support the C<GNU Extended Header>
1509 feature will not be able to read these archives. Such clients include
1510 tars on C<Solaris>, C<Irix> and C<AIX>.
1511
1512 The default is C<0>.
1513
1514 =head2 $Archive::Tar::DEBUG
1515
1516 Set this variable to C<1> to always get the C<Carp::longmess> output
1517 of the warnings, instead of the regular C<carp>. This is the same
1518 message you would get by doing:
1519
1520     $tar->error(1);
1521
1522 Defaults to C<0>.
1523
1524 =head2 $Archive::Tar::WARN
1525
1526 Set this variable to C<0> if you do not want any warnings printed.
1527 Personally I recommend against doing this, but people asked for the
1528 option. Also, be advised that this is of course not threadsafe.
1529
1530 Defaults to C<1>.
1531
1532 =head2 $Archive::Tar::error
1533
1534 Holds the last reported error. Kept for historical reasons, but its
1535 use is very much discouraged. Use the C<error()> method instead:
1536
1537     warn $tar->error unless $tar->extract;
1538
1539 =head2 $Archive::Tar::HAS_PERLIO
1540
1541 This variable holds a boolean indicating if we currently have
1542 C<perlio> support loaded. This will be enabled for any perl
1543 greater than C<5.8> compiled with C<perlio>.
1544
1545 If you feel strongly about disabling it, set this variable to
1546 C<false>. Note that you will then need C<IO::String> installed
1547 to support writing stringified archives.
1548
1549 Don't change this variable unless you B<really> know what you're
1550 doing.
1551
1552 =head2 $Archive::Tar::HAS_IO_STRING
1553
1554 This variable holds a boolean indicating if we currently have
1555 C<IO::String> support loaded. This will be enabled for any perl
1556 that has a loadable C<IO::String> module.
1557
1558 If you feel strongly about disabling it, set this variable to
1559 C<false>. Note that you will then need C<perlio> support from
1560 your perl to be able to  write stringified archives.
1561
1562 Don't change this variable unless you B<really> know what you're
1563 doing.
1564
1565 =head1 FAQ
1566
1567 =over 4
1568
1569 =item What's the minimum perl version required to run Archive::Tar?
1570
1571 You will need perl version 5.005_03 or newer.
1572
1573 =item Isn't Archive::Tar slow?
1574
1575 Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar>
1576 However, it's very portable. If speed is an issue, consider using
1577 C</bin/tar> instead.
1578
1579 =item Isn't Archive::Tar heavier on memory than /bin/tar?
1580
1581 Yes it is, see previous answer. Since C<Compress::Zlib> and therefore
1582 C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little
1583 choice but to read the archive into memory.
1584 This is ok if you want to do in-memory manipulation of the archive.
1585 If you just want to extract, use the C<extract_archive> class method
1586 instead. It will optimize and write to disk immediately.
1587
1588 =item Can't you lazy-load data instead?
1589
1590 No, not easily. See previous question.
1591
1592 =item How much memory will an X kb tar file need?
1593
1594 Probably more than X kb, since it will all be read into memory. If
1595 this is a problem, and you don't need to do in memory manipulation
1596 of the archive, consider using C</bin/tar> instead.
1597
1598 =item What do you do with unsupported filetypes in an archive?
1599
1600 C<Unix> has a few filetypes that aren't supported on other platforms,
1601 like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just
1602 try to make a copy of the original file, rather than throwing an error.
1603
1604 This does require you to read the entire archive in to memory first,
1605 since otherwise we wouldn't know what data to fill the copy with.
1606 (This means that you cannot use the class methods on archives that
1607 have incompatible filetypes and still expect things to work).
1608
1609 For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that
1610 the extraction of this particular item didn't work.
1611
1612 =item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly!
1613
1614 By default, C<Archive::Tar> is in a completely POSIX-compatible
1615 mode, which uses the POSIX-specification of C<tar> to store files.
1616 For paths greather than 100 characters, this is done using the
1617 C<POSIX header prefix>. Non-POSIX-compatible clients may not support
1618 this part of the specification, and may only support the C<GNU Extended
1619 Header> functionality. To facilitate those clients, you can set the
1620 C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the
1621 C<GLOBAL VARIABLES> section for details on this variable.
1622
1623 Note that GNU tar earlier than version 1.14 does not cope well with
1624 the C<POSIX header prefix>. If you use such a version, consider setting
1625 the C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>.
1626
1627 =item How do I extract only files that have property X from an archive?
1628
1629 Sometimes, you might not wish to extract a complete archive, just
1630 the files that are relevant to you, based on some criteria.
1631
1632 You can do this by filtering a list of C<Archive::Tar::File> objects
1633 based on your criteria. For example, to extract only files that have
1634 the string C<foo> in their title, you would use:
1635
1636     $tar->extract(
1637         grep { $_->full_path =~ /foo/ } $tar->get_files
1638     );
1639
1640 This way, you can filter on any attribute of the files in the archive.
1641 Consult the C<Archive::Tar::File> documentation on how to use these
1642 objects.
1643
1644 =item How do I access .tar.Z files?
1645
1646 The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via
1647 the C<IO::Zlib> module) to access tar files that have been compressed
1648 with C<gzip>. Unfortunately tar files compressed with the Unix C<compress>
1649 utility cannot be read by C<Compress::Zlib> and so cannot be directly
1650 accesses by C<Archive::Tar>.
1651
1652 If the C<uncompress> or C<gunzip> programs are available, you can use
1653 one of these workarounds to read C<.tar.Z> files from C<Archive::Tar>
1654
1655 Firstly with C<uncompress>
1656
1657     use Archive::Tar;
1658
1659     open F, "uncompress -c $filename |";
1660     my $tar = Archive::Tar->new(*F);
1661     ...
1662
1663 and this with C<gunzip>
1664
1665     use Archive::Tar;
1666
1667     open F, "gunzip -c $filename |";
1668     my $tar = Archive::Tar->new(*F);
1669     ...
1670
1671 Similarly, if the C<compress> program is available, you can use this to
1672 write a C<.tar.Z> file
1673
1674     use Archive::Tar;
1675     use IO::File;
1676
1677     my $fh = new IO::File "| compress -c >$filename";
1678     my $tar = Archive::Tar->new();
1679     ...
1680     $tar->write($fh);
1681     $fh->close ;
1682
1683 =item How do I handle Unicode strings?
1684
1685 C<Archive::Tar> uses byte semantics for any files it reads from or writes
1686 to disk. This is not a problem if you only deal with files and never
1687 look at their content or work solely with byte strings. But if you use
1688 Unicode strings with character semantics, some additional steps need
1689 to be taken.
1690
1691 For example, if you add a Unicode string like
1692
1693     # Problem
1694     $tar->add_data('file.txt', "Euro: \x{20AC}");
1695
1696 then there will be a problem later when the tarfile gets written out
1697 to disk via C<$tar->write()>:
1698
1699     Wide character in print at .../Archive/Tar.pm line 1014.
1700
1701 The data was added as a Unicode string and when writing it out to disk,
1702 the C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl
1703 tried to convert the string to ISO-8859 and failed. The written file
1704 now contains garbage.
1705
1706 For this reason, Unicode strings need to be converted to UTF-8-encoded
1707 bytestrings before they are handed off to C<add_data()>:
1708
1709     use Encode;
1710     my $data = "Accented character: \x{20AC}";
1711     $data = encode('utf8', $data);
1712
1713     $tar->add_data('file.txt', $data);
1714
1715 A opposite problem occurs if you extract a UTF8-encoded file from a
1716 tarball. Using C<get_content()> on the C<Archive::Tar::File> object
1717 will return its content as a bytestring, not as a Unicode string.
1718
1719 If you want it to be a Unicode string (because you want character
1720 semantics with operations like regular expression matching), you need
1721 to decode the UTF8-encoded content and have Perl convert it into
1722 a Unicode string:
1723
1724     use Encode;
1725     my $data = $tar->get_content();
1726
1727     # Make it a Unicode string
1728     $data = decode('utf8', $data);
1729
1730 There is no easy way to provide this functionality in C<Archive::Tar>,
1731 because a tarball can contain many files, and each of which could be
1732 encoded in a different way.
1733
1734 =back
1735
1736 =head1 TODO
1737
1738 =over 4
1739
1740 =item Check if passed in handles are open for read/write
1741
1742 Currently I don't know of any portable pure perl way to do this.
1743 Suggestions welcome.
1744
1745 =item Allow archives to be passed in as string
1746
1747 Currently, we only allow opened filehandles or filenames, but
1748 not strings. The internals would need some reworking to facilitate
1749 stringified archives.
1750
1751 =item Facilitate processing an opened filehandle of a compressed archive
1752
1753 Currently, we only support this if the filehandle is an IO::Zlib object.
1754 Environments, like apache, will present you with an opened filehandle
1755 to an uploaded file, which might be a compressed archive.
1756
1757 =back
1758
1759 =head1 SEE ALSO
1760
1761 =over 4
1762
1763 =item The GNU tar specification
1764
1765 C<http://www.gnu.org/software/tar/manual/tar.html>
1766
1767 =item The PAX format specication
1768
1769 The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
1770
1771 =item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html>
1772
1773 =item GNU tar intends to switch to POSIX compatibility
1774
1775 GNU Tar authors have expressed their intention to become completely
1776 POSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html>
1777
1778 =item A Comparison between various tar implementations
1779
1780 Lists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs>
1781
1782 =back
1783
1784 =head1 AUTHOR
1785
1786 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1787
1788 Please reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>.
1789
1790 =head1 ACKNOWLEDGEMENTS
1791
1792 Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney and
1793 especially Andrew Savige for their help and suggestions.
1794
1795 =head1 COPYRIGHT
1796
1797 This module is copyright (c) 2002 - 2007 Jos Boumans
1798 E<lt>kane@cpan.orgE<gt>. All rights reserved.
1799
1800 This library is free software; you may redistribute and/or modify
1801 it under the same terms as Perl itself.
1802
1803 =cut