lib/Archive/Tar/File.pm

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