cpan/Archive-Tar/lib/Archive/Tar/File.pm

   1 package Archive::Tar::File;
   2 use strict;
   3
   4 use Carp                ();
   5 use IO::File;
   6 use File::Spec::Unix    ();
   7 use File::Spec          ();
   8 use File::Basename      ();
   9
  10 ### avoid circular use, so only require;
  11 require Archive::Tar;
  12 use Archive::Tar::Constant;
  13
  14 use vars qw[@ISA $VERSION];
  15 #@ISA        = qw[Archive::Tar];
  16 $VERSION    = '1.92';
  17
  18 ### set value to 1 to oct() it during the unpack ###
  19
  20 my $tmpl = [
  21         name        => 0,   # string                                    A100
  22         mode        => 1,   # octal                                     A8
  23         uid         => 1,   # octal                                     A8
  24         gid         => 1,   # octal                                     A8
  25         size        => 0,   # octal     # cdrake - not *always* octal.. A12
  26         mtime       => 1,   # octal                                     A12
  27         chksum      => 1,   # octal                                     A8
  28         type        => 0,   # character                                 A1
  29         linkname    => 0,   # string                                    A100
  30         magic       => 0,   # string                                    A6
  31         version     => 0,   # 2 bytes                                   A2
  32         uname       => 0,   # string                                    A32
  33         gname       => 0,   # string                                    A32
  34         devmajor    => 1,   # octal                                     A8
  35         devminor    => 1,   # octal                                     A8
  36         prefix      => 0,       #                                       A155 x 12
  37
  38 ### end UNPACK items ###
  39         raw         => 0,   # the raw data chunk
  40         data        => 0,   # the data associated with the file --
  41                             # This  might be very memory intensive
  42 ];
  43
  44 ### install get/set accessors for this object.
  45 for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
  46     my $key = $tmpl->[$i];
  47     no strict 'refs';
  48     *{__PACKAGE__."::$key"} = sub {
  49         my $self = shift;
  50         $self->{$key} = $_[0] if @_;
  51
  52         ### just in case the key is not there or undef or something ###
  53         {   local $^W = 0;
  54             return $self->{$key};
  55         }
  56     }
  57 }
  58
  59 =head1 NAME
  60
  61 Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
  62
  63 =head1 SYNOPSIS
  64
  65     my @items = $tar->get_files;
  66
  67     print $_->name, ' ', $_->size, "\n" for @items;
  68
  69     print $object->get_content;
  70     $object->replace_content('new content');
  71
  72     $object->rename( 'new/full/path/to/file.c' );
  73
  74 =head1 DESCRIPTION
  75
  76 Archive::Tar::Files provides a neat little object layer for in-memory
  77 extracted files. It's mostly used internally in Archive::Tar to tidy
  78 up the code, but there's no reason users shouldn't use this API as
  79 well.
  80
  81 =head2 Accessors
  82
  83 A lot of the methods in this package are accessors to the various
  84 fields in the tar header:
  85
  86 =over 4
  87
  88 =item name
  89
  90 The file's name
  91
  92 =item mode
  93
  94 The file's mode
  95
  96 =item uid
  97
  98 The user id owning the file
  99
 100 =item gid
 101
 102 The group id owning the file
 103
 104 =item size
 105
 106 File size in bytes
 107
 108 =item mtime
 109
 110 Modification time. Adjusted to mac-time on MacOS if required
 111
 112 =item chksum
 113
 114 Checksum field for the tar header
 115
 116 =item type
 117
 118 File type -- numeric, but comparable to exported constants -- see
 119 Archive::Tar's documentation
 120
 121 =item linkname
 122
 123 If the file is a symlink, the file it's pointing to
 124
 125 =item magic
 126
 127 Tar magic string -- not useful for most users
 128
 129 =item version
 130
 131 Tar version string -- not useful for most users
 132
 133 =item uname
 134
 135 The user name that owns the file
 136
 137 =item gname
 138
 139 The group name that owns the file
 140
 141 =item devmajor
 142
 143 Device major number in case of a special file
 144
 145 =item devminor
 146
 147 Device minor number in case of a special file
 148
 149 =item prefix
 150
 151 Any directory to prefix to the extraction path, if any
 152
 153 =item raw
 154
 155 Raw tar header -- not useful for most users
 156
 157 =back
 158
 159 =head1 Methods
 160
 161 =head2 Archive::Tar::File->new( file => $path )
 162
 163 Returns a new Archive::Tar::File object from an existing file.
 164
 165 Returns undef on failure.
 166
 167 =head2 Archive::Tar::File->new( data => $path, $data, $opt )
 168
 169 Returns a new Archive::Tar::File object from data.
 170
 171 C<$path> defines the file name (which need not exist), C<$data> the
 172 file contents, and C<$opt> is a reference to a hash of attributes
 173 which may be used to override the default attributes (fields in the
 174 tar header), which are described above in the Accessors section.
 175
 176 Returns undef on failure.
 177
 178 =head2 Archive::Tar::File->new( chunk => $chunk )
 179
 180 Returns a new Archive::Tar::File object from a raw 512-byte tar
 181 archive chunk.
 182
 183 Returns undef on failure.
 184
 185 =cut
 186
 187 sub new {
 188     my $class   = shift;
 189     my $what    = shift;
 190
 191     my $obj =   ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
 192                 ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
 193                 ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
 194                 undef;
 195
 196     return $obj;
 197 }
 198
 199 ### copies the data, creates a clone ###
 200 sub clone {
 201     my $self = shift;
 202     return bless { %$self }, ref $self;
 203 }
 204
 205 sub _new_from_chunk {
 206     my $class = shift;
 207     my $chunk = shift or return;    # 512 bytes of tar header
 208     my %hash  = @_;
 209
 210     ### filter any arguments on defined-ness of values.
 211     ### this allows overriding from what the tar-header is saying
 212     ### about this tar-entry. Particularly useful for @LongLink files
 213     my %args  = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
 214
 215     ### makes it start at 0 actually... :) ###
 216     my $i = -1;
 217     my %entry = map {
 218         my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]);       # cdrake
 219         ($_)=($_=~/^([^\0]*)/) unless($s eq 'size');    # cdrake
 220         $s=> $v ? oct $_ : $_                           # cdrake
 221         # $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_  # removed by cdrake - mucks up binary sizes >8gb
 222     } unpack( UNPACK, $chunk );                         # cdrake
 223     # } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );   # old - replaced now by cdrake
 224
 225
 226     if(substr($entry{'size'}, 0, 1) eq "\x80") {        # binary size extension for files >8gigs (> octal 77777777777777)       # cdrake
 227       my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64);       # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake
 228     } else {    # cdrake
 229       ($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'};        # cdrake
 230     }   # cdrake
 231
 232
 233     my $obj = bless { %entry, %args }, $class;
 234
 235         ### magic is a filetype string.. it should have something like 'ustar' or
 236         ### something similar... if the chunk is garbage, skip it
 237         return unless $obj->magic !~ /\W/;
 238
 239     ### store the original chunk ###
 240     $obj->raw( $chunk );
 241
 242     $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
 243     $obj->type(DIR)  if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
 244
 245
 246     return $obj;
 247
 248 }
 249
 250 sub _new_from_file {
 251     my $class       = shift;
 252     my $path        = shift;
 253
 254     ### path has to at least exist
 255     return unless defined $path;
 256
 257     my $type        = __PACKAGE__->_filetype($path);
 258     my $data        = '';
 259
 260     READ: {
 261         unless ($type == DIR ) {
 262             my $fh = IO::File->new;
 263
 264             unless( $fh->open($path) ) {
 265                 ### dangling symlinks are fine, stop reading but continue
 266                 ### creating the object
 267                 last READ if $type == SYMLINK;
 268
 269                 ### otherwise, return from this function --
 270                 ### anything that's *not* a symlink should be
 271                 ### resolvable
 272                 return;
 273             }
 274
 275             ### binmode needed to read files properly on win32 ###
 276             binmode $fh;
 277             $data = do { local $/; <$fh> };
 278             close $fh;
 279         }
 280     }
 281
 282     my @items       = qw[mode uid gid size mtime];
 283     my %hash        = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
 284
 285     if (ON_VMS) {
 286         ### VMS has two UID modes, traditional and POSIX.  Normally POSIX is
 287         ### not used.  We currently do not have an easy way to see if we are in
 288         ### POSIX mode.  In traditional mode, the UID is actually the VMS UIC.
 289         ### The VMS UIC has the upper 16 bits is the GID, which in many cases
 290         ### the VMS UIC will be larger than 209715, the largest that TAR can
 291         ### handle.  So for now, assume it is traditional if the UID is larger
 292         ### than 0x10000.
 293
 294         if ($hash{uid} > 0x10000) {
 295             $hash{uid} = $hash{uid} & 0xFFFF;
 296         }
 297
 298         ### The file length from stat() is the physical length of the file
 299         ### However the amount of data read in may be more for some file types.
 300         ### Fixed length files are read past the logical EOF to end of the block
 301         ### containing.  Other file types get expanded on read because record
 302         ### delimiters are added.
 303
 304         my $data_len = length $data;
 305         $hash{size} = $data_len if $hash{size} < $data_len;
 306
 307     }
 308     ### you *must* set size == 0 on symlinks, or the next entry will be
 309     ### though of as the contents of the symlink, which is wrong.
 310     ### this fixes bug #7937
 311     $hash{size}     = 0 if ($type == DIR or $type == SYMLINK);
 312     $hash{mtime}    -= TIME_OFFSET;
 313
 314     ### strip the high bits off the mode, which we don't need to store
 315     $hash{mode}     = STRIP_MODE->( $hash{mode} );
 316
 317
 318     ### probably requires some file path munging here ... ###
 319     ### name and prefix are set later
 320     my $obj = {
 321         %hash,
 322         name        => '',
 323         chksum      => CHECK_SUM,
 324         type        => $type,
 325         linkname    => ($type == SYMLINK and CAN_READLINK)
 326                             ? readlink $path
 327                             : '',
 328         magic       => MAGIC,
 329         version     => TAR_VERSION,
 330         uname       => UNAME->( $hash{uid} ),
 331         gname       => GNAME->( $hash{gid} ),
 332         devmajor    => 0,   # not handled
 333         devminor    => 0,   # not handled
 334         prefix      => '',
 335         data        => $data,
 336     };
 337
 338     bless $obj, $class;
 339
 340     ### fix up the prefix and file from the path
 341     my($prefix,$file) = $obj->_prefix_and_file( $path );
 342     $obj->prefix( $prefix );
 343     $obj->name( $file );
 344
 345     return $obj;
 346 }
 347
 348 sub _new_from_data {
 349     my $class   = shift;
 350     my $path    = shift;    return unless defined $path;
 351     my $data    = shift;    return unless defined $data;
 352     my $opt     = shift;
 353
 354     my $obj = {
 355         data        => $data,
 356         name        => '',
 357         mode        => MODE,
 358         uid         => UID,
 359         gid         => GID,
 360         size        => length $data,
 361         mtime       => time - TIME_OFFSET,
 362         chksum      => CHECK_SUM,
 363         type        => FILE,
 364         linkname    => '',
 365         magic       => MAGIC,
 366         version     => TAR_VERSION,
 367         uname       => UNAME->( UID ),
 368         gname       => GNAME->( GID ),
 369         devminor    => 0,
 370         devmajor    => 0,
 371         prefix      => '',
 372     };
 373
 374     ### overwrite with user options, if provided ###
 375     if( $opt and ref $opt eq 'HASH' ) {
 376         for my $key ( keys %$opt ) {
 377
 378             ### don't write bogus options ###
 379             next unless exists $obj->{$key};
 380             $obj->{$key} = $opt->{$key};
 381         }
 382     }
 383
 384     bless $obj, $class;
 385
 386     ### fix up the prefix and file from the path
 387     my($prefix,$file) = $obj->_prefix_and_file( $path );
 388     $obj->prefix( $prefix );
 389     $obj->name( $file );
 390
 391     return $obj;
 392 }
 393
 394 sub _prefix_and_file {
 395     my $self = shift;
 396     my $path = shift;
 397
 398     my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
 399     my @dirs = File::Spec->splitdir( $dirs );
 400
 401     ### so sometimes the last element is '' -- probably when trailing
 402     ### dir slashes are encountered... this is of course pointless,
 403     ### so remove it
 404     pop @dirs while @dirs and not length $dirs[-1];
 405
 406     ### if it's a directory, then $file might be empty
 407     $file = pop @dirs if $self->is_dir and not length $file;
 408
 409     ### splitting ../ gives you the relative path in native syntax
 410     map { $_ = '..' if $_  eq '-' } @dirs if ON_VMS;
 411
 412     my $prefix = File::Spec::Unix->catdir(
 413                         grep { length } $vol, @dirs
 414                     );
 415     return( $prefix, $file );
 416 }
 417
 418 sub _filetype {
 419     my $self = shift;
 420     my $file = shift;
 421
 422     return unless defined $file;
 423
 424     return SYMLINK  if (-l $file);      # Symlink
 425
 426     return FILE     if (-f _);          # Plain file
 427
 428     return DIR      if (-d _);          # Directory
 429
 430     return FIFO     if (-p _);          # Named pipe
 431
 432     return SOCKET   if (-S _);          # Socket
 433
 434     return BLOCKDEV if (-b _);          # Block special
 435
 436     return CHARDEV  if (-c _);          # Character special
 437
 438     ### shouldn't happen, this is when making archives, not reading ###
 439     return LONGLINK if ( $file eq LONGLINK_NAME );
 440
 441     return UNKNOWN;                         # Something else (like what?)
 442
 443 }
 444
 445 ### this method 'downgrades' a file to plain file -- this is used for
 446 ### symlinks when FOLLOW_SYMLINKS is true.
 447 sub _downgrade_to_plainfile {
 448     my $entry = shift;
 449     $entry->type( FILE );
 450     $entry->mode( MODE );
 451     $entry->linkname('');
 452
 453     return 1;
 454 }
 455
 456 =head2 $bool = $file->extract( [ $alternative_name ] )
 457
 458 Extract this object, optionally to an alternative name.
 459
 460 See C<< Archive::Tar->extract_file >> for details.
 461
 462 Returns true on success and false on failure.
 463
 464 =cut
 465
 466 sub extract {
 467     my $self = shift;
 468
 469     local $Carp::CarpLevel += 1;
 470
 471     return Archive::Tar->_extract_file( $self, @_ );
 472 }
 473
 474 =head2 $path = $file->full_path
 475
 476 Returns the full path from the tar header; this is basically a
 477 concatenation of the C<prefix> and C<name> fields.
 478
 479 =cut
 480
 481 sub full_path {
 482     my $self = shift;
 483
 484     ### if prefix field is empty
 485     return $self->name unless defined $self->prefix and length $self->prefix;
 486
 487     ### or otherwise, catfile'd
 488     return File::Spec::Unix->catfile( $self->prefix, $self->name );
 489 }
 490
 491
 492 =head2 $bool = $file->validate
 493
 494 Done by Archive::Tar internally when reading the tar file:
 495 validate the header against the checksum to ensure integer tar file.
 496
 497 Returns true on success, false on failure
 498
 499 =cut
 500
 501 sub validate {
 502     my $self = shift;
 503
 504     my $raw = $self->raw;
 505
 506     ### don't know why this one is different from the one we /write/ ###
 507     substr ($raw, 148, 8) = "        ";
 508
 509     ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
 510     ### like GNU tar does. See here for details:
 511     ### http://www.gnu.org/software/tar/manual/tar.html#SEC139
 512     ### so we do both a signed AND unsigned validate. if one succeeds, that's
 513     ### good enough
 514         return (   (unpack ("%16C*", $raw) == $self->chksum)
 515                 or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
 516 }
 517
 518 =head2 $bool = $file->has_content
 519
 520 Returns a boolean to indicate whether the current object has content.
 521 Some special files like directories and so on never will have any
 522 content. This method is mainly to make sure you don't get warnings
 523 for using uninitialized values when looking at an object's content.
 524
 525 =cut
 526
 527 sub has_content {
 528     my $self = shift;
 529     return defined $self->data() && length $self->data() ? 1 : 0;
 530 }
 531
 532 =head2 $content = $file->get_content
 533
 534 Returns the current content for the in-memory file
 535
 536 =cut
 537
 538 sub get_content {
 539     my $self = shift;
 540     $self->data( );
 541 }
 542
 543 =head2 $cref = $file->get_content_by_ref
 544
 545 Returns the current content for the in-memory file as a scalar
 546 reference. Normal users won't need this, but it will save memory if
 547 you are dealing with very large data files in your tar archive, since
 548 it will pass the contents by reference, rather than make a copy of it
 549 first.
 550
 551 =cut
 552
 553 sub get_content_by_ref {
 554     my $self = shift;
 555
 556     return \$self->{data};
 557 }
 558
 559 =head2 $bool = $file->replace_content( $content )
 560
 561 Replace the current content of the file with the new content. This
 562 only affects the in-memory archive, not the on-disk version until
 563 you write it.
 564
 565 Returns true on success, false on failure.
 566
 567 =cut
 568
 569 sub replace_content {
 570     my $self = shift;
 571     my $data = shift || '';
 572
 573     $self->data( $data );
 574     $self->size( length $data );
 575     return 1;
 576 }
 577
 578 =head2 $bool = $file->rename( $new_name )
 579
 580 Rename the current file to $new_name.
 581
 582 Note that you must specify a Unix path for $new_name, since per tar
 583 standard, all files in the archive must be Unix paths.
 584
 585 Returns true on success and false on failure.
 586
 587 =cut
 588
 589 sub rename {
 590     my $self = shift;
 591     my $path = shift;
 592
 593     return unless defined $path;
 594
 595     my ($prefix,$file) = $self->_prefix_and_file( $path );
 596
 597     $self->name( $file );
 598     $self->prefix( $prefix );
 599
 600         return 1;
 601 }
 602
 603 =head2 $bool = $file->chmod $mode)
 604
 605 Change mode of $file to $mode. The mode can be a string or a number
 606 which is interpreted as octal whether or not a leading 0 is given.
 607
 608 Returns true on success and false on failure.
 609
 610 =cut
 611
 612 sub chmod {
 613     my $self  = shift;
 614     my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
 615     $self->{mode} = oct($mode);
 616     return 1;
 617 }
 618
 619 =head2 $bool = $file->chown( $user [, $group])
 620
 621 Change owner of $file to $user. If a $group is given that is changed
 622 as well. You can also pass a single parameter with a colon separating the
 623 use and group as in 'root:wheel'.
 624
 625 Returns true on success and false on failure.
 626
 627 =cut
 628
 629 sub chown {
 630     my $self = shift;
 631     my $uname = shift;
 632     return unless defined $uname;
 633     my $gname;
 634     if (-1 != index($uname, ':')) {
 635         ($uname, $gname) = split(/:/, $uname);
 636     } else {
 637         $gname = shift if @_ > 0;
 638     }
 639
 640     $self->uname( $uname );
 641     $self->gname( $gname ) if $gname;
 642         return 1;
 643 }
 644
 645 =head1 Convenience methods
 646
 647 To quickly check the type of a C<Archive::Tar::File> object, you can
 648 use the following methods:
 649
 650 =over 4
 651
 652 =item $file->is_file
 653
 654 Returns true if the file is of type C<file>
 655
 656 =item $file->is_dir
 657
 658 Returns true if the file is of type C<dir>
 659
 660 =item $file->is_hardlink
 661
 662 Returns true if the file is of type C<hardlink>
 663
 664 =item $file->is_symlink
 665
 666 Returns true if the file is of type C<symlink>
 667
 668 =item $file->is_chardev
 669
 670 Returns true if the file is of type C<chardev>
 671
 672 =item $file->is_blockdev
 673
 674 Returns true if the file is of type C<blockdev>
 675
 676 =item $file->is_fifo
 677
 678 Returns true if the file is of type C<fifo>
 679
 680 =item $file->is_socket
 681
 682 Returns true if the file is of type C<socket>
 683
 684 =item $file->is_longlink
 685
 686 Returns true if the file is of type C<LongLink>.
 687 Should not happen after a successful C<read>.
 688
 689 =item $file->is_label
 690
 691 Returns true if the file is of type C<Label>.
 692 Should not happen after a successful C<read>.
 693
 694 =item $file->is_unknown
 695
 696 Returns true if the file type is C<unknown>
 697
 698 =back
 699
 700 =cut
 701
 702 #stupid perl5.5.3 needs to warn if it's not numeric
 703 sub is_file     { local $^W;    FILE      == $_[0]->type }
 704 sub is_dir      { local $^W;    DIR       == $_[0]->type }
 705 sub is_hardlink { local $^W;    HARDLINK  == $_[0]->type }
 706 sub is_symlink  { local $^W;    SYMLINK   == $_[0]->type }
 707 sub is_chardev  { local $^W;    CHARDEV   == $_[0]->type }
 708 sub is_blockdev { local $^W;    BLOCKDEV  == $_[0]->type }
 709 sub is_fifo     { local $^W;    FIFO      == $_[0]->type }
 710 sub is_socket   { local $^W;    SOCKET    == $_[0]->type }
 711 sub is_unknown  { local $^W;    UNKNOWN   == $_[0]->type }
 712 sub is_longlink { local $^W;    LONGLINK  eq $_[0]->type }
 713 sub is_label    { local $^W;    LABEL     eq $_[0]->type }
 714
 715 1;