[Summary view] [Print] [Text view]

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