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