1b39c5158Smillert### the gnu tar specification: 2b39c5158Smillert### http://www.gnu.org/software/tar/manual/tar.html 3b39c5158Smillert### 4b39c5158Smillert### and the pax format spec, which tar derives from: 5b39c5158Smillert### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html 6b39c5158Smillert 7b39c5158Smillertpackage Archive::Tar; 8b39c5158Smillertrequire 5.005_03; 9b39c5158Smillert 10b39c5158Smillertuse Cwd; 11b39c5158Smillertuse IO::Zlib; 12b39c5158Smillertuse IO::File; 13b39c5158Smillertuse Carp qw(carp croak); 14b39c5158Smillertuse File::Spec (); 15b39c5158Smillertuse File::Spec::Unix (); 16b39c5158Smillertuse File::Path (); 17b39c5158Smillert 18b39c5158Smillertuse Archive::Tar::File; 19b39c5158Smillertuse Archive::Tar::Constant; 20b39c5158Smillert 21b39c5158Smillertrequire Exporter; 22b39c5158Smillert 23b39c5158Smillertuse strict; 24b39c5158Smillertuse vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD 25b39c5158Smillert $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS 26898184e3Ssthen $INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT 27b39c5158Smillert ]; 28b39c5158Smillert 29b39c5158Smillert@ISA = qw[Exporter]; 30b39c5158Smillert@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ]; 31b39c5158Smillert$DEBUG = 0; 32b39c5158Smillert$WARN = 1; 33b39c5158Smillert$FOLLOW_SYMLINK = 0; 34*91f110e0Safresh1$VERSION = "1.90"; 35b39c5158Smillert$CHOWN = 1; 36b39c5158Smillert$CHMOD = 1; 37b39c5158Smillert$SAME_PERMISSIONS = $> == 0 ? 1 : 0; 38b39c5158Smillert$DO_NOT_USE_PREFIX = 0; 39b39c5158Smillert$INSECURE_EXTRACT_MODE = 0; 40898184e3Ssthen$ZERO_PAD_NUMBERS = 0; 41b39c5158Smillert 42b39c5158SmillertBEGIN { 43b39c5158Smillert use Config; 44b39c5158Smillert $HAS_PERLIO = $Config::Config{useperlio}; 45b39c5158Smillert 46b39c5158Smillert ### try and load IO::String anyway, so you can dynamically 47b39c5158Smillert ### switch between perlio and IO::String 48b39c5158Smillert $HAS_IO_STRING = eval { 49b39c5158Smillert require IO::String; 50b39c5158Smillert import IO::String; 51b39c5158Smillert 1; 52b39c5158Smillert } || 0; 53b39c5158Smillert} 54b39c5158Smillert 55b39c5158Smillert=head1 NAME 56b39c5158Smillert 57b39c5158SmillertArchive::Tar - module for manipulations of tar archives 58b39c5158Smillert 59b39c5158Smillert=head1 SYNOPSIS 60b39c5158Smillert 61b39c5158Smillert use Archive::Tar; 62b39c5158Smillert my $tar = Archive::Tar->new; 63b39c5158Smillert 64b39c5158Smillert $tar->read('origin.tgz'); 65b39c5158Smillert $tar->extract(); 66b39c5158Smillert 67b39c5158Smillert $tar->add_files('file/foo.pl', 'docs/README'); 68b39c5158Smillert $tar->add_data('file/baz.txt', 'This is the contents now'); 69b39c5158Smillert 70b39c5158Smillert $tar->rename('oldname', 'new/file/name'); 71898184e3Ssthen $tar->chown('/', 'root'); 72898184e3Ssthen $tar->chown('/', 'root:root'); 73898184e3Ssthen $tar->chmod('/tmp', '1777'); 74b39c5158Smillert 75b39c5158Smillert $tar->write('files.tar'); # plain tar 76b39c5158Smillert $tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed 77b39c5158Smillert $tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed 78b39c5158Smillert 79b39c5158Smillert=head1 DESCRIPTION 80b39c5158Smillert 81b39c5158SmillertArchive::Tar provides an object oriented mechanism for handling tar 82b39c5158Smillertfiles. It provides class methods for quick and easy files handling 83b39c5158Smillertwhile also allowing for the creation of tar file objects for custom 84b39c5158Smillertmanipulation. If you have the IO::Zlib module installed, 85b39c5158SmillertArchive::Tar will also support compressed or gzipped tar files. 86b39c5158Smillert 87b39c5158SmillertAn object of class Archive::Tar represents a .tar(.gz) archive full 88b39c5158Smillertof files and things. 89b39c5158Smillert 90b39c5158Smillert=head1 Object Methods 91b39c5158Smillert 92b39c5158Smillert=head2 Archive::Tar->new( [$file, $compressed] ) 93b39c5158Smillert 94b39c5158SmillertReturns a new Tar object. If given any arguments, C<new()> calls the 95b39c5158SmillertC<read()> method automatically, passing on the arguments provided to 96b39c5158Smillertthe C<read()> method. 97b39c5158Smillert 98b39c5158SmillertIf C<new()> is invoked with arguments and the C<read()> method fails 99b39c5158Smillertfor any reason, C<new()> returns undef. 100b39c5158Smillert 101b39c5158Smillert=cut 102b39c5158Smillert 103b39c5158Smillertmy $tmpl = { 104b39c5158Smillert _data => [ ], 105b39c5158Smillert _file => 'Unknown', 106b39c5158Smillert}; 107b39c5158Smillert 108b39c5158Smillert### install get/set accessors for this object. 109b39c5158Smillertfor my $key ( keys %$tmpl ) { 110b39c5158Smillert no strict 'refs'; 111b39c5158Smillert *{__PACKAGE__."::$key"} = sub { 112b39c5158Smillert my $self = shift; 113b39c5158Smillert $self->{$key} = $_[0] if @_; 114b39c5158Smillert return $self->{$key}; 115b39c5158Smillert } 116b39c5158Smillert} 117b39c5158Smillert 118b39c5158Smillertsub new { 119b39c5158Smillert my $class = shift; 120b39c5158Smillert $class = ref $class if ref $class; 121b39c5158Smillert 122b39c5158Smillert ### copying $tmpl here since a shallow copy makes it use the 123b39c5158Smillert ### same aref, causing for files to remain in memory always. 124b39c5158Smillert my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class; 125b39c5158Smillert 126b39c5158Smillert if (@_) { 127b39c5158Smillert unless ( $obj->read( @_ ) ) { 128b39c5158Smillert $obj->_error(qq[No data could be read from file]); 129b39c5158Smillert return; 130b39c5158Smillert } 131b39c5158Smillert } 132b39c5158Smillert 133b39c5158Smillert return $obj; 134b39c5158Smillert} 135b39c5158Smillert 136b39c5158Smillert=head2 $tar->read ( $filename|$handle, [$compressed, {opt => 'val'}] ) 137b39c5158Smillert 138b39c5158SmillertRead the given tar file into memory. 139b39c5158SmillertThe first argument can either be the name of a file or a reference to 140b39c5158Smillertan already open filehandle (or an IO::Zlib object if it's compressed) 141b39c5158Smillert 142b39c5158SmillertThe C<read> will I<replace> any previous content in C<$tar>! 143b39c5158Smillert 144b39c5158SmillertThe second argument may be considered optional, but remains for 145b39c5158Smillertbackwards compatibility. Archive::Tar now looks at the file 146b39c5158Smillertmagic to determine what class should be used to open the file 147b39c5158Smillertand will transparently Do The Right Thing. 148b39c5158Smillert 149b39c5158SmillertArchive::Tar will warn if you try to pass a bzip2 compressed file and the 150b39c5158SmillertIO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return. 151b39c5158Smillert 152b39c5158SmillertNote that you can currently B<not> pass a C<gzip> compressed 153b39c5158Smillertfilehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed 154b39c5158Smillertfilehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string 155b39c5158Smillertcontaining the full archive information (either compressed or 156b39c5158Smillertuncompressed). These are worth while features, but not currently 157b39c5158Smillertimplemented. See the C<TODO> section. 158b39c5158Smillert 159b39c5158SmillertThe third argument can be a hash reference with options. Note that 160b39c5158Smillertall options are case-sensitive. 161b39c5158Smillert 162b39c5158Smillert=over 4 163b39c5158Smillert 164b39c5158Smillert=item limit 165b39c5158Smillert 166b39c5158SmillertDo not read more than C<limit> files. This is useful if you have 167b39c5158Smillertvery big archives, and are only interested in the first few files. 168b39c5158Smillert 169b39c5158Smillert=item filter 170b39c5158Smillert 171b39c5158SmillertCan be set to a regular expression. Only files with names that match 172b39c5158Smillertthe expression will be read. 173b39c5158Smillert 174898184e3Ssthen=item md5 175898184e3Ssthen 176898184e3SsthenSet to 1 and the md5sum of files will be returned (instead of file data) 177898184e3Ssthen my $iter = Archive::Tar->iter( $file, 1, {md5 => 1} ); 178898184e3Ssthen while( my $f = $iter->() ) { 179898184e3Ssthen print $f->data . "\t" . $f->full_path . $/; 180898184e3Ssthen } 181898184e3Ssthen 182b39c5158Smillert=item extract 183b39c5158Smillert 184b39c5158SmillertIf set to true, immediately extract entries when reading them. This 185b39c5158Smillertgives you the same memory break as the C<extract_archive> function. 186b39c5158SmillertNote however that entries will not be read into memory, but written 187b39c5158Smillertstraight to disk. This means no C<Archive::Tar::File> objects are 188b39c5158Smillertcreated for you to inspect. 189b39c5158Smillert 190b39c5158Smillert=back 191b39c5158Smillert 192b39c5158SmillertAll files are stored internally as C<Archive::Tar::File> objects. 193b39c5158SmillertPlease consult the L<Archive::Tar::File> documentation for details. 194b39c5158Smillert 195b39c5158SmillertReturns the number of files read in scalar context, and a list of 196b39c5158SmillertC<Archive::Tar::File> objects in list context. 197b39c5158Smillert 198b39c5158Smillert=cut 199b39c5158Smillert 200b39c5158Smillertsub read { 201b39c5158Smillert my $self = shift; 202b39c5158Smillert my $file = shift; 203b39c5158Smillert my $gzip = shift || 0; 204b39c5158Smillert my $opts = shift || {}; 205b39c5158Smillert 206b39c5158Smillert unless( defined $file ) { 207b39c5158Smillert $self->_error( qq[No file to read from!] ); 208b39c5158Smillert return; 209b39c5158Smillert } else { 210b39c5158Smillert $self->_file( $file ); 211b39c5158Smillert } 212b39c5158Smillert 213b39c5158Smillert my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) ) 214b39c5158Smillert or return; 215b39c5158Smillert 216b39c5158Smillert my $data = $self->_read_tar( $handle, $opts ) or return; 217b39c5158Smillert 218b39c5158Smillert $self->_data( $data ); 219b39c5158Smillert 220b39c5158Smillert return wantarray ? @$data : scalar @$data; 221b39c5158Smillert} 222b39c5158Smillert 223b39c5158Smillertsub _get_handle { 224b39c5158Smillert my $self = shift; 225b39c5158Smillert my $file = shift; return unless defined $file; 226b39c5158Smillert my $compress = shift || 0; 227b39c5158Smillert my $mode = shift || READ_ONLY->( ZLIB ); # default to read only 228b39c5158Smillert 229898184e3Ssthen ### Check if file is a file handle or IO glob 230898184e3Ssthen if ( ref $file ) { 231898184e3Ssthen return $file if eval{ *$file{IO} }; 232898184e3Ssthen return $file if eval{ $file->isa(q{IO::Handle}) }; 233898184e3Ssthen $file = q{}.$file; 234898184e3Ssthen } 235b39c5158Smillert 236b39c5158Smillert ### get a FH opened to the right class, so we can use it transparently 237b39c5158Smillert ### throughout the program 238b39c5158Smillert my $fh; 239b39c5158Smillert { ### reading magic only makes sense if we're opening a file for 240b39c5158Smillert ### reading. otherwise, just use what the user requested. 241b39c5158Smillert my $magic = ''; 242b39c5158Smillert if( MODE_READ->($mode) ) { 243b39c5158Smillert open my $tmp, $file or do { 244b39c5158Smillert $self->_error( qq[Could not open '$file' for reading: $!] ); 245b39c5158Smillert return; 246b39c5158Smillert }; 247b39c5158Smillert 248b39c5158Smillert ### read the first 4 bites of the file to figure out which class to 249b39c5158Smillert ### use to open the file. 250b39c5158Smillert sysread( $tmp, $magic, 4 ); 251b39c5158Smillert close $tmp; 252b39c5158Smillert } 253b39c5158Smillert 254b39c5158Smillert ### is it bzip? 255b39c5158Smillert ### if you asked specifically for bzip compression, or if we're in 256b39c5158Smillert ### read mode and the magic numbers add up, use bzip 257b39c5158Smillert if( BZIP and ( 258b39c5158Smillert ($compress eq COMPRESS_BZIP) or 259b39c5158Smillert ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM ) 260b39c5158Smillert ) 261b39c5158Smillert ) { 262b39c5158Smillert 263b39c5158Smillert ### different reader/writer modules, different error vars... sigh 264b39c5158Smillert if( MODE_READ->($mode) ) { 265b39c5158Smillert $fh = IO::Uncompress::Bunzip2->new( $file ) or do { 266b39c5158Smillert $self->_error( qq[Could not read '$file': ] . 267b39c5158Smillert $IO::Uncompress::Bunzip2::Bunzip2Error 268b39c5158Smillert ); 269b39c5158Smillert return; 270b39c5158Smillert }; 271b39c5158Smillert 272b39c5158Smillert } else { 273b39c5158Smillert $fh = IO::Compress::Bzip2->new( $file ) or do { 274b39c5158Smillert $self->_error( qq[Could not write to '$file': ] . 275b39c5158Smillert $IO::Compress::Bzip2::Bzip2Error 276b39c5158Smillert ); 277b39c5158Smillert return; 278b39c5158Smillert }; 279b39c5158Smillert } 280b39c5158Smillert 281b39c5158Smillert ### is it gzip? 282b39c5158Smillert ### if you asked for compression, if you wanted to read or the gzip 283b39c5158Smillert ### magic number is present (redundant with read) 284b39c5158Smillert } elsif( ZLIB and ( 285b39c5158Smillert $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM 286b39c5158Smillert ) 287b39c5158Smillert ) { 288b39c5158Smillert $fh = IO::Zlib->new; 289b39c5158Smillert 290b39c5158Smillert unless( $fh->open( $file, $mode ) ) { 291b39c5158Smillert $self->_error(qq[Could not create filehandle for '$file': $!]); 292b39c5158Smillert return; 293b39c5158Smillert } 294b39c5158Smillert 295b39c5158Smillert ### is it plain tar? 296b39c5158Smillert } else { 297b39c5158Smillert $fh = IO::File->new; 298b39c5158Smillert 299b39c5158Smillert unless( $fh->open( $file, $mode ) ) { 300b39c5158Smillert $self->_error(qq[Could not create filehandle for '$file': $!]); 301b39c5158Smillert return; 302b39c5158Smillert } 303b39c5158Smillert 304b39c5158Smillert ### enable bin mode on tar archives 305b39c5158Smillert binmode $fh; 306b39c5158Smillert } 307b39c5158Smillert } 308b39c5158Smillert 309b39c5158Smillert return $fh; 310b39c5158Smillert} 311b39c5158Smillert 312b39c5158Smillert 313b39c5158Smillertsub _read_tar { 314b39c5158Smillert my $self = shift; 315b39c5158Smillert my $handle = shift or return; 316b39c5158Smillert my $opts = shift || {}; 317b39c5158Smillert 318b39c5158Smillert my $count = $opts->{limit} || 0; 319b39c5158Smillert my $filter = $opts->{filter}; 320898184e3Ssthen my $md5 = $opts->{md5} || 0; # cdrake 321898184e3Ssthen my $filter_cb = $opts->{filter_cb}; 322b39c5158Smillert my $extract = $opts->{extract} || 0; 323b39c5158Smillert 324b39c5158Smillert ### set a cap on the amount of files to extract ### 325b39c5158Smillert my $limit = 0; 326b39c5158Smillert $limit = 1 if $count > 0; 327b39c5158Smillert 328b39c5158Smillert my $tarfile = [ ]; 329b39c5158Smillert my $chunk; 330b39c5158Smillert my $read = 0; 331b39c5158Smillert my $real_name; # to set the name of a file when 332b39c5158Smillert # we're encountering @longlink 333b39c5158Smillert my $data; 334b39c5158Smillert 335b39c5158Smillert LOOP: 336b39c5158Smillert while( $handle->read( $chunk, HEAD ) ) { 337b39c5158Smillert ### IO::Zlib doesn't support this yet 338*91f110e0Safresh1 my $offset; 339*91f110e0Safresh1 if ( ref($handle) ne 'IO::Zlib' ) { 340*91f110e0Safresh1 local $@; 341*91f110e0Safresh1 $offset = eval { tell $handle } || 'unknown'; 342898184e3Ssthen $@ = ''; 343*91f110e0Safresh1 } 344*91f110e0Safresh1 else { 345*91f110e0Safresh1 $offset = 'unknown'; 346*91f110e0Safresh1 } 347b39c5158Smillert 348b39c5158Smillert unless( $read++ ) { 349b39c5158Smillert my $gzip = GZIP_MAGIC_NUM; 350b39c5158Smillert if( $chunk =~ /$gzip/ ) { 351b39c5158Smillert $self->_error( qq[Cannot read compressed format in tar-mode] ); 352b39c5158Smillert return; 353b39c5158Smillert } 354b39c5158Smillert 355b39c5158Smillert ### size is < HEAD, which means a corrupted file, as the minimum 356b39c5158Smillert ### length is _at least_ HEAD 357b39c5158Smillert if (length $chunk != HEAD) { 358b39c5158Smillert $self->_error( qq[Cannot read enough bytes from the tarfile] ); 359b39c5158Smillert return; 360b39c5158Smillert } 361b39c5158Smillert } 362b39c5158Smillert 363b39c5158Smillert ### if we can't read in all bytes... ### 364b39c5158Smillert last if length $chunk != HEAD; 365b39c5158Smillert 366b39c5158Smillert ### Apparently this should really be two blocks of 512 zeroes, 367b39c5158Smillert ### but GNU tar sometimes gets it wrong. See comment in the 368b39c5158Smillert ### source code (tar.c) to GNU cpio. 369b39c5158Smillert next if $chunk eq TAR_END; 370b39c5158Smillert 371b39c5158Smillert ### according to the posix spec, the last 12 bytes of the header are 372b39c5158Smillert ### null bytes, to pad it to a 512 byte block. That means if these 373898184e3Ssthen ### bytes are NOT null bytes, it's a corrupt header. See: 374b39c5158Smillert ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx 375b39c5158Smillert ### line 111 376b39c5158Smillert { my $nulls = join '', "\0" x 12; 377b39c5158Smillert unless( $nulls eq substr( $chunk, 500, 12 ) ) { 378b39c5158Smillert $self->_error( qq[Invalid header block at offset $offset] ); 379b39c5158Smillert next LOOP; 380b39c5158Smillert } 381b39c5158Smillert } 382b39c5158Smillert 383b39c5158Smillert ### pass the realname, so we can set it 'proper' right away 384b39c5158Smillert ### some of the heuristics are done on the name, so important 385b39c5158Smillert ### to set it ASAP 386b39c5158Smillert my $entry; 387b39c5158Smillert { my %extra_args = (); 388b39c5158Smillert $extra_args{'name'} = $$real_name if defined $real_name; 389b39c5158Smillert 390b39c5158Smillert unless( $entry = Archive::Tar::File->new( chunk => $chunk, 391b39c5158Smillert %extra_args ) 392b39c5158Smillert ) { 393b39c5158Smillert $self->_error( qq[Couldn't read chunk at offset $offset] ); 394b39c5158Smillert next LOOP; 395b39c5158Smillert } 396b39c5158Smillert } 397b39c5158Smillert 398b39c5158Smillert ### ignore labels: 399898184e3Ssthen ### http://www.gnu.org/software/tar/manual/html_chapter/Media.html#SEC159 400b39c5158Smillert next if $entry->is_label; 401b39c5158Smillert 402b39c5158Smillert if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) { 403b39c5158Smillert 404b39c5158Smillert if ( $entry->is_file && !$entry->validate ) { 405b39c5158Smillert ### sometimes the chunk is rather fux0r3d and a whole 512 406b39c5158Smillert ### bytes ends up in the ->name area. 407b39c5158Smillert ### clean it up, if need be 408b39c5158Smillert my $name = $entry->name; 409b39c5158Smillert $name = substr($name, 0, 100) if length $name > 100; 410b39c5158Smillert $name =~ s/\n/ /g; 411b39c5158Smillert 412b39c5158Smillert $self->_error( $name . qq[: checksum error] ); 413b39c5158Smillert next LOOP; 414b39c5158Smillert } 415b39c5158Smillert 416b39c5158Smillert my $block = BLOCK_SIZE->( $entry->size ); 417b39c5158Smillert 418b39c5158Smillert $data = $entry->get_content_by_ref; 419b39c5158Smillert 420898184e3Ssthen my $skip = 0; 421898184e3Ssthen my $ctx; # cdrake 422898184e3Ssthen ### skip this entry if we're filtering 423898184e3Ssthen 424898184e3Ssthen if($md5) { # cdrake 425898184e3Ssthen $ctx = Digest::MD5->new; # cdrake 426898184e3Ssthen $skip=5; # cdrake 427898184e3Ssthen 428898184e3Ssthen } elsif ($filter && $entry->name !~ $filter) { 429898184e3Ssthen $skip = 1; 430898184e3Ssthen 431898184e3Ssthen ### skip this entry if it's a pax header. This is a special file added 432898184e3Ssthen ### by, among others, git-generated tarballs. It holds comments and is 433898184e3Ssthen ### not meant for extracting. See #38932: pax_global_header extracted 434898184e3Ssthen } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) { 435898184e3Ssthen $skip = 2; 436898184e3Ssthen } elsif ($filter_cb && ! $filter_cb->($entry)) { 437898184e3Ssthen $skip = 3; 438898184e3Ssthen } 439898184e3Ssthen 440898184e3Ssthen if ($skip) { 441898184e3Ssthen # 442898184e3Ssthen # Since we're skipping, do not allocate memory for the 443898184e3Ssthen # whole file. Read it 64 BLOCKS at a time. Do not 444898184e3Ssthen # complete the skip yet because maybe what we read is a 445898184e3Ssthen # longlink and it won't get skipped after all 446898184e3Ssthen # 447898184e3Ssthen my $amt = $block; 448898184e3Ssthen my $fsz=$entry->size; # cdrake 449898184e3Ssthen while ($amt > 0) { 450898184e3Ssthen $$data = ''; 451898184e3Ssthen my $this = 64 * BLOCK; 452898184e3Ssthen $this = $amt if $this > $amt; 453898184e3Ssthen if( $handle->read( $$data, $this ) < $this ) { 454898184e3Ssthen $self->_error( qq[Read error on tarfile (missing data) ']. 455898184e3Ssthen $entry->full_path ."' at offset $offset" ); 456898184e3Ssthen next LOOP; 457898184e3Ssthen } 458898184e3Ssthen $amt -= $this; 459898184e3Ssthen $fsz -= $this; # cdrake 460898184e3Ssthen substr ($$data, $fsz) = "" if ($fsz<0); # remove external junk prior to md5 # cdrake 461898184e3Ssthen $ctx->add($$data) if($skip==5); # cdrake 462898184e3Ssthen } 463898184e3Ssthen $$data = $ctx->hexdigest if($skip==5 && !$entry->is_longlink && !$entry->is_unknown && !$entry->is_label ) ; # cdrake 464898184e3Ssthen } else { 465898184e3Ssthen 466b39c5158Smillert ### just read everything into memory 467b39c5158Smillert ### can't do lazy loading since IO::Zlib doesn't support 'seek' 468b39c5158Smillert ### this is because Compress::Zlib doesn't support it =/ 469b39c5158Smillert ### this reads in the whole data in one read() call. 470b39c5158Smillert if ( $handle->read( $$data, $block ) < $block ) { 471b39c5158Smillert $self->_error( qq[Read error on tarfile (missing data) ']. 472b39c5158Smillert $entry->full_path ."' at offset $offset" ); 473b39c5158Smillert next LOOP; 474b39c5158Smillert } 475b39c5158Smillert ### throw away trailing garbage ### 476b39c5158Smillert substr ($$data, $entry->size) = "" if defined $$data; 477898184e3Ssthen } 478b39c5158Smillert 479b39c5158Smillert ### part II of the @LongLink munging -- need to do /after/ 480b39c5158Smillert ### the checksum check. 481b39c5158Smillert if( $entry->is_longlink ) { 482b39c5158Smillert ### weird thing in tarfiles -- if the file is actually a 483b39c5158Smillert ### @LongLink, the data part seems to have a trailing ^@ 484b39c5158Smillert ### (unprintable) char. to display, pipe output through less. 485b39c5158Smillert ### but that doesn't *always* happen.. so check if the last 486b39c5158Smillert ### character is a control character, and if so remove it 487b39c5158Smillert ### at any rate, we better remove that character here, or tests 488b39c5158Smillert ### like 'eq' and hashlook ups based on names will SO not work 489b39c5158Smillert ### remove it by calculating the proper size, and then 490b39c5158Smillert ### tossing out everything that's longer than that size. 491b39c5158Smillert 492b39c5158Smillert ### count number of nulls 493b39c5158Smillert my $nulls = $$data =~ tr/\0/\0/; 494b39c5158Smillert 495b39c5158Smillert ### cut data + size by that many bytes 496b39c5158Smillert $entry->size( $entry->size - $nulls ); 497b39c5158Smillert substr ($$data, $entry->size) = ""; 498b39c5158Smillert } 499b39c5158Smillert } 500b39c5158Smillert 501b39c5158Smillert ### clean up of the entries.. posix tar /apparently/ has some 502b39c5158Smillert ### weird 'feature' that allows for filenames > 255 characters 503b39c5158Smillert ### they'll put a header in with as name '././@LongLink' and the 504b39c5158Smillert ### contents will be the name of the /next/ file in the archive 505b39c5158Smillert ### pretty crappy and kludgy if you ask me 506b39c5158Smillert 507b39c5158Smillert ### set the name for the next entry if this is a @LongLink; 508b39c5158Smillert ### this is one ugly hack =/ but needed for direct extraction 509b39c5158Smillert if( $entry->is_longlink ) { 510b39c5158Smillert $real_name = $data; 511b39c5158Smillert next LOOP; 512b39c5158Smillert } elsif ( defined $real_name ) { 513b39c5158Smillert $entry->name( $$real_name ); 514b39c5158Smillert $entry->prefix(''); 515b39c5158Smillert undef $real_name; 516b39c5158Smillert } 517b39c5158Smillert 518b39c5158Smillert if ($filter && $entry->name !~ $filter) { 519b39c5158Smillert next LOOP; 520b39c5158Smillert 521b39c5158Smillert ### skip this entry if it's a pax header. This is a special file added 522b39c5158Smillert ### by, among others, git-generated tarballs. It holds comments and is 523b39c5158Smillert ### not meant for extracting. See #38932: pax_global_header extracted 524898184e3Ssthen } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) { 525898184e3Ssthen next LOOP; 526898184e3Ssthen } elsif ($filter_cb && ! $filter_cb->($entry)) { 527b39c5158Smillert next LOOP; 528b39c5158Smillert } 529b39c5158Smillert 530898184e3Ssthen if ( $extract && !$entry->is_longlink 531b39c5158Smillert && !$entry->is_unknown 532898184e3Ssthen && !$entry->is_label ) { 533898184e3Ssthen $self->_extract_file( $entry ) or return; 534898184e3Ssthen } 535b39c5158Smillert 536b39c5158Smillert ### Guard against tarfiles with garbage at the end 537b39c5158Smillert last LOOP if $entry->name eq ''; 538b39c5158Smillert 539b39c5158Smillert ### push only the name on the rv if we're extracting 540b39c5158Smillert ### -- for extract_archive 541b39c5158Smillert push @$tarfile, ($extract ? $entry->name : $entry); 542b39c5158Smillert 543b39c5158Smillert if( $limit ) { 544b39c5158Smillert $count-- unless $entry->is_longlink || $entry->is_dir; 545b39c5158Smillert last LOOP unless $count; 546b39c5158Smillert } 547b39c5158Smillert } continue { 548b39c5158Smillert undef $data; 549b39c5158Smillert } 550b39c5158Smillert 551b39c5158Smillert return $tarfile; 552b39c5158Smillert} 553b39c5158Smillert 554b39c5158Smillert=head2 $tar->contains_file( $filename ) 555b39c5158Smillert 556b39c5158SmillertCheck if the archive contains a certain file. 557b39c5158SmillertIt will return true if the file is in the archive, false otherwise. 558b39c5158Smillert 559b39c5158SmillertNote however, that this function does an exact match using C<eq> 560b39c5158Smillerton the full path. So it cannot compensate for case-insensitive file- 561b39c5158Smillertsystems or compare 2 paths to see if they would point to the same 562b39c5158Smillertunderlying file. 563b39c5158Smillert 564b39c5158Smillert=cut 565b39c5158Smillert 566b39c5158Smillertsub contains_file { 567b39c5158Smillert my $self = shift; 568b39c5158Smillert my $full = shift; 569b39c5158Smillert 570b39c5158Smillert return unless defined $full; 571b39c5158Smillert 572b39c5158Smillert ### don't warn if the entry isn't there.. that's what this function 573b39c5158Smillert ### is for after all. 574b39c5158Smillert local $WARN = 0; 575b39c5158Smillert return 1 if $self->_find_entry($full); 576b39c5158Smillert return; 577b39c5158Smillert} 578b39c5158Smillert 579b39c5158Smillert=head2 $tar->extract( [@filenames] ) 580b39c5158Smillert 581b39c5158SmillertWrite files whose names are equivalent to any of the names in 582b39c5158SmillertC<@filenames> to disk, creating subdirectories as necessary. This 583b39c5158Smillertmight not work too well under VMS. 584b39c5158SmillertUnder MacPerl, the file's modification time will be converted to the 585b39c5158SmillertMacOS zero of time, and appropriate conversions will be done to the 586b39c5158Smillertpath. However, the length of each element of the path is not 587b39c5158Smillertinspected to see whether it's longer than MacOS currently allows (32 588b39c5158Smillertcharacters). 589b39c5158Smillert 590b39c5158SmillertIf C<extract> is called without a list of file names, the entire 591b39c5158Smillertcontents of the archive are extracted. 592b39c5158Smillert 593b39c5158SmillertReturns a list of filenames extracted. 594b39c5158Smillert 595b39c5158Smillert=cut 596b39c5158Smillert 597b39c5158Smillertsub extract { 598b39c5158Smillert my $self = shift; 599b39c5158Smillert my @args = @_; 600b39c5158Smillert my @files; 601b39c5158Smillert 602b39c5158Smillert # use the speed optimization for all extracted files 603b39c5158Smillert local($self->{cwd}) = cwd() unless $self->{cwd}; 604b39c5158Smillert 605898184e3Ssthen ### you requested the extraction of only certain files 606b39c5158Smillert if( @args ) { 607b39c5158Smillert for my $file ( @args ) { 608b39c5158Smillert 609b39c5158Smillert ### it's already an object? 610b39c5158Smillert if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) { 611b39c5158Smillert push @files, $file; 612b39c5158Smillert next; 613b39c5158Smillert 614b39c5158Smillert ### go find it then 615b39c5158Smillert } else { 616b39c5158Smillert 617b39c5158Smillert my $found; 618b39c5158Smillert for my $entry ( @{$self->_data} ) { 619b39c5158Smillert next unless $file eq $entry->full_path; 620b39c5158Smillert 621b39c5158Smillert ### we found the file you're looking for 622b39c5158Smillert push @files, $entry; 623b39c5158Smillert $found++; 624b39c5158Smillert } 625b39c5158Smillert 626b39c5158Smillert unless( $found ) { 627b39c5158Smillert return $self->_error( 628b39c5158Smillert qq[Could not find '$file' in archive] ); 629b39c5158Smillert } 630b39c5158Smillert } 631b39c5158Smillert } 632b39c5158Smillert 633b39c5158Smillert ### just grab all the file items 634b39c5158Smillert } else { 635b39c5158Smillert @files = $self->get_files; 636b39c5158Smillert } 637b39c5158Smillert 638b39c5158Smillert ### nothing found? that's an error 639b39c5158Smillert unless( scalar @files ) { 640b39c5158Smillert $self->_error( qq[No files found for ] . $self->_file ); 641b39c5158Smillert return; 642b39c5158Smillert } 643b39c5158Smillert 644b39c5158Smillert ### now extract them 645b39c5158Smillert for my $entry ( @files ) { 646b39c5158Smillert unless( $self->_extract_file( $entry ) ) { 647b39c5158Smillert $self->_error(q[Could not extract ']. $entry->full_path .q['] ); 648b39c5158Smillert return; 649b39c5158Smillert } 650b39c5158Smillert } 651b39c5158Smillert 652b39c5158Smillert return @files; 653b39c5158Smillert} 654b39c5158Smillert 655b39c5158Smillert=head2 $tar->extract_file( $file, [$extract_path] ) 656b39c5158Smillert 657b39c5158SmillertWrite an entry, whose name is equivalent to the file name provided to 658b39c5158Smillertdisk. Optionally takes a second parameter, which is the full native 659b39c5158Smillertpath (including filename) the entry will be written to. 660b39c5158Smillert 661b39c5158SmillertFor example: 662b39c5158Smillert 663b39c5158Smillert $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' ); 664b39c5158Smillert 665b39c5158Smillert $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' ); 666b39c5158Smillert 667b39c5158SmillertReturns true on success, false on failure. 668b39c5158Smillert 669b39c5158Smillert=cut 670b39c5158Smillert 671b39c5158Smillertsub extract_file { 672b39c5158Smillert my $self = shift; 673b39c5158Smillert my $file = shift; return unless defined $file; 674b39c5158Smillert my $alt = shift; 675b39c5158Smillert 676b39c5158Smillert my $entry = $self->_find_entry( $file ) 677b39c5158Smillert or $self->_error( qq[Could not find an entry for '$file'] ), return; 678b39c5158Smillert 679b39c5158Smillert return $self->_extract_file( $entry, $alt ); 680b39c5158Smillert} 681b39c5158Smillert 682b39c5158Smillertsub _extract_file { 683b39c5158Smillert my $self = shift; 684b39c5158Smillert my $entry = shift or return; 685b39c5158Smillert my $alt = shift; 686b39c5158Smillert 687b39c5158Smillert ### you wanted an alternate extraction location ### 688b39c5158Smillert my $name = defined $alt ? $alt : $entry->full_path; 689b39c5158Smillert 690b39c5158Smillert ### splitpath takes a bool at the end to indicate 691b39c5158Smillert ### that it's splitting a dir 692b39c5158Smillert my ($vol,$dirs,$file); 693b39c5158Smillert if ( defined $alt ) { # It's a local-OS path 694b39c5158Smillert ($vol,$dirs,$file) = File::Spec->splitpath( $alt, 695b39c5158Smillert $entry->is_dir ); 696b39c5158Smillert } else { 697b39c5158Smillert ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name, 698b39c5158Smillert $entry->is_dir ); 699b39c5158Smillert } 700b39c5158Smillert 701b39c5158Smillert my $dir; 702b39c5158Smillert ### is $name an absolute path? ### 703b39c5158Smillert if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) { 704b39c5158Smillert 705b39c5158Smillert ### absolute names are not allowed to be in tarballs under 706b39c5158Smillert ### strict mode, so only allow it if a user tells us to do it 707b39c5158Smillert if( not defined $alt and not $INSECURE_EXTRACT_MODE ) { 708b39c5158Smillert $self->_error( 709b39c5158Smillert q[Entry ']. $entry->full_path .q[' is an absolute path. ]. 710b39c5158Smillert q[Not extracting absolute paths under SECURE EXTRACT MODE] 711b39c5158Smillert ); 712b39c5158Smillert return; 713b39c5158Smillert } 714b39c5158Smillert 715b39c5158Smillert ### user asked us to, it's fine. 716b39c5158Smillert $dir = File::Spec->catpath( $vol, $dirs, "" ); 717b39c5158Smillert 718b39c5158Smillert ### it's a relative path ### 719b39c5158Smillert } else { 720b39c5158Smillert my $cwd = (ref $self and defined $self->{cwd}) 721b39c5158Smillert ? $self->{cwd} 722b39c5158Smillert : cwd(); 723b39c5158Smillert 724b39c5158Smillert my @dirs = defined $alt 725b39c5158Smillert ? File::Spec->splitdir( $dirs ) # It's a local-OS path 726b39c5158Smillert : File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely 727b39c5158Smillert # straight from the tarball 728b39c5158Smillert 729b39c5158Smillert if( not defined $alt and 730b39c5158Smillert not $INSECURE_EXTRACT_MODE 731b39c5158Smillert ) { 732b39c5158Smillert 733b39c5158Smillert ### paths that leave the current directory are not allowed under 734b39c5158Smillert ### strict mode, so only allow it if a user tells us to do this. 735b39c5158Smillert if( grep { $_ eq '..' } @dirs ) { 736b39c5158Smillert 737b39c5158Smillert $self->_error( 738b39c5158Smillert q[Entry ']. $entry->full_path .q[' is attempting to leave ]. 739b39c5158Smillert q[the current working directory. Not extracting under ]. 740b39c5158Smillert q[SECURE EXTRACT MODE] 741b39c5158Smillert ); 742b39c5158Smillert return; 743b39c5158Smillert } 744b39c5158Smillert 745b39c5158Smillert ### the archive may be asking us to extract into a symlink. This 746b39c5158Smillert ### is not sane and a possible security issue, as outlined here: 747b39c5158Smillert ### https://rt.cpan.org/Ticket/Display.html?id=30380 748b39c5158Smillert ### https://bugzilla.redhat.com/show_bug.cgi?id=295021 749b39c5158Smillert ### https://issues.rpath.com/browse/RPL-1716 750b39c5158Smillert my $full_path = $cwd; 751b39c5158Smillert for my $d ( @dirs ) { 752b39c5158Smillert $full_path = File::Spec->catdir( $full_path, $d ); 753b39c5158Smillert 754b39c5158Smillert ### we've already checked this one, and it's safe. Move on. 755b39c5158Smillert next if ref $self and $self->{_link_cache}->{$full_path}; 756b39c5158Smillert 757b39c5158Smillert if( -l $full_path ) { 758b39c5158Smillert my $to = readlink $full_path; 759b39c5158Smillert my $diag = "symlinked directory ($full_path => $to)"; 760b39c5158Smillert 761b39c5158Smillert $self->_error( 762b39c5158Smillert q[Entry ']. $entry->full_path .q[' is attempting to ]. 763b39c5158Smillert qq[extract to a $diag. This is considered a security ]. 764b39c5158Smillert q[vulnerability and not allowed under SECURE EXTRACT ]. 765b39c5158Smillert q[MODE] 766b39c5158Smillert ); 767b39c5158Smillert return; 768b39c5158Smillert } 769b39c5158Smillert 770b39c5158Smillert ### XXX keep a cache if possible, so the stats become cheaper: 771b39c5158Smillert $self->{_link_cache}->{$full_path} = 1 if ref $self; 772b39c5158Smillert } 773b39c5158Smillert } 774b39c5158Smillert 775b39c5158Smillert ### '.' is the directory delimiter on VMS, which has to be escaped 776b39c5158Smillert ### or changed to '_' on vms. vmsify is used, because older versions 777b39c5158Smillert ### of vmspath do not handle this properly. 778b39c5158Smillert ### Must not add a '/' to an empty directory though. 779b39c5158Smillert map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS; 780b39c5158Smillert 781b39c5158Smillert my ($cwd_vol,$cwd_dir,$cwd_file) 782b39c5158Smillert = File::Spec->splitpath( $cwd ); 783b39c5158Smillert my @cwd = File::Spec->splitdir( $cwd_dir ); 784b39c5158Smillert push @cwd, $cwd_file if length $cwd_file; 785b39c5158Smillert 786898184e3Ssthen ### We need to pass '' as the last element to catpath. Craig Berry 787b39c5158Smillert ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>): 788b39c5158Smillert ### The root problem is that splitpath on UNIX always returns the 789b39c5158Smillert ### final path element as a file even if it is a directory, and of 790b39c5158Smillert ### course there is no way it can know the difference without checking 791b39c5158Smillert ### against the filesystem, which it is documented as not doing. When 792b39c5158Smillert ### you turn around and call catpath, on VMS you have to know which bits 793b39c5158Smillert ### are directory bits and which bits are file bits. In this case we 794b39c5158Smillert ### know the result should be a directory. I had thought you could omit 795b39c5158Smillert ### the file argument to catpath in such a case, but apparently on UNIX 796b39c5158Smillert ### you can't. 797b39c5158Smillert $dir = File::Spec->catpath( 798b39c5158Smillert $cwd_vol, File::Spec->catdir( @cwd, @dirs ), '' 799b39c5158Smillert ); 800b39c5158Smillert 801b39c5158Smillert ### catdir() returns undef if the path is longer than 255 chars on 802b39c5158Smillert ### older VMS systems. 803b39c5158Smillert unless ( defined $dir ) { 804b39c5158Smillert $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] ); 805b39c5158Smillert return; 806b39c5158Smillert } 807b39c5158Smillert 808b39c5158Smillert } 809b39c5158Smillert 810b39c5158Smillert if( -e $dir && !-d _ ) { 811b39c5158Smillert $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] ); 812b39c5158Smillert return; 813b39c5158Smillert } 814b39c5158Smillert 815b39c5158Smillert unless ( -d _ ) { 816b39c5158Smillert eval { File::Path::mkpath( $dir, 0, 0777 ) }; 817b39c5158Smillert if( $@ ) { 818b39c5158Smillert my $fp = $entry->full_path; 819b39c5158Smillert $self->_error(qq[Could not create directory '$dir' for '$fp': $@]); 820b39c5158Smillert return; 821b39c5158Smillert } 822b39c5158Smillert 823b39c5158Smillert ### XXX chown here? that might not be the same as in the archive 824b39c5158Smillert ### as we're only chown'ing to the owner of the file we're extracting 825b39c5158Smillert ### not to the owner of the directory itself, which may or may not 826b39c5158Smillert ### be another entry in the archive 827b39c5158Smillert ### Answer: no, gnu tar doesn't do it either, it'd be the wrong 828b39c5158Smillert ### way to go. 829b39c5158Smillert #if( $CHOWN && CAN_CHOWN ) { 830b39c5158Smillert # chown $entry->uid, $entry->gid, $dir or 831b39c5158Smillert # $self->_error( qq[Could not set uid/gid on '$dir'] ); 832b39c5158Smillert #} 833b39c5158Smillert } 834b39c5158Smillert 835b39c5158Smillert ### we're done if we just needed to create a dir ### 836b39c5158Smillert return 1 if $entry->is_dir; 837b39c5158Smillert 838b39c5158Smillert my $full = File::Spec->catfile( $dir, $file ); 839b39c5158Smillert 840b39c5158Smillert if( $entry->is_unknown ) { 841b39c5158Smillert $self->_error( qq[Unknown file type for file '$full'] ); 842b39c5158Smillert return; 843b39c5158Smillert } 844b39c5158Smillert 845b39c5158Smillert if( length $entry->type && $entry->is_file ) { 846b39c5158Smillert my $fh = IO::File->new; 847b39c5158Smillert $fh->open( '>' . $full ) or ( 848b39c5158Smillert $self->_error( qq[Could not open file '$full': $!] ), 849b39c5158Smillert return 850b39c5158Smillert ); 851b39c5158Smillert 852b39c5158Smillert if( $entry->size ) { 853b39c5158Smillert binmode $fh; 854b39c5158Smillert syswrite $fh, $entry->data or ( 855b39c5158Smillert $self->_error( qq[Could not write data to '$full'] ), 856b39c5158Smillert return 857b39c5158Smillert ); 858b39c5158Smillert } 859b39c5158Smillert 860b39c5158Smillert close $fh or ( 861b39c5158Smillert $self->_error( qq[Could not close file '$full'] ), 862b39c5158Smillert return 863b39c5158Smillert ); 864b39c5158Smillert 865b39c5158Smillert } else { 866b39c5158Smillert $self->_make_special_file( $entry, $full ) or return; 867b39c5158Smillert } 868b39c5158Smillert 869b39c5158Smillert ### only update the timestamp if it's not a symlink; that will change the 870b39c5158Smillert ### timestamp of the original. This addresses bug #33669: Could not update 871b39c5158Smillert ### timestamp warning on symlinks 872b39c5158Smillert if( not -l $full ) { 873b39c5158Smillert utime time, $entry->mtime - TIME_OFFSET, $full or 874b39c5158Smillert $self->_error( qq[Could not update timestamp] ); 875b39c5158Smillert } 876b39c5158Smillert 877*91f110e0Safresh1 if( $CHOWN && CAN_CHOWN->() and not -l $full ) { 878b39c5158Smillert chown $entry->uid, $entry->gid, $full or 879b39c5158Smillert $self->_error( qq[Could not set uid/gid on '$full'] ); 880b39c5158Smillert } 881b39c5158Smillert 882b39c5158Smillert ### only chmod if we're allowed to, but never chmod symlinks, since they'll 883b39c5158Smillert ### change the perms on the file they're linking too... 884b39c5158Smillert if( $CHMOD and not -l $full ) { 885b39c5158Smillert my $mode = $entry->mode; 886b39c5158Smillert unless ($SAME_PERMISSIONS) { 887b39c5158Smillert $mode &= ~(oct(7000) | umask); 888b39c5158Smillert } 889b39c5158Smillert chmod $mode, $full or 890b39c5158Smillert $self->_error( qq[Could not chown '$full' to ] . $entry->mode ); 891b39c5158Smillert } 892b39c5158Smillert 893b39c5158Smillert return 1; 894b39c5158Smillert} 895b39c5158Smillert 896b39c5158Smillertsub _make_special_file { 897b39c5158Smillert my $self = shift; 898b39c5158Smillert my $entry = shift or return; 899b39c5158Smillert my $file = shift; return unless defined $file; 900b39c5158Smillert 901b39c5158Smillert my $err; 902b39c5158Smillert 903b39c5158Smillert if( $entry->is_symlink ) { 904b39c5158Smillert my $fail; 905b39c5158Smillert if( ON_UNIX ) { 906b39c5158Smillert symlink( $entry->linkname, $file ) or $fail++; 907b39c5158Smillert 908b39c5158Smillert } else { 909b39c5158Smillert $self->_extract_special_file_as_plain_file( $entry, $file ) 910b39c5158Smillert or $fail++; 911b39c5158Smillert } 912b39c5158Smillert 913b39c5158Smillert $err = qq[Making symbolic link '$file' to '] . 914b39c5158Smillert $entry->linkname .q[' failed] if $fail; 915b39c5158Smillert 916b39c5158Smillert } elsif ( $entry->is_hardlink ) { 917b39c5158Smillert my $fail; 918b39c5158Smillert if( ON_UNIX ) { 919b39c5158Smillert link( $entry->linkname, $file ) or $fail++; 920b39c5158Smillert 921b39c5158Smillert } else { 922b39c5158Smillert $self->_extract_special_file_as_plain_file( $entry, $file ) 923b39c5158Smillert or $fail++; 924b39c5158Smillert } 925b39c5158Smillert 926b39c5158Smillert $err = qq[Making hard link from '] . $entry->linkname . 927b39c5158Smillert qq[' to '$file' failed] if $fail; 928b39c5158Smillert 929b39c5158Smillert } elsif ( $entry->is_fifo ) { 930b39c5158Smillert ON_UNIX && !system('mknod', $file, 'p') or 931b39c5158Smillert $err = qq[Making fifo ']. $entry->name .qq[' failed]; 932b39c5158Smillert 933b39c5158Smillert } elsif ( $entry->is_blockdev or $entry->is_chardev ) { 934b39c5158Smillert my $mode = $entry->is_blockdev ? 'b' : 'c'; 935b39c5158Smillert 936b39c5158Smillert ON_UNIX && !system('mknod', $file, $mode, 937b39c5158Smillert $entry->devmajor, $entry->devminor) or 938b39c5158Smillert $err = qq[Making block device ']. $entry->name .qq[' (maj=] . 939b39c5158Smillert $entry->devmajor . qq[ min=] . $entry->devminor . 940b39c5158Smillert qq[) failed.]; 941b39c5158Smillert 942b39c5158Smillert } elsif ( $entry->is_socket ) { 943b39c5158Smillert ### the original doesn't do anything special for sockets.... ### 944b39c5158Smillert 1; 945b39c5158Smillert } 946b39c5158Smillert 947b39c5158Smillert return $err ? $self->_error( $err ) : 1; 948b39c5158Smillert} 949b39c5158Smillert 950b39c5158Smillert### don't know how to make symlinks, let's just extract the file as 951b39c5158Smillert### a plain file 952b39c5158Smillertsub _extract_special_file_as_plain_file { 953b39c5158Smillert my $self = shift; 954b39c5158Smillert my $entry = shift or return; 955b39c5158Smillert my $file = shift; return unless defined $file; 956b39c5158Smillert 957b39c5158Smillert my $err; 958b39c5158Smillert TRY: { 959b39c5158Smillert my $orig = $self->_find_entry( $entry->linkname ); 960b39c5158Smillert 961b39c5158Smillert unless( $orig ) { 962b39c5158Smillert $err = qq[Could not find file '] . $entry->linkname . 963b39c5158Smillert qq[' in memory.]; 964b39c5158Smillert last TRY; 965b39c5158Smillert } 966b39c5158Smillert 967b39c5158Smillert ### clone the entry, make it appear as a normal file ### 968b39c5158Smillert my $clone = $entry->clone; 969b39c5158Smillert $clone->_downgrade_to_plainfile; 970b39c5158Smillert $self->_extract_file( $clone, $file ) or last TRY; 971b39c5158Smillert 972b39c5158Smillert return 1; 973b39c5158Smillert } 974b39c5158Smillert 975b39c5158Smillert return $self->_error($err); 976b39c5158Smillert} 977b39c5158Smillert 978b39c5158Smillert=head2 $tar->list_files( [\@properties] ) 979b39c5158Smillert 980b39c5158SmillertReturns a list of the names of all the files in the archive. 981b39c5158Smillert 982b39c5158SmillertIf C<list_files()> is passed an array reference as its first argument 983b39c5158Smillertit returns a list of hash references containing the requested 984b39c5158Smillertproperties of each file. The following list of properties is 985b39c5158Smillertsupported: name, size, mtime (last modified date), mode, uid, gid, 986b39c5158Smillertlinkname, uname, gname, devmajor, devminor, prefix. 987b39c5158Smillert 988b39c5158SmillertPassing an array reference containing only one element, 'name', is 989b39c5158Smillertspecial cased to return a list of names rather than a list of hash 990b39c5158Smillertreferences, making it equivalent to calling C<list_files> without 991b39c5158Smillertarguments. 992b39c5158Smillert 993b39c5158Smillert=cut 994b39c5158Smillert 995b39c5158Smillertsub list_files { 996b39c5158Smillert my $self = shift; 997b39c5158Smillert my $aref = shift || [ ]; 998b39c5158Smillert 999b39c5158Smillert unless( $self->_data ) { 1000b39c5158Smillert $self->read() or return; 1001b39c5158Smillert } 1002b39c5158Smillert 1003b39c5158Smillert if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) { 1004b39c5158Smillert return map { $_->full_path } @{$self->_data}; 1005b39c5158Smillert } else { 1006b39c5158Smillert 1007b39c5158Smillert #my @rv; 1008b39c5158Smillert #for my $obj ( @{$self->_data} ) { 1009b39c5158Smillert # push @rv, { map { $_ => $obj->$_() } @$aref }; 1010b39c5158Smillert #} 1011b39c5158Smillert #return @rv; 1012b39c5158Smillert 1013b39c5158Smillert ### this does the same as the above.. just needs a +{ } 1014b39c5158Smillert ### to make sure perl doesn't confuse it for a block 1015b39c5158Smillert return map { my $o=$_; 1016b39c5158Smillert +{ map { $_ => $o->$_() } @$aref } 1017b39c5158Smillert } @{$self->_data}; 1018b39c5158Smillert } 1019b39c5158Smillert} 1020b39c5158Smillert 1021b39c5158Smillertsub _find_entry { 1022b39c5158Smillert my $self = shift; 1023b39c5158Smillert my $file = shift; 1024b39c5158Smillert 1025b39c5158Smillert unless( defined $file ) { 1026b39c5158Smillert $self->_error( qq[No file specified] ); 1027b39c5158Smillert return; 1028b39c5158Smillert } 1029b39c5158Smillert 1030b39c5158Smillert ### it's an object already 1031b39c5158Smillert return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); 1032b39c5158Smillert 1033b39c5158Smillert for my $entry ( @{$self->_data} ) { 1034b39c5158Smillert my $path = $entry->full_path; 1035b39c5158Smillert return $entry if $path eq $file; 1036b39c5158Smillert } 1037b39c5158Smillert 1038b39c5158Smillert $self->_error( qq[No such file in archive: '$file'] ); 1039b39c5158Smillert return; 1040b39c5158Smillert} 1041b39c5158Smillert 1042b39c5158Smillert=head2 $tar->get_files( [@filenames] ) 1043b39c5158Smillert 1044b39c5158SmillertReturns the C<Archive::Tar::File> objects matching the filenames 1045b39c5158Smillertprovided. If no filename list was passed, all C<Archive::Tar::File> 1046b39c5158Smillertobjects in the current Tar object are returned. 1047b39c5158Smillert 1048b39c5158SmillertPlease refer to the C<Archive::Tar::File> documentation on how to 1049b39c5158Smillerthandle these objects. 1050b39c5158Smillert 1051b39c5158Smillert=cut 1052b39c5158Smillert 1053b39c5158Smillertsub get_files { 1054b39c5158Smillert my $self = shift; 1055b39c5158Smillert 1056b39c5158Smillert return @{ $self->_data } unless @_; 1057b39c5158Smillert 1058b39c5158Smillert my @list; 1059b39c5158Smillert for my $file ( @_ ) { 1060b39c5158Smillert push @list, grep { defined } $self->_find_entry( $file ); 1061b39c5158Smillert } 1062b39c5158Smillert 1063b39c5158Smillert return @list; 1064b39c5158Smillert} 1065b39c5158Smillert 1066b39c5158Smillert=head2 $tar->get_content( $file ) 1067b39c5158Smillert 1068b39c5158SmillertReturn the content of the named file. 1069b39c5158Smillert 1070b39c5158Smillert=cut 1071b39c5158Smillert 1072b39c5158Smillertsub get_content { 1073b39c5158Smillert my $self = shift; 1074b39c5158Smillert my $entry = $self->_find_entry( shift ) or return; 1075b39c5158Smillert 1076b39c5158Smillert return $entry->data; 1077b39c5158Smillert} 1078b39c5158Smillert 1079b39c5158Smillert=head2 $tar->replace_content( $file, $content ) 1080b39c5158Smillert 1081b39c5158SmillertMake the string $content be the content for the file named $file. 1082b39c5158Smillert 1083b39c5158Smillert=cut 1084b39c5158Smillert 1085b39c5158Smillertsub replace_content { 1086b39c5158Smillert my $self = shift; 1087b39c5158Smillert my $entry = $self->_find_entry( shift ) or return; 1088b39c5158Smillert 1089b39c5158Smillert return $entry->replace_content( shift ); 1090b39c5158Smillert} 1091b39c5158Smillert 1092b39c5158Smillert=head2 $tar->rename( $file, $new_name ) 1093b39c5158Smillert 1094b39c5158SmillertRename the file of the in-memory archive to $new_name. 1095b39c5158Smillert 1096b39c5158SmillertNote that you must specify a Unix path for $new_name, since per tar 1097b39c5158Smillertstandard, all files in the archive must be Unix paths. 1098b39c5158Smillert 1099b39c5158SmillertReturns true on success and false on failure. 1100b39c5158Smillert 1101b39c5158Smillert=cut 1102b39c5158Smillert 1103b39c5158Smillertsub rename { 1104b39c5158Smillert my $self = shift; 1105b39c5158Smillert my $file = shift; return unless defined $file; 1106b39c5158Smillert my $new = shift; return unless defined $new; 1107b39c5158Smillert 1108b39c5158Smillert my $entry = $self->_find_entry( $file ) or return; 1109b39c5158Smillert 1110b39c5158Smillert return $entry->rename( $new ); 1111b39c5158Smillert} 1112b39c5158Smillert 1113898184e3Ssthen=head2 $tar->chmod( $file, $mode ) 1114898184e3Ssthen 1115898184e3SsthenChange mode of $file to $mode. 1116898184e3Ssthen 1117898184e3SsthenReturns true on success and false on failure. 1118898184e3Ssthen 1119898184e3Ssthen=cut 1120898184e3Ssthen 1121898184e3Ssthensub chmod { 1122898184e3Ssthen my $self = shift; 1123898184e3Ssthen my $file = shift; return unless defined $file; 1124898184e3Ssthen my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/; 1125898184e3Ssthen my @args = ("$mode"); 1126898184e3Ssthen 1127898184e3Ssthen my $entry = $self->_find_entry( $file ) or return; 1128898184e3Ssthen my $x = $entry->chmod( @args ); 1129898184e3Ssthen return $x; 1130898184e3Ssthen} 1131898184e3Ssthen 1132898184e3Ssthen=head2 $tar->chown( $file, $uname [, $gname] ) 1133898184e3Ssthen 1134898184e3SsthenChange owner $file to $uname and $gname. 1135898184e3Ssthen 1136898184e3SsthenReturns true on success and false on failure. 1137898184e3Ssthen 1138898184e3Ssthen=cut 1139898184e3Ssthen 1140898184e3Ssthensub chown { 1141898184e3Ssthen my $self = shift; 1142898184e3Ssthen my $file = shift; return unless defined $file; 1143898184e3Ssthen my $uname = shift; return unless defined $uname; 1144898184e3Ssthen my @args = ($uname); 1145898184e3Ssthen push(@args, shift); 1146898184e3Ssthen 1147898184e3Ssthen my $entry = $self->_find_entry( $file ) or return; 1148898184e3Ssthen my $x = $entry->chown( @args ); 1149898184e3Ssthen return $x; 1150898184e3Ssthen} 1151898184e3Ssthen 1152b39c5158Smillert=head2 $tar->remove (@filenamelist) 1153b39c5158Smillert 1154b39c5158SmillertRemoves any entries with names matching any of the given filenames 1155b39c5158Smillertfrom the in-memory archive. Returns a list of C<Archive::Tar::File> 1156b39c5158Smillertobjects that remain. 1157b39c5158Smillert 1158b39c5158Smillert=cut 1159b39c5158Smillert 1160b39c5158Smillertsub remove { 1161b39c5158Smillert my $self = shift; 1162b39c5158Smillert my @list = @_; 1163b39c5158Smillert 1164b39c5158Smillert my %seen = map { $_->full_path => $_ } @{$self->_data}; 1165b39c5158Smillert delete $seen{ $_ } for @list; 1166b39c5158Smillert 1167b39c5158Smillert $self->_data( [values %seen] ); 1168b39c5158Smillert 1169b39c5158Smillert return values %seen; 1170b39c5158Smillert} 1171b39c5158Smillert 1172b39c5158Smillert=head2 $tar->clear 1173b39c5158Smillert 1174b39c5158SmillertC<clear> clears the current in-memory archive. This effectively gives 1175b39c5158Smillertyou a 'blank' object, ready to be filled again. Note that C<clear> 1176b39c5158Smillertonly has effect on the object, not the underlying tarfile. 1177b39c5158Smillert 1178b39c5158Smillert=cut 1179b39c5158Smillert 1180b39c5158Smillertsub clear { 1181b39c5158Smillert my $self = shift or return; 1182b39c5158Smillert 1183b39c5158Smillert $self->_data( [] ); 1184b39c5158Smillert $self->_file( '' ); 1185b39c5158Smillert 1186b39c5158Smillert return 1; 1187b39c5158Smillert} 1188b39c5158Smillert 1189b39c5158Smillert 1190b39c5158Smillert=head2 $tar->write ( [$file, $compressed, $prefix] ) 1191b39c5158Smillert 1192b39c5158SmillertWrite the in-memory archive to disk. The first argument can either 1193b39c5158Smillertbe the name of a file or a reference to an already open filehandle (a 1194b39c5158SmillertGLOB reference). 1195b39c5158Smillert 1196b39c5158SmillertThe second argument is used to indicate compression. You can either 1197b39c5158Smillertcompress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed 1198b39c5158Smillertto be the C<gzip> compression level (between 1 and 9), but the use of 1199898184e3Ssthenconstants is preferred: 1200b39c5158Smillert 1201b39c5158Smillert # write a gzip compressed file 1202b39c5158Smillert $tar->write( 'out.tgz', COMPRESS_GZIP ); 1203b39c5158Smillert 1204b39c5158Smillert # write a bzip compressed file 1205b39c5158Smillert $tar->write( 'out.tbz', COMPRESS_BZIP ); 1206b39c5158Smillert 1207b39c5158SmillertNote that when you pass in a filehandle, the compression argument 1208b39c5158Smillertis ignored, as all files are printed verbatim to your filehandle. 1209b39c5158SmillertIf you wish to enable compression with filehandles, use an 1210b39c5158SmillertC<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead. 1211b39c5158Smillert 1212b39c5158SmillertThe third argument is an optional prefix. All files will be tucked 1213b39c5158Smillertaway in the directory you specify as prefix. So if you have files 1214b39c5158Smillert'a' and 'b' in your archive, and you specify 'foo' as prefix, they 1215b39c5158Smillertwill be written to the archive as 'foo/a' and 'foo/b'. 1216b39c5158Smillert 1217b39c5158SmillertIf no arguments are given, C<write> returns the entire formatted 1218b39c5158Smillertarchive as a string, which could be useful if you'd like to stuff the 1219b39c5158Smillertarchive into a socket or a pipe to gzip or something. 1220b39c5158Smillert 1221b39c5158Smillert 1222b39c5158Smillert=cut 1223b39c5158Smillert 1224b39c5158Smillertsub write { 1225b39c5158Smillert my $self = shift; 1226b39c5158Smillert my $file = shift; $file = '' unless defined $file; 1227b39c5158Smillert my $gzip = shift || 0; 1228b39c5158Smillert my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; 1229b39c5158Smillert my $dummy = ''; 1230b39c5158Smillert 1231b39c5158Smillert ### only need a handle if we have a file to print to ### 1232b39c5158Smillert my $handle = length($file) 1233b39c5158Smillert ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) ) 1234b39c5158Smillert or return ) 1235b39c5158Smillert : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h } 1236b39c5158Smillert : $HAS_IO_STRING ? IO::String->new 1237b39c5158Smillert : __PACKAGE__->no_string_support(); 1238b39c5158Smillert 1239b39c5158Smillert ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a 1240b39c5158Smillert ### corrupt TAR file. Must clear out $\ to make sure no garbage is 1241b39c5158Smillert ### printed to the archive 1242b39c5158Smillert local $\; 1243b39c5158Smillert 1244b39c5158Smillert for my $entry ( @{$self->_data} ) { 1245b39c5158Smillert ### entries to be written to the tarfile ### 1246b39c5158Smillert my @write_me; 1247b39c5158Smillert 1248b39c5158Smillert ### only now will we change the object to reflect the current state 1249b39c5158Smillert ### of the name and prefix fields -- this needs to be limited to 1250b39c5158Smillert ### write() only! 1251b39c5158Smillert my $clone = $entry->clone; 1252b39c5158Smillert 1253b39c5158Smillert 1254b39c5158Smillert ### so, if you don't want use to use the prefix, we'll stuff 1255b39c5158Smillert ### everything in the name field instead 1256b39c5158Smillert if( $DO_NOT_USE_PREFIX ) { 1257b39c5158Smillert 1258b39c5158Smillert ### you might have an extended prefix, if so, set it in the clone 1259b39c5158Smillert ### XXX is ::Unix right? 1260b39c5158Smillert $clone->name( length $ext_prefix 1261b39c5158Smillert ? File::Spec::Unix->catdir( $ext_prefix, 1262b39c5158Smillert $clone->full_path) 1263b39c5158Smillert : $clone->full_path ); 1264b39c5158Smillert $clone->prefix( '' ); 1265b39c5158Smillert 1266b39c5158Smillert ### otherwise, we'll have to set it properly -- prefix part in the 1267b39c5158Smillert ### prefix and name part in the name field. 1268b39c5158Smillert } else { 1269b39c5158Smillert 1270b39c5158Smillert ### split them here, not before! 1271b39c5158Smillert my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path ); 1272b39c5158Smillert 1273b39c5158Smillert ### you might have an extended prefix, if so, set it in the clone 1274b39c5158Smillert ### XXX is ::Unix right? 1275b39c5158Smillert $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix ) 1276b39c5158Smillert if length $ext_prefix; 1277b39c5158Smillert 1278b39c5158Smillert $clone->prefix( $prefix ); 1279b39c5158Smillert $clone->name( $name ); 1280b39c5158Smillert } 1281b39c5158Smillert 1282b39c5158Smillert ### names are too long, and will get truncated if we don't add a 1283b39c5158Smillert ### '@LongLink' file... 1284b39c5158Smillert my $make_longlink = ( length($clone->name) > NAME_LENGTH or 1285b39c5158Smillert length($clone->prefix) > PREFIX_LENGTH 1286b39c5158Smillert ) || 0; 1287b39c5158Smillert 1288b39c5158Smillert ### perhaps we need to make a longlink file? 1289b39c5158Smillert if( $make_longlink ) { 1290b39c5158Smillert my $longlink = Archive::Tar::File->new( 1291b39c5158Smillert data => LONGLINK_NAME, 1292b39c5158Smillert $clone->full_path, 1293b39c5158Smillert { type => LONGLINK } 1294b39c5158Smillert ); 1295b39c5158Smillert 1296b39c5158Smillert unless( $longlink ) { 1297b39c5158Smillert $self->_error( qq[Could not create 'LongLink' entry for ] . 1298b39c5158Smillert qq[oversize file '] . $clone->full_path ."'" ); 1299b39c5158Smillert return; 1300b39c5158Smillert }; 1301b39c5158Smillert 1302b39c5158Smillert push @write_me, $longlink; 1303b39c5158Smillert } 1304b39c5158Smillert 1305b39c5158Smillert push @write_me, $clone; 1306b39c5158Smillert 1307b39c5158Smillert ### write the one, optionally 2 a::t::file objects to the handle 1308b39c5158Smillert for my $clone (@write_me) { 1309b39c5158Smillert 1310b39c5158Smillert ### if the file is a symlink, there are 2 options: 1311b39c5158Smillert ### either we leave the symlink intact, but then we don't write any 1312b39c5158Smillert ### data OR we follow the symlink, which means we actually make a 1313b39c5158Smillert ### copy. if we do the latter, we have to change the TYPE of the 1314b39c5158Smillert ### clone to 'FILE' 1315b39c5158Smillert my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK; 1316b39c5158Smillert my $data_ok = !$clone->is_symlink && $clone->has_content; 1317b39c5158Smillert 1318b39c5158Smillert ### downgrade to a 'normal' file if it's a symlink we're going to 1319b39c5158Smillert ### treat as a regular file 1320b39c5158Smillert $clone->_downgrade_to_plainfile if $link_ok; 1321b39c5158Smillert 1322b39c5158Smillert ### get the header for this block 1323b39c5158Smillert my $header = $self->_format_tar_entry( $clone ); 1324b39c5158Smillert unless( $header ) { 1325b39c5158Smillert $self->_error(q[Could not format header for: ] . 1326b39c5158Smillert $clone->full_path ); 1327b39c5158Smillert return; 1328b39c5158Smillert } 1329b39c5158Smillert 1330b39c5158Smillert unless( print $handle $header ) { 1331b39c5158Smillert $self->_error(q[Could not write header for: ] . 1332b39c5158Smillert $clone->full_path); 1333b39c5158Smillert return; 1334b39c5158Smillert } 1335b39c5158Smillert 1336b39c5158Smillert if( $link_ok or $data_ok ) { 1337b39c5158Smillert unless( print $handle $clone->data ) { 1338b39c5158Smillert $self->_error(q[Could not write data for: ] . 1339b39c5158Smillert $clone->full_path); 1340b39c5158Smillert return; 1341b39c5158Smillert } 1342b39c5158Smillert 1343b39c5158Smillert ### pad the end of the clone if required ### 1344b39c5158Smillert print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK 1345b39c5158Smillert } 1346b39c5158Smillert 1347b39c5158Smillert } ### done writing these entries 1348b39c5158Smillert } 1349b39c5158Smillert 1350b39c5158Smillert ### write the end markers ### 1351b39c5158Smillert print $handle TAR_END x 2 or 1352b39c5158Smillert return $self->_error( qq[Could not write tar end markers] ); 1353b39c5158Smillert 1354b39c5158Smillert ### did you want it written to a file, or returned as a string? ### 1355b39c5158Smillert my $rv = length($file) ? 1 1356b39c5158Smillert : $HAS_PERLIO ? $dummy 1357b39c5158Smillert : do { seek $handle, 0, 0; local $/; <$handle> }; 1358b39c5158Smillert 1359898184e3Ssthen ### make sure to close the handle if we created it 1360898184e3Ssthen if ( $file ne $handle ) { 1361898184e3Ssthen unless( close $handle ) { 1362898184e3Ssthen $self->_error( qq[Could not write tar] ); 1363898184e3Ssthen return; 1364898184e3Ssthen } 1365898184e3Ssthen } 1366b39c5158Smillert 1367b39c5158Smillert return $rv; 1368b39c5158Smillert} 1369b39c5158Smillert 1370b39c5158Smillertsub _format_tar_entry { 1371b39c5158Smillert my $self = shift; 1372b39c5158Smillert my $entry = shift or return; 1373b39c5158Smillert my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; 1374b39c5158Smillert my $no_prefix = shift || 0; 1375b39c5158Smillert 1376b39c5158Smillert my $file = $entry->name; 1377b39c5158Smillert my $prefix = $entry->prefix; $prefix = '' unless defined $prefix; 1378b39c5158Smillert 1379b39c5158Smillert ### remove the prefix from the file name 1380898184e3Ssthen ### not sure if this is still needed --kane 1381b39c5158Smillert ### no it's not -- Archive::Tar::File->_new_from_file will take care of 1382b39c5158Smillert ### this for us. Even worse, this would break if we tried to add a file 1383b39c5158Smillert ### like x/x. 1384b39c5158Smillert #if( length $prefix ) { 1385b39c5158Smillert # $file =~ s/^$match//; 1386b39c5158Smillert #} 1387b39c5158Smillert 1388b39c5158Smillert $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix) 1389b39c5158Smillert if length $ext_prefix; 1390b39c5158Smillert 1391b39c5158Smillert ### not sure why this is... ### 1392b39c5158Smillert my $l = PREFIX_LENGTH; # is ambiguous otherwise... 1393b39c5158Smillert substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH; 1394b39c5158Smillert 1395898184e3Ssthen my $f1 = "%06o"; my $f2 = $ZERO_PAD_NUMBERS ? "%011o" : "%11o"; 1396b39c5158Smillert 1397b39c5158Smillert ### this might be optimizable with a 'changed' flag in the file objects ### 1398b39c5158Smillert my $tar = pack ( 1399b39c5158Smillert PACK, 1400b39c5158Smillert $file, 1401b39c5158Smillert 1402b39c5158Smillert (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]), 1403b39c5158Smillert (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]), 1404b39c5158Smillert 1405b39c5158Smillert "", # checksum field - space padded a bit down 1406b39c5158Smillert 1407b39c5158Smillert (map { $entry->$_() } qw[type linkname magic]), 1408b39c5158Smillert 1409b39c5158Smillert $entry->version || TAR_VERSION, 1410b39c5158Smillert 1411b39c5158Smillert (map { $entry->$_() } qw[uname gname]), 1412b39c5158Smillert (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]), 1413b39c5158Smillert 1414b39c5158Smillert ($no_prefix ? '' : $prefix) 1415b39c5158Smillert ); 1416b39c5158Smillert 1417b39c5158Smillert ### add the checksum ### 1418898184e3Ssthen my $checksum_fmt = $ZERO_PAD_NUMBERS ? "%06o\0" : "%06o\0"; 1419b39c5158Smillert substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar)); 1420b39c5158Smillert 1421b39c5158Smillert return $tar; 1422b39c5158Smillert} 1423b39c5158Smillert 1424b39c5158Smillert=head2 $tar->add_files( @filenamelist ) 1425b39c5158Smillert 1426b39c5158SmillertTakes a list of filenames and adds them to the in-memory archive. 1427b39c5158Smillert 1428b39c5158SmillertThe path to the file is automatically converted to a Unix like 1429b39c5158Smillertequivalent for use in the archive, and, if on MacOS, the file's 1430b39c5158Smillertmodification time is converted from the MacOS epoch to the Unix epoch. 1431b39c5158SmillertSo tar archives created on MacOS with B<Archive::Tar> can be read 1432b39c5158Smillertboth with I<tar> on Unix and applications like I<suntar> or 1433b39c5158SmillertI<Stuffit Expander> on MacOS. 1434b39c5158Smillert 1435b39c5158SmillertBe aware that the file's type/creator and resource fork will be lost, 1436b39c5158Smillertwhich is usually what you want in cross-platform archives. 1437b39c5158Smillert 1438b39c5158SmillertInstead of a filename, you can also pass it an existing C<Archive::Tar::File> 1439b39c5158Smillertobject from, for example, another archive. The object will be clone, and 1440b39c5158Smillerteffectively be a copy of the original, not an alias. 1441b39c5158Smillert 1442b39c5158SmillertReturns a list of C<Archive::Tar::File> objects that were just added. 1443b39c5158Smillert 1444b39c5158Smillert=cut 1445b39c5158Smillert 1446b39c5158Smillertsub add_files { 1447b39c5158Smillert my $self = shift; 1448b39c5158Smillert my @files = @_ or return; 1449b39c5158Smillert 1450b39c5158Smillert my @rv; 1451b39c5158Smillert for my $file ( @files ) { 1452b39c5158Smillert 1453b39c5158Smillert ### you passed an Archive::Tar::File object 1454b39c5158Smillert ### clone it so we don't accidentally have a reference to 1455b39c5158Smillert ### an object from another archive 1456b39c5158Smillert if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) { 1457b39c5158Smillert push @rv, $file->clone; 1458b39c5158Smillert next; 1459b39c5158Smillert } 1460b39c5158Smillert 1461*91f110e0Safresh1 eval { 1462*91f110e0Safresh1 if( utf8::is_utf8( $file )) { 1463*91f110e0Safresh1 utf8::encode( $file ); 1464*91f110e0Safresh1 } 1465*91f110e0Safresh1 }; 1466*91f110e0Safresh1 1467b39c5158Smillert unless( -e $file || -l $file ) { 1468b39c5158Smillert $self->_error( qq[No such file: '$file'] ); 1469b39c5158Smillert next; 1470b39c5158Smillert } 1471b39c5158Smillert 1472b39c5158Smillert my $obj = Archive::Tar::File->new( file => $file ); 1473b39c5158Smillert unless( $obj ) { 1474b39c5158Smillert $self->_error( qq[Unable to add file: '$file'] ); 1475b39c5158Smillert next; 1476b39c5158Smillert } 1477b39c5158Smillert 1478b39c5158Smillert push @rv, $obj; 1479b39c5158Smillert } 1480b39c5158Smillert 1481b39c5158Smillert push @{$self->{_data}}, @rv; 1482b39c5158Smillert 1483b39c5158Smillert return @rv; 1484b39c5158Smillert} 1485b39c5158Smillert 1486b39c5158Smillert=head2 $tar->add_data ( $filename, $data, [$opthashref] ) 1487b39c5158Smillert 1488b39c5158SmillertTakes a filename, a scalar full of data and optionally a reference to 1489b39c5158Smillerta hash with specific options. 1490b39c5158Smillert 1491b39c5158SmillertWill add a file to the in-memory archive, with name C<$filename> and 1492b39c5158Smillertcontent C<$data>. Specific properties can be set using C<$opthashref>. 1493b39c5158SmillertThe following list of properties is supported: name, size, mtime 1494b39c5158Smillert(last modified date), mode, uid, gid, linkname, uname, gname, 1495b39c5158Smillertdevmajor, devminor, prefix, type. (On MacOS, the file's path and 1496b39c5158Smillertmodification times are converted to Unix equivalents.) 1497b39c5158Smillert 1498*91f110e0Safresh1Valid values for the file type are the following constants defined by 1499*91f110e0Safresh1Archive::Tar::Constant: 1500b39c5158Smillert 1501b39c5158Smillert=over 4 1502b39c5158Smillert 1503b39c5158Smillert=item FILE 1504b39c5158Smillert 1505b39c5158SmillertRegular file. 1506b39c5158Smillert 1507b39c5158Smillert=item HARDLINK 1508b39c5158Smillert 1509b39c5158Smillert=item SYMLINK 1510b39c5158Smillert 1511b39c5158SmillertHard and symbolic ("soft") links; linkname should specify target. 1512b39c5158Smillert 1513b39c5158Smillert=item CHARDEV 1514b39c5158Smillert 1515b39c5158Smillert=item BLOCKDEV 1516b39c5158Smillert 1517b39c5158SmillertCharacter and block devices. devmajor and devminor should specify the major 1518b39c5158Smillertand minor device numbers. 1519b39c5158Smillert 1520b39c5158Smillert=item DIR 1521b39c5158Smillert 1522b39c5158SmillertDirectory. 1523b39c5158Smillert 1524b39c5158Smillert=item FIFO 1525b39c5158Smillert 1526b39c5158SmillertFIFO (named pipe). 1527b39c5158Smillert 1528b39c5158Smillert=item SOCKET 1529b39c5158Smillert 1530b39c5158SmillertSocket. 1531b39c5158Smillert 1532b39c5158Smillert=back 1533b39c5158Smillert 1534b39c5158SmillertReturns the C<Archive::Tar::File> object that was just added, or 1535b39c5158SmillertC<undef> on failure. 1536b39c5158Smillert 1537b39c5158Smillert=cut 1538b39c5158Smillert 1539b39c5158Smillertsub add_data { 1540b39c5158Smillert my $self = shift; 1541b39c5158Smillert my ($file, $data, $opt) = @_; 1542b39c5158Smillert 1543b39c5158Smillert my $obj = Archive::Tar::File->new( data => $file, $data, $opt ); 1544b39c5158Smillert unless( $obj ) { 1545b39c5158Smillert $self->_error( qq[Unable to add file: '$file'] ); 1546b39c5158Smillert return; 1547b39c5158Smillert } 1548b39c5158Smillert 1549b39c5158Smillert push @{$self->{_data}}, $obj; 1550b39c5158Smillert 1551b39c5158Smillert return $obj; 1552b39c5158Smillert} 1553b39c5158Smillert 1554b39c5158Smillert=head2 $tar->error( [$BOOL] ) 1555b39c5158Smillert 1556b39c5158SmillertReturns the current errorstring (usually, the last error reported). 1557b39c5158SmillertIf a true value was specified, it will give the C<Carp::longmess> 1558b39c5158Smillertequivalent of the error, in effect giving you a stacktrace. 1559b39c5158Smillert 1560b39c5158SmillertFor backwards compatibility, this error is also available as 1561b39c5158SmillertC<$Archive::Tar::error> although it is much recommended you use the 1562b39c5158Smillertmethod call instead. 1563b39c5158Smillert 1564b39c5158Smillert=cut 1565b39c5158Smillert 1566b39c5158Smillert{ 1567b39c5158Smillert $error = ''; 1568b39c5158Smillert my $longmess; 1569b39c5158Smillert 1570b39c5158Smillert sub _error { 1571b39c5158Smillert my $self = shift; 1572b39c5158Smillert my $msg = $error = shift; 1573b39c5158Smillert $longmess = Carp::longmess($error); 1574b39c5158Smillert if (ref $self) { 1575b39c5158Smillert $self->{_error} = $error; 1576b39c5158Smillert $self->{_longmess} = $longmess; 1577b39c5158Smillert } 1578b39c5158Smillert 1579b39c5158Smillert ### set Archive::Tar::WARN to 0 to disable printing 1580b39c5158Smillert ### of errors 1581b39c5158Smillert if( $WARN ) { 1582b39c5158Smillert carp $DEBUG ? $longmess : $msg; 1583b39c5158Smillert } 1584b39c5158Smillert 1585b39c5158Smillert return; 1586b39c5158Smillert } 1587b39c5158Smillert 1588b39c5158Smillert sub error { 1589b39c5158Smillert my $self = shift; 1590b39c5158Smillert if (ref $self) { 1591b39c5158Smillert return shift() ? $self->{_longmess} : $self->{_error}; 1592b39c5158Smillert } else { 1593b39c5158Smillert return shift() ? $longmess : $error; 1594b39c5158Smillert } 1595b39c5158Smillert } 1596b39c5158Smillert} 1597b39c5158Smillert 1598b39c5158Smillert=head2 $tar->setcwd( $cwd ); 1599b39c5158Smillert 1600b39c5158SmillertC<Archive::Tar> needs to know the current directory, and it will run 1601b39c5158SmillertC<Cwd::cwd()> I<every> time it extracts a I<relative> entry from the 1602b39c5158Smillerttarfile and saves it in the file system. (As of version 1.30, however, 1603b39c5158SmillertC<Archive::Tar> will use the speed optimization described below 1604b39c5158Smillertautomatically, so it's only relevant if you're using C<extract_file()>). 1605b39c5158Smillert 1606b39c5158SmillertSince C<Archive::Tar> doesn't change the current directory internally 1607b39c5158Smillertwhile it is extracting the items in a tarball, all calls to C<Cwd::cwd()> 1608b39c5158Smillertcan be avoided if we can guarantee that the current directory doesn't 1609b39c5158Smillertget changed externally. 1610b39c5158Smillert 1611b39c5158SmillertTo use this performance boost, set the current directory via 1612b39c5158Smillert 1613b39c5158Smillert use Cwd; 1614b39c5158Smillert $tar->setcwd( cwd() ); 1615b39c5158Smillert 1616b39c5158Smillertonce before calling a function like C<extract_file> and 1617b39c5158SmillertC<Archive::Tar> will use the current directory setting from then on 1618b39c5158Smillertand won't call C<Cwd::cwd()> internally. 1619b39c5158Smillert 1620b39c5158SmillertTo switch back to the default behaviour, use 1621b39c5158Smillert 1622b39c5158Smillert $tar->setcwd( undef ); 1623b39c5158Smillert 1624b39c5158Smillertand C<Archive::Tar> will call C<Cwd::cwd()> internally again. 1625b39c5158Smillert 1626898184e3SsthenIf you're using C<Archive::Tar>'s C<extract()> method, C<setcwd()> will 1627b39c5158Smillertbe called for you. 1628b39c5158Smillert 1629b39c5158Smillert=cut 1630b39c5158Smillert 1631b39c5158Smillertsub setcwd { 1632b39c5158Smillert my $self = shift; 1633b39c5158Smillert my $cwd = shift; 1634b39c5158Smillert 1635b39c5158Smillert $self->{cwd} = $cwd; 1636b39c5158Smillert} 1637b39c5158Smillert 1638b39c5158Smillert=head1 Class Methods 1639b39c5158Smillert 1640b39c5158Smillert=head2 Archive::Tar->create_archive($file, $compressed, @filelist) 1641b39c5158Smillert 1642b39c5158SmillertCreates a tar file from the list of files provided. The first 1643b39c5158Smillertargument can either be the name of the tar file to create or a 1644b39c5158Smillertreference to an open file handle (e.g. a GLOB reference). 1645b39c5158Smillert 1646b39c5158SmillertThe second argument is used to indicate compression. You can either 1647b39c5158Smillertcompress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed 1648b39c5158Smillertto be the C<gzip> compression level (between 1 and 9), but the use of 1649898184e3Ssthenconstants is preferred: 1650b39c5158Smillert 1651b39c5158Smillert # write a gzip compressed file 1652b39c5158Smillert Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist ); 1653b39c5158Smillert 1654b39c5158Smillert # write a bzip compressed file 1655b39c5158Smillert Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist ); 1656b39c5158Smillert 1657b39c5158SmillertNote that when you pass in a filehandle, the compression argument 1658b39c5158Smillertis ignored, as all files are printed verbatim to your filehandle. 1659b39c5158SmillertIf you wish to enable compression with filehandles, use an 1660b39c5158SmillertC<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead. 1661b39c5158Smillert 1662b39c5158SmillertThe remaining arguments list the files to be included in the tar file. 1663b39c5158SmillertThese files must all exist. Any files which don't exist or can't be 1664b39c5158Smillertread are silently ignored. 1665b39c5158Smillert 1666b39c5158SmillertIf the archive creation fails for any reason, C<create_archive> will 1667b39c5158Smillertreturn false. Please use the C<error> method to find the cause of the 1668b39c5158Smillertfailure. 1669b39c5158Smillert 1670b39c5158SmillertNote that this method does not write C<on the fly> as it were; it 1671b39c5158Smillertstill reads all the files into memory before writing out the archive. 1672b39c5158SmillertConsult the FAQ below if this is a problem. 1673b39c5158Smillert 1674b39c5158Smillert=cut 1675b39c5158Smillert 1676b39c5158Smillertsub create_archive { 1677b39c5158Smillert my $class = shift; 1678b39c5158Smillert 1679b39c5158Smillert my $file = shift; return unless defined $file; 1680b39c5158Smillert my $gzip = shift || 0; 1681b39c5158Smillert my @files = @_; 1682b39c5158Smillert 1683b39c5158Smillert unless( @files ) { 1684b39c5158Smillert return $class->_error( qq[Cowardly refusing to create empty archive!] ); 1685b39c5158Smillert } 1686b39c5158Smillert 1687b39c5158Smillert my $tar = $class->new; 1688b39c5158Smillert $tar->add_files( @files ); 1689b39c5158Smillert return $tar->write( $file, $gzip ); 1690b39c5158Smillert} 1691b39c5158Smillert 1692b39c5158Smillert=head2 Archive::Tar->iter( $filename, [ $compressed, {opt => $val} ] ) 1693b39c5158Smillert 1694b39c5158SmillertReturns an iterator function that reads the tar file without loading 1695b39c5158Smillertit all in memory. Each time the function is called it will return the 1696b39c5158Smillertnext file in the tarball. The files are returned as 1697b39c5158SmillertC<Archive::Tar::File> objects. The iterator function returns the 1698b39c5158Smillertempty list once it has exhausted the files contained. 1699b39c5158Smillert 1700b39c5158SmillertThe second argument can be a hash reference with options, which are 1701b39c5158Smillertidentical to the arguments passed to C<read()>. 1702b39c5158Smillert 1703b39c5158SmillertExample usage: 1704b39c5158Smillert 1705b39c5158Smillert my $next = Archive::Tar->iter( "example.tar.gz", 1, {filter => qr/\.pm$/} ); 1706b39c5158Smillert 1707b39c5158Smillert while( my $f = $next->() ) { 1708b39c5158Smillert print $f->name, "\n"; 1709b39c5158Smillert 1710b39c5158Smillert $f->extract or warn "Extraction failed"; 1711b39c5158Smillert 1712b39c5158Smillert # .... 1713b39c5158Smillert } 1714b39c5158Smillert 1715b39c5158Smillert=cut 1716b39c5158Smillert 1717b39c5158Smillert 1718b39c5158Smillertsub iter { 1719b39c5158Smillert my $class = shift; 1720b39c5158Smillert my $filename = shift or return; 1721898184e3Ssthen my $compressed = shift || 0; 1722b39c5158Smillert my $opts = shift || {}; 1723b39c5158Smillert 1724b39c5158Smillert ### get a handle to read from. 1725b39c5158Smillert my $handle = $class->_get_handle( 1726b39c5158Smillert $filename, 1727b39c5158Smillert $compressed, 1728b39c5158Smillert READ_ONLY->( ZLIB ) 1729b39c5158Smillert ) or return; 1730b39c5158Smillert 1731b39c5158Smillert my @data; 1732b39c5158Smillert return sub { 1733b39c5158Smillert return shift(@data) if @data; # more than one file returned? 1734b39c5158Smillert return unless $handle; # handle exhausted? 1735b39c5158Smillert 1736b39c5158Smillert ### read data, should only return file 1737b39c5158Smillert my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 }); 1738b39c5158Smillert @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY'; 1739b39c5158Smillert 1740b39c5158Smillert ### return one piece of data 1741b39c5158Smillert return shift(@data) if @data; 1742b39c5158Smillert 1743b39c5158Smillert ### data is exhausted, free the filehandle 1744b39c5158Smillert undef $handle; 1745b39c5158Smillert return; 1746b39c5158Smillert }; 1747b39c5158Smillert} 1748b39c5158Smillert 1749b39c5158Smillert=head2 Archive::Tar->list_archive($file, $compressed, [\@properties]) 1750b39c5158Smillert 1751b39c5158SmillertReturns a list of the names of all the files in the archive. The 1752b39c5158Smillertfirst argument can either be the name of the tar file to list or a 1753b39c5158Smillertreference to an open file handle (e.g. a GLOB reference). 1754b39c5158Smillert 1755b39c5158SmillertIf C<list_archive()> is passed an array reference as its third 1756b39c5158Smillertargument it returns a list of hash references containing the requested 1757b39c5158Smillertproperties of each file. The following list of properties is 1758b39c5158Smillertsupported: full_path, name, size, mtime (last modified date), mode, 1759*91f110e0Safresh1uid, gid, linkname, uname, gname, devmajor, devminor, prefix, type. 1760b39c5158Smillert 1761b39c5158SmillertSee C<Archive::Tar::File> for details about supported properties. 1762b39c5158Smillert 1763b39c5158SmillertPassing an array reference containing only one element, 'name', is 1764b39c5158Smillertspecial cased to return a list of names rather than a list of hash 1765b39c5158Smillertreferences. 1766b39c5158Smillert 1767b39c5158Smillert=cut 1768b39c5158Smillert 1769b39c5158Smillertsub list_archive { 1770b39c5158Smillert my $class = shift; 1771b39c5158Smillert my $file = shift; return unless defined $file; 1772b39c5158Smillert my $gzip = shift || 0; 1773b39c5158Smillert 1774b39c5158Smillert my $tar = $class->new($file, $gzip); 1775b39c5158Smillert return unless $tar; 1776b39c5158Smillert 1777b39c5158Smillert return $tar->list_files( @_ ); 1778b39c5158Smillert} 1779b39c5158Smillert 1780b39c5158Smillert=head2 Archive::Tar->extract_archive($file, $compressed) 1781b39c5158Smillert 1782b39c5158SmillertExtracts the contents of the tar file. The first argument can either 1783b39c5158Smillertbe the name of the tar file to create or a reference to an open file 1784b39c5158Smillerthandle (e.g. a GLOB reference). All relative paths in the tar file will 1785b39c5158Smillertbe created underneath the current working directory. 1786b39c5158Smillert 1787b39c5158SmillertC<extract_archive> will return a list of files it extracted. 1788b39c5158SmillertIf the archive extraction fails for any reason, C<extract_archive> 1789b39c5158Smillertwill return false. Please use the C<error> method to find the cause 1790b39c5158Smillertof the failure. 1791b39c5158Smillert 1792b39c5158Smillert=cut 1793b39c5158Smillert 1794b39c5158Smillertsub extract_archive { 1795b39c5158Smillert my $class = shift; 1796b39c5158Smillert my $file = shift; return unless defined $file; 1797b39c5158Smillert my $gzip = shift || 0; 1798b39c5158Smillert 1799b39c5158Smillert my $tar = $class->new( ) or return; 1800b39c5158Smillert 1801b39c5158Smillert return $tar->read( $file, $gzip, { extract => 1 } ); 1802b39c5158Smillert} 1803b39c5158Smillert 1804b39c5158Smillert=head2 $bool = Archive::Tar->has_io_string 1805b39c5158Smillert 1806b39c5158SmillertReturns true if we currently have C<IO::String> support loaded. 1807b39c5158Smillert 1808b39c5158SmillertEither C<IO::String> or C<perlio> support is needed to support writing 1809b39c5158Smillertstringified archives. Currently, C<perlio> is the preferred method, if 1810b39c5158Smillertavailable. 1811b39c5158Smillert 1812b39c5158SmillertSee the C<GLOBAL VARIABLES> section to see how to change this preference. 1813b39c5158Smillert 1814b39c5158Smillert=cut 1815b39c5158Smillert 1816b39c5158Smillertsub has_io_string { return $HAS_IO_STRING; } 1817b39c5158Smillert 1818b39c5158Smillert=head2 $bool = Archive::Tar->has_perlio 1819b39c5158Smillert 1820b39c5158SmillertReturns true if we currently have C<perlio> support loaded. 1821b39c5158Smillert 1822b39c5158SmillertThis requires C<perl-5.8> or higher, compiled with C<perlio> 1823b39c5158Smillert 1824b39c5158SmillertEither C<IO::String> or C<perlio> support is needed to support writing 1825b39c5158Smillertstringified archives. Currently, C<perlio> is the preferred method, if 1826b39c5158Smillertavailable. 1827b39c5158Smillert 1828b39c5158SmillertSee the C<GLOBAL VARIABLES> section to see how to change this preference. 1829b39c5158Smillert 1830b39c5158Smillert=cut 1831b39c5158Smillert 1832b39c5158Smillertsub has_perlio { return $HAS_PERLIO; } 1833b39c5158Smillert 1834b39c5158Smillert=head2 $bool = Archive::Tar->has_zlib_support 1835b39c5158Smillert 1836b39c5158SmillertReturns true if C<Archive::Tar> can extract C<zlib> compressed archives 1837b39c5158Smillert 1838b39c5158Smillert=cut 1839b39c5158Smillert 1840b39c5158Smillertsub has_zlib_support { return ZLIB } 1841b39c5158Smillert 1842b39c5158Smillert=head2 $bool = Archive::Tar->has_bzip2_support 1843b39c5158Smillert 1844b39c5158SmillertReturns true if C<Archive::Tar> can extract C<bzip2> compressed archives 1845b39c5158Smillert 1846b39c5158Smillert=cut 1847b39c5158Smillert 1848b39c5158Smillertsub has_bzip2_support { return BZIP } 1849b39c5158Smillert 1850b39c5158Smillert=head2 Archive::Tar->can_handle_compressed_files 1851b39c5158Smillert 1852b39c5158SmillertA simple checking routine, which will return true if C<Archive::Tar> 1853b39c5158Smillertis able to uncompress compressed archives on the fly with C<IO::Zlib> 1854b39c5158Smillertand C<IO::Compress::Bzip2> or false if not both are installed. 1855b39c5158Smillert 1856b39c5158SmillertYou can use this as a shortcut to determine whether C<Archive::Tar> 1857b39c5158Smillertwill do what you think before passing compressed archives to its 1858b39c5158SmillertC<read> method. 1859b39c5158Smillert 1860b39c5158Smillert=cut 1861b39c5158Smillert 1862b39c5158Smillertsub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 } 1863b39c5158Smillert 1864b39c5158Smillertsub no_string_support { 1865b39c5158Smillert croak("You have to install IO::String to support writing archives to strings"); 1866b39c5158Smillert} 1867b39c5158Smillert 1868b39c5158Smillert1; 1869b39c5158Smillert 1870b39c5158Smillert__END__ 1871b39c5158Smillert 1872b39c5158Smillert=head1 GLOBAL VARIABLES 1873b39c5158Smillert 1874b39c5158Smillert=head2 $Archive::Tar::FOLLOW_SYMLINK 1875b39c5158Smillert 1876b39c5158SmillertSet this variable to C<1> to make C<Archive::Tar> effectively make a 1877b39c5158Smillertcopy of the file when extracting. Default is C<0>, which 1878b39c5158Smillertmeans the symlink stays intact. Of course, you will have to pack the 1879b39c5158Smillertfile linked to as well. 1880b39c5158Smillert 1881b39c5158SmillertThis option is checked when you write out the tarfile using C<write> 1882b39c5158Smillertor C<create_archive>. 1883b39c5158Smillert 1884b39c5158SmillertThis works just like C</bin/tar>'s C<-h> option. 1885b39c5158Smillert 1886b39c5158Smillert=head2 $Archive::Tar::CHOWN 1887b39c5158Smillert 1888b39c5158SmillertBy default, C<Archive::Tar> will try to C<chown> your files if it is 1889b39c5158Smillertable to. In some cases, this may not be desired. In that case, set 1890b39c5158Smillertthis variable to C<0> to disable C<chown>-ing, even if it were 1891b39c5158Smillertpossible. 1892b39c5158Smillert 1893b39c5158SmillertThe default is C<1>. 1894b39c5158Smillert 1895b39c5158Smillert=head2 $Archive::Tar::CHMOD 1896b39c5158Smillert 1897b39c5158SmillertBy default, C<Archive::Tar> will try to C<chmod> your files to 1898b39c5158Smillertwhatever mode was specified for the particular file in the archive. 1899b39c5158SmillertIn some cases, this may not be desired. In that case, set this 1900b39c5158Smillertvariable to C<0> to disable C<chmod>-ing. 1901b39c5158Smillert 1902b39c5158SmillertThe default is C<1>. 1903b39c5158Smillert 1904b39c5158Smillert=head2 $Archive::Tar::SAME_PERMISSIONS 1905b39c5158Smillert 1906b39c5158SmillertWhen, C<$Archive::Tar::CHMOD> is enabled, this setting controls whether 1907b39c5158Smillertthe permissions on files from the archive are used without modification 1908b39c5158Smillertof if they are filtered by removing any setid bits and applying the 1909b39c5158Smillertcurrent umask. 1910b39c5158Smillert 1911b39c5158SmillertThe default is C<1> for the root user and C<0> for normal users. 1912b39c5158Smillert 1913b39c5158Smillert=head2 $Archive::Tar::DO_NOT_USE_PREFIX 1914b39c5158Smillert 1915b39c5158SmillertBy default, C<Archive::Tar> will try to put paths that are over 1916b39c5158Smillert100 characters in the C<prefix> field of your tar header, as 1917b39c5158Smillertdefined per POSIX-standard. However, some (older) tar programs 1918b39c5158Smillertdo not implement this spec. To retain compatibility with these older 1919b39c5158Smillertor non-POSIX compliant versions, you can set the C<$DO_NOT_USE_PREFIX> 1920b39c5158Smillertvariable to a true value, and C<Archive::Tar> will use an alternate 1921b39c5158Smillertway of dealing with paths over 100 characters by using the 1922b39c5158SmillertC<GNU Extended Header> feature. 1923b39c5158Smillert 1924b39c5158SmillertNote that clients who do not support the C<GNU Extended Header> 1925b39c5158Smillertfeature will not be able to read these archives. Such clients include 1926b39c5158Smillerttars on C<Solaris>, C<Irix> and C<AIX>. 1927b39c5158Smillert 1928b39c5158SmillertThe default is C<0>. 1929b39c5158Smillert 1930b39c5158Smillert=head2 $Archive::Tar::DEBUG 1931b39c5158Smillert 1932b39c5158SmillertSet this variable to C<1> to always get the C<Carp::longmess> output 1933b39c5158Smillertof the warnings, instead of the regular C<carp>. This is the same 1934b39c5158Smillertmessage you would get by doing: 1935b39c5158Smillert 1936b39c5158Smillert $tar->error(1); 1937b39c5158Smillert 1938b39c5158SmillertDefaults to C<0>. 1939b39c5158Smillert 1940b39c5158Smillert=head2 $Archive::Tar::WARN 1941b39c5158Smillert 1942b39c5158SmillertSet this variable to C<0> if you do not want any warnings printed. 1943b39c5158SmillertPersonally I recommend against doing this, but people asked for the 1944b39c5158Smillertoption. Also, be advised that this is of course not threadsafe. 1945b39c5158Smillert 1946b39c5158SmillertDefaults to C<1>. 1947b39c5158Smillert 1948b39c5158Smillert=head2 $Archive::Tar::error 1949b39c5158Smillert 1950b39c5158SmillertHolds the last reported error. Kept for historical reasons, but its 1951b39c5158Smillertuse is very much discouraged. Use the C<error()> method instead: 1952b39c5158Smillert 1953b39c5158Smillert warn $tar->error unless $tar->extract; 1954b39c5158Smillert 1955b39c5158SmillertNote that in older versions of this module, the C<error()> method 1956b39c5158Smillertwould return an effectively global value even when called an instance 1957b39c5158Smillertmethod as above. This has since been fixed, and multiple instances of 1958b39c5158SmillertC<Archive::Tar> now have separate error strings. 1959b39c5158Smillert 1960b39c5158Smillert=head2 $Archive::Tar::INSECURE_EXTRACT_MODE 1961b39c5158Smillert 1962b39c5158SmillertThis variable indicates whether C<Archive::Tar> should allow 1963b39c5158Smillertfiles to be extracted outside their current working directory. 1964b39c5158Smillert 1965b39c5158SmillertAllowing this could have security implications, as a malicious 1966b39c5158Smillerttar archive could alter or replace any file the extracting user 1967b39c5158Smillerthas permissions to. Therefor, the default is to not allow 1968b39c5158Smillertinsecure extractions. 1969b39c5158Smillert 1970b39c5158SmillertIf you trust the archive, or have other reasons to allow the 1971b39c5158Smillertarchive to write files outside your current working directory, 1972b39c5158Smillertset this variable to C<true>. 1973b39c5158Smillert 1974b39c5158SmillertNote that this is a backwards incompatible change from version 1975b39c5158SmillertC<1.36> and before. 1976b39c5158Smillert 1977b39c5158Smillert=head2 $Archive::Tar::HAS_PERLIO 1978b39c5158Smillert 1979b39c5158SmillertThis variable holds a boolean indicating if we currently have 1980b39c5158SmillertC<perlio> support loaded. This will be enabled for any perl 1981b39c5158Smillertgreater than C<5.8> compiled with C<perlio>. 1982b39c5158Smillert 1983b39c5158SmillertIf you feel strongly about disabling it, set this variable to 1984b39c5158SmillertC<false>. Note that you will then need C<IO::String> installed 1985b39c5158Smillertto support writing stringified archives. 1986b39c5158Smillert 1987b39c5158SmillertDon't change this variable unless you B<really> know what you're 1988b39c5158Smillertdoing. 1989b39c5158Smillert 1990b39c5158Smillert=head2 $Archive::Tar::HAS_IO_STRING 1991b39c5158Smillert 1992b39c5158SmillertThis variable holds a boolean indicating if we currently have 1993b39c5158SmillertC<IO::String> support loaded. This will be enabled for any perl 1994b39c5158Smillertthat has a loadable C<IO::String> module. 1995b39c5158Smillert 1996b39c5158SmillertIf you feel strongly about disabling it, set this variable to 1997b39c5158SmillertC<false>. Note that you will then need C<perlio> support from 1998b39c5158Smillertyour perl to be able to write stringified archives. 1999b39c5158Smillert 2000b39c5158SmillertDon't change this variable unless you B<really> know what you're 2001b39c5158Smillertdoing. 2002b39c5158Smillert 2003898184e3Ssthen=head2 $Archive::Tar::ZERO_PAD_NUMBERS 2004898184e3Ssthen 2005898184e3SsthenThis variable holds a boolean indicating if we will create 2006898184e3Ssthenzero padded numbers for C<size>, C<mtime> and C<checksum>. 2007898184e3SsthenThe default is C<0>, indicating that we will create space padded 2008898184e3Ssthennumbers. Added for compatibility with C<busybox> implementations. 2009898184e3Ssthen 2010b39c5158Smillert=head1 FAQ 2011b39c5158Smillert 2012b39c5158Smillert=over 4 2013b39c5158Smillert 2014b39c5158Smillert=item What's the minimum perl version required to run Archive::Tar? 2015b39c5158Smillert 2016b39c5158SmillertYou will need perl version 5.005_03 or newer. 2017b39c5158Smillert 2018b39c5158Smillert=item Isn't Archive::Tar slow? 2019b39c5158Smillert 2020b39c5158SmillertYes it is. It's pure perl, so it's a lot slower then your C</bin/tar> 2021b39c5158SmillertHowever, it's very portable. If speed is an issue, consider using 2022b39c5158SmillertC</bin/tar> instead. 2023b39c5158Smillert 2024b39c5158Smillert=item Isn't Archive::Tar heavier on memory than /bin/tar? 2025b39c5158Smillert 2026b39c5158SmillertYes it is, see previous answer. Since C<Compress::Zlib> and therefore 2027b39c5158SmillertC<IO::Zlib> doesn't support C<seek> on their filehandles, there is little 2028b39c5158Smillertchoice but to read the archive into memory. 2029b39c5158SmillertThis is ok if you want to do in-memory manipulation of the archive. 2030b39c5158Smillert 2031b39c5158SmillertIf you just want to extract, use the C<extract_archive> class method 2032b39c5158Smillertinstead. It will optimize and write to disk immediately. 2033b39c5158Smillert 2034b39c5158SmillertAnother option is to use the C<iter> class method to iterate over 2035b39c5158Smillertthe files in the tarball without reading them all in memory at once. 2036b39c5158Smillert 2037b39c5158Smillert=item Can you lazy-load data instead? 2038b39c5158Smillert 2039b39c5158SmillertIn some cases, yes. You can use the C<iter> class method to iterate 2040b39c5158Smillertover the files in the tarball without reading them all in memory at once. 2041b39c5158Smillert 2042b39c5158Smillert=item How much memory will an X kb tar file need? 2043b39c5158Smillert 2044b39c5158SmillertProbably more than X kb, since it will all be read into memory. If 2045b39c5158Smillertthis is a problem, and you don't need to do in memory manipulation 2046b39c5158Smillertof the archive, consider using the C<iter> class method, or C</bin/tar> 2047b39c5158Smillertinstead. 2048b39c5158Smillert 2049b39c5158Smillert=item What do you do with unsupported filetypes in an archive? 2050b39c5158Smillert 2051b39c5158SmillertC<Unix> has a few filetypes that aren't supported on other platforms, 2052b39c5158Smillertlike C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just 2053b39c5158Smillerttry to make a copy of the original file, rather than throwing an error. 2054b39c5158Smillert 2055b39c5158SmillertThis does require you to read the entire archive in to memory first, 2056b39c5158Smillertsince otherwise we wouldn't know what data to fill the copy with. 2057b39c5158Smillert(This means that you cannot use the class methods, including C<iter> 2058b39c5158Smillerton archives that have incompatible filetypes and still expect things 2059b39c5158Smillertto work). 2060b39c5158Smillert 2061b39c5158SmillertFor other filetypes, like C<chardevs> and C<blockdevs> we'll warn that 2062b39c5158Smillertthe extraction of this particular item didn't work. 2063b39c5158Smillert 2064b39c5158Smillert=item I'm using WinZip, or some other non-POSIX client, and files are not being extracted properly! 2065b39c5158Smillert 2066b39c5158SmillertBy default, C<Archive::Tar> is in a completely POSIX-compatible 2067b39c5158Smillertmode, which uses the POSIX-specification of C<tar> to store files. 2068898184e3SsthenFor paths greater than 100 characters, this is done using the 2069b39c5158SmillertC<POSIX header prefix>. Non-POSIX-compatible clients may not support 2070b39c5158Smillertthis part of the specification, and may only support the C<GNU Extended 2071b39c5158SmillertHeader> functionality. To facilitate those clients, you can set the 2072b39c5158SmillertC<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. See the 2073b39c5158SmillertC<GLOBAL VARIABLES> section for details on this variable. 2074b39c5158Smillert 2075b39c5158SmillertNote that GNU tar earlier than version 1.14 does not cope well with 2076b39c5158Smillertthe C<POSIX header prefix>. If you use such a version, consider setting 2077b39c5158Smillertthe C<$Archive::Tar::DO_NOT_USE_PREFIX> variable to C<true>. 2078b39c5158Smillert 2079b39c5158Smillert=item How do I extract only files that have property X from an archive? 2080b39c5158Smillert 2081b39c5158SmillertSometimes, you might not wish to extract a complete archive, just 2082b39c5158Smillertthe files that are relevant to you, based on some criteria. 2083b39c5158Smillert 2084b39c5158SmillertYou can do this by filtering a list of C<Archive::Tar::File> objects 2085b39c5158Smillertbased on your criteria. For example, to extract only files that have 2086b39c5158Smillertthe string C<foo> in their title, you would use: 2087b39c5158Smillert 2088b39c5158Smillert $tar->extract( 2089b39c5158Smillert grep { $_->full_path =~ /foo/ } $tar->get_files 2090b39c5158Smillert ); 2091b39c5158Smillert 2092b39c5158SmillertThis way, you can filter on any attribute of the files in the archive. 2093b39c5158SmillertConsult the C<Archive::Tar::File> documentation on how to use these 2094b39c5158Smillertobjects. 2095b39c5158Smillert 2096b39c5158Smillert=item How do I access .tar.Z files? 2097b39c5158Smillert 2098b39c5158SmillertThe C<Archive::Tar> module can optionally use C<Compress::Zlib> (via 2099b39c5158Smillertthe C<IO::Zlib> module) to access tar files that have been compressed 2100b39c5158Smillertwith C<gzip>. Unfortunately tar files compressed with the Unix C<compress> 2101b39c5158Smillertutility cannot be read by C<Compress::Zlib> and so cannot be directly 2102b39c5158Smillertaccesses by C<Archive::Tar>. 2103b39c5158Smillert 2104b39c5158SmillertIf the C<uncompress> or C<gunzip> programs are available, you can use 2105b39c5158Smillertone of these workarounds to read C<.tar.Z> files from C<Archive::Tar> 2106b39c5158Smillert 2107b39c5158SmillertFirstly with C<uncompress> 2108b39c5158Smillert 2109b39c5158Smillert use Archive::Tar; 2110b39c5158Smillert 2111b39c5158Smillert open F, "uncompress -c $filename |"; 2112b39c5158Smillert my $tar = Archive::Tar->new(*F); 2113b39c5158Smillert ... 2114b39c5158Smillert 2115b39c5158Smillertand this with C<gunzip> 2116b39c5158Smillert 2117b39c5158Smillert use Archive::Tar; 2118b39c5158Smillert 2119b39c5158Smillert open F, "gunzip -c $filename |"; 2120b39c5158Smillert my $tar = Archive::Tar->new(*F); 2121b39c5158Smillert ... 2122b39c5158Smillert 2123b39c5158SmillertSimilarly, if the C<compress> program is available, you can use this to 2124b39c5158Smillertwrite a C<.tar.Z> file 2125b39c5158Smillert 2126b39c5158Smillert use Archive::Tar; 2127b39c5158Smillert use IO::File; 2128b39c5158Smillert 2129b39c5158Smillert my $fh = new IO::File "| compress -c >$filename"; 2130b39c5158Smillert my $tar = Archive::Tar->new(); 2131b39c5158Smillert ... 2132b39c5158Smillert $tar->write($fh); 2133b39c5158Smillert $fh->close ; 2134b39c5158Smillert 2135b39c5158Smillert=item How do I handle Unicode strings? 2136b39c5158Smillert 2137b39c5158SmillertC<Archive::Tar> uses byte semantics for any files it reads from or writes 2138b39c5158Smillertto disk. This is not a problem if you only deal with files and never 2139b39c5158Smillertlook at their content or work solely with byte strings. But if you use 2140b39c5158SmillertUnicode strings with character semantics, some additional steps need 2141b39c5158Smillertto be taken. 2142b39c5158Smillert 2143b39c5158SmillertFor example, if you add a Unicode string like 2144b39c5158Smillert 2145b39c5158Smillert # Problem 2146b39c5158Smillert $tar->add_data('file.txt', "Euro: \x{20AC}"); 2147b39c5158Smillert 2148b39c5158Smillertthen there will be a problem later when the tarfile gets written out 2149b39c5158Smillertto disk via C<$tar->write()>: 2150b39c5158Smillert 2151b39c5158Smillert Wide character in print at .../Archive/Tar.pm line 1014. 2152b39c5158Smillert 2153b39c5158SmillertThe data was added as a Unicode string and when writing it out to disk, 2154b39c5158Smillertthe C<:utf8> line discipline wasn't set by C<Archive::Tar>, so Perl 2155b39c5158Smillerttried to convert the string to ISO-8859 and failed. The written file 2156b39c5158Smillertnow contains garbage. 2157b39c5158Smillert 2158b39c5158SmillertFor this reason, Unicode strings need to be converted to UTF-8-encoded 2159b39c5158Smillertbytestrings before they are handed off to C<add_data()>: 2160b39c5158Smillert 2161b39c5158Smillert use Encode; 2162b39c5158Smillert my $data = "Accented character: \x{20AC}"; 2163b39c5158Smillert $data = encode('utf8', $data); 2164b39c5158Smillert 2165b39c5158Smillert $tar->add_data('file.txt', $data); 2166b39c5158Smillert 2167b39c5158SmillertA opposite problem occurs if you extract a UTF8-encoded file from a 2168b39c5158Smillerttarball. Using C<get_content()> on the C<Archive::Tar::File> object 2169b39c5158Smillertwill return its content as a bytestring, not as a Unicode string. 2170b39c5158Smillert 2171b39c5158SmillertIf you want it to be a Unicode string (because you want character 2172b39c5158Smillertsemantics with operations like regular expression matching), you need 2173b39c5158Smillertto decode the UTF8-encoded content and have Perl convert it into 2174b39c5158Smillerta Unicode string: 2175b39c5158Smillert 2176b39c5158Smillert use Encode; 2177b39c5158Smillert my $data = $tar->get_content(); 2178b39c5158Smillert 2179b39c5158Smillert # Make it a Unicode string 2180b39c5158Smillert $data = decode('utf8', $data); 2181b39c5158Smillert 2182b39c5158SmillertThere is no easy way to provide this functionality in C<Archive::Tar>, 2183b39c5158Smillertbecause a tarball can contain many files, and each of which could be 2184b39c5158Smillertencoded in a different way. 2185b39c5158Smillert 2186b39c5158Smillert=back 2187b39c5158Smillert 2188b39c5158Smillert=head1 CAVEATS 2189b39c5158Smillert 2190b39c5158SmillertThe AIX tar does not fill all unused space in the tar archive with 0x00. 2191b39c5158SmillertThis sometimes leads to warning messages from C<Archive::Tar>. 2192b39c5158Smillert 2193b39c5158Smillert Invalid header block at offset nnn 2194b39c5158Smillert 2195b39c5158SmillertA fix for that problem is scheduled to be released in the following levels 2196b39c5158Smillertof AIX, all of which should be coming out in the 4th quarter of 2009: 2197b39c5158Smillert 2198b39c5158Smillert AIX 5.3 TL7 SP10 2199b39c5158Smillert AIX 5.3 TL8 SP8 2200b39c5158Smillert AIX 5.3 TL9 SP5 2201b39c5158Smillert AIX 5.3 TL10 SP2 2202b39c5158Smillert 2203b39c5158Smillert AIX 6.1 TL0 SP11 2204b39c5158Smillert AIX 6.1 TL1 SP7 2205b39c5158Smillert AIX 6.1 TL2 SP6 2206b39c5158Smillert AIX 6.1 TL3 SP3 2207b39c5158Smillert 2208b39c5158SmillertThe IBM APAR number for this problem is IZ50240 (Reported component ID: 2209b39c5158Smillert5765G0300 / AIX 5.3). It is possible to get an ifix for that problem. 2210b39c5158SmillertIf you need an ifix please contact your local IBM AIX support. 2211b39c5158Smillert 2212b39c5158Smillert=head1 TODO 2213b39c5158Smillert 2214b39c5158Smillert=over 4 2215b39c5158Smillert 2216b39c5158Smillert=item Check if passed in handles are open for read/write 2217b39c5158Smillert 2218b39c5158SmillertCurrently I don't know of any portable pure perl way to do this. 2219b39c5158SmillertSuggestions welcome. 2220b39c5158Smillert 2221b39c5158Smillert=item Allow archives to be passed in as string 2222b39c5158Smillert 2223b39c5158SmillertCurrently, we only allow opened filehandles or filenames, but 2224b39c5158Smillertnot strings. The internals would need some reworking to facilitate 2225b39c5158Smillertstringified archives. 2226b39c5158Smillert 2227b39c5158Smillert=item Facilitate processing an opened filehandle of a compressed archive 2228b39c5158Smillert 2229b39c5158SmillertCurrently, we only support this if the filehandle is an IO::Zlib object. 2230b39c5158SmillertEnvironments, like apache, will present you with an opened filehandle 2231b39c5158Smillertto an uploaded file, which might be a compressed archive. 2232b39c5158Smillert 2233b39c5158Smillert=back 2234b39c5158Smillert 2235b39c5158Smillert=head1 SEE ALSO 2236b39c5158Smillert 2237b39c5158Smillert=over 4 2238b39c5158Smillert 2239b39c5158Smillert=item The GNU tar specification 2240b39c5158Smillert 2241b39c5158SmillertC<http://www.gnu.org/software/tar/manual/tar.html> 2242b39c5158Smillert 2243898184e3Ssthen=item The PAX format specification 2244b39c5158Smillert 2245898184e3SsthenThe specification which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html> 2246b39c5158Smillert 2247b39c5158Smillert=item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html> 2248b39c5158Smillert 2249b39c5158Smillert=item GNU tar intends to switch to POSIX compatibility 2250b39c5158Smillert 2251b39c5158SmillertGNU Tar authors have expressed their intention to become completely 2252b39c5158SmillertPOSIX-compatible; C<http://www.gnu.org/software/tar/manual/html_node/Formats.html> 2253b39c5158Smillert 2254b39c5158Smillert=item A Comparison between various tar implementations 2255b39c5158Smillert 2256b39c5158SmillertLists known issues and incompatibilities; C<http://gd.tuwien.ac.at/utils/archivers/star/README.otherbugs> 2257b39c5158Smillert 2258b39c5158Smillert=back 2259b39c5158Smillert 2260b39c5158Smillert=head1 AUTHOR 2261b39c5158Smillert 2262b39c5158SmillertThis module by Jos Boumans E<lt>kane@cpan.orgE<gt>. 2263b39c5158Smillert 2264b39c5158SmillertPlease reports bugs to E<lt>bug-archive-tar@rt.cpan.orgE<gt>. 2265b39c5158Smillert 2266b39c5158Smillert=head1 ACKNOWLEDGEMENTS 2267b39c5158Smillert 2268b39c5158SmillertThanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney, Gisle Aas, 2269b39c5158SmillertRainer Tammer and especially Andrew Savige for their help and suggestions. 2270b39c5158Smillert 2271b39c5158Smillert=head1 COPYRIGHT 2272b39c5158Smillert 2273b39c5158SmillertThis module is copyright (c) 2002 - 2009 Jos Boumans 2274b39c5158SmillertE<lt>kane@cpan.orgE<gt>. All rights reserved. 2275b39c5158Smillert 2276b39c5158SmillertThis library is free software; you may redistribute and/or modify 2277b39c5158Smillertit under the same terms as Perl itself. 2278b39c5158Smillert 2279b39c5158Smillert=cut 2280