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