1 package Archive::Tar::File;
5 use File::Spec::Unix ();
9 use Archive::Tar::Constant;
11 use vars qw[@ISA $VERSION];
12 @ISA = qw[Archive::Tar];
15 ### set value to 1 to oct() it during the unpack ###
24 type => 0, # character
25 linkname => 0, # string
27 version => 0, # 2 bytes
30 devmajor => 1, # octal
31 devminor => 1, # octal
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
40 ### install get/set accessors for this object.
41 for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
42 my $key = $tmpl->[$i];
44 *{__PACKAGE__."::$key"} = sub {
46 $self->{$key} = $_[0] if @_;
48 ### just in case the key is not there or undef or something ###
57 Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
61 my @items = $tar->get_files;
63 print $_->name, ' ', $_->size, "\n" for @items;
65 print $object->get_content;
66 $object->replace_content('new content');
68 $object->rename( 'new/full/path/to/file.c' );
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
79 A lot of the methods in this package are accessors to the various
80 fields in the tar header:
94 The user id owning the file
98 The group id owning the file
106 Modification time. Adjusted to mac-time on MacOS if required
110 Checksum field for the tar header
114 File type -- numeric, but comparable to exported constants -- see
115 Archive::Tar's documentation
119 If the file is a symlink, the file it's pointing to
123 Tar magic string -- not useful for most users
127 Tar version string -- not useful for most users
131 The user name that owns the file
135 The group name that owns the file
139 Device major number in case of a special file
143 Device minor number in case of a special file
147 Any directory to prefix to the extraction path, if any
151 Raw tar header -- not useful for most users
157 =head2 new( file => $path )
159 Returns a new Archive::Tar::File object from an existing file.
161 Returns undef on failure.
163 =head2 new( data => $path, $data, $opt )
165 Returns a new Archive::Tar::File object from data.
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.
172 Returns undef on failure.
174 =head2 new( chunk => $chunk )
176 Returns a new Archive::Tar::File object from a raw 512-byte tar
179 Returns undef on failure.
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( @_ ) :
195 ### copies the data, creates a clone ###
198 return bless { %$self }, ref $self;
201 sub _new_from_chunk {
203 my $chunk = shift or return;
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;
211 ### makes it start at 0 actually... :) ###
214 $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
215 } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
217 my $obj = bless { %entry, %args }, $class;
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/;
223 ### store the original chunk ###
226 $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
227 $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
236 my $path = shift or return;
237 my $type = __PACKAGE__->_filetype($path);
240 unless ($type == DIR) {
241 my $fh = IO::File->new;
242 $fh->open($path) or return;
244 ### binmode needed to read files properly on win32 ###
246 $data = do { local $/; <$fh> };
250 my @items = qw[mode uid gid size mtime];
251 my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
253 ### you *must* set size == 0 on symlinks, or the next entry will be
254 ### though of as the contents of the symlink, which is wrong.
255 ### this fixes bug #7937
256 $hash{size} = 0 if ($type == DIR or $type == SYMLINK);
257 $hash{mtime} -= TIME_OFFSET;
259 ### strip the high bits off the mode, which we don't need to store
260 $hash{mode} = STRIP_MODE->( $hash{mode} );
263 ### probably requires some file path munging here ... ###
264 ### name and prefix are set later
270 linkname => ($type == SYMLINK and CAN_READLINK)
274 version => TAR_VERSION,
275 uname => UNAME->( $hash{uid} ),
276 gname => GNAME->( $hash{gid} ),
277 devmajor => 0, # not handled
278 devminor => 0, # not handled
285 ### fix up the prefix and file from the path
286 my($prefix,$file) = $obj->_prefix_and_file( $path );
287 $obj->prefix( $prefix );
295 my $path = shift or return;
296 my $data = shift; return unless defined $data;
305 size => length $data,
306 mtime => time - TIME_OFFSET,
311 version => TAR_VERSION,
312 uname => UNAME->( UID ),
313 gname => GNAME->( GID ),
319 ### overwrite with user options, if provided ###
320 if( $opt and ref $opt eq 'HASH' ) {
321 for my $key ( keys %$opt ) {
323 ### don't write bogus options ###
324 next unless exists $obj->{$key};
325 $obj->{$key} = $opt->{$key};
331 ### fix up the prefix and file from the path
332 my($prefix,$file) = $obj->_prefix_and_file( $path );
333 $obj->prefix( $prefix );
339 sub _prefix_and_file {
343 my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
344 my @dirs = File::Spec->splitdir( $dirs );
346 ### so sometimes the last element is '' -- probably when trailing
347 ### dir slashes are encountered... this is is of course pointless,
349 pop @dirs while @dirs and not length $dirs[-1];
351 ### if it's a directory, then $file might be empty
352 $file = pop @dirs if $self->is_dir and not length $file;
354 my $prefix = File::Spec::Unix->catdir(
355 grep { length } $vol, @dirs
357 return( $prefix, $file );
362 my $file = shift or return;
364 return SYMLINK if (-l $file); # Symlink
366 return FILE if (-f _); # Plain file
368 return DIR if (-d _); # Directory
370 return FIFO if (-p _); # Named pipe
372 return SOCKET if (-S _); # Socket
374 return BLOCKDEV if (-b _); # Block special
376 return CHARDEV if (-c _); # Character special
378 ### shouldn't happen, this is when making archives, not reading ###
379 return LONGLINK if ( $file eq LONGLINK_NAME );
381 return UNKNOWN; # Something else (like what?)
385 ### this method 'downgrades' a file to plain file -- this is used for
386 ### symlinks when FOLLOW_SYMLINKS is true.
387 sub _downgrade_to_plainfile {
389 $entry->type( FILE );
390 $entry->mode( MODE );
391 $entry->linkname('');
398 Returns the full path from the tar header; this is basically a
399 concatenation of the C<prefix> and C<name> fields.
406 ### if prefix field is emtpy
407 return $self->name unless defined $self->prefix and length $self->prefix;
409 ### or otherwise, catfile'd
410 return File::Spec::Unix->catfile( $self->prefix, $self->name );
416 Done by Archive::Tar internally when reading the tar file:
417 validate the header against the checksum to ensure integer tar file.
419 Returns true on success, false on failure
426 my $raw = $self->raw;
428 ### don't know why this one is different from the one we /write/ ###
429 substr ($raw, 148, 8) = " ";
430 return unpack ("%16C*", $raw) == $self->chksum ? 1 : 0;
435 Returns a boolean to indicate whether the current object has content.
436 Some special files like directories and so on never will have any
437 content. This method is mainly to make sure you don't get warnings
438 for using uninitialized values when looking at an object's content.
444 return defined $self->data() && length $self->data() ? 1 : 0;
449 Returns the current content for the in-memory file
458 =head2 get_content_by_ref
460 Returns the current content for the in-memory file as a scalar
461 reference. Normal users won't need this, but it will save memory if
462 you are dealing with very large data files in your tar archive, since
463 it will pass the contents by reference, rather than make a copy of it
468 sub get_content_by_ref {
471 return \$self->{data};
474 =head2 replace_content( $content )
476 Replace the current content of the file with the new content. This
477 only affects the in-memory archive, not the on-disk version until
480 Returns true on success, false on failure.
484 sub replace_content {
486 my $data = shift || '';
488 $self->data( $data );
489 $self->size( length $data );
493 =head2 rename( $new_name )
495 Rename the current file to $new_name.
497 Note that you must specify a Unix path for $new_name, since per tar
498 standard, all files in the archive must be Unix paths.
500 Returns true on success and false on failure.
506 my $path = shift or return;
508 my ($prefix,$file) = $self->_prefix_and_file( $path );
510 $self->name( $file );
511 $self->prefix( $prefix );
516 =head1 Convenience methods
518 To quickly check the type of a C<Archive::Tar::File> object, you can
519 use the following methods:
525 Returns true if the file is of type C<file>
529 Returns true if the file is of type C<dir>
533 Returns true if the file is of type C<hardlink>
537 Returns true if the file is of type C<symlink>
541 Returns true if the file is of type C<chardev>
545 Returns true if the file is of type C<blockdev>
549 Returns true if the file is of type C<fifo>
553 Returns true if the file is of type C<socket>
557 Returns true if the file is of type C<LongLink>.
558 Should not happen after a successful C<read>.
562 Returns true if the file is of type C<Label>.
563 Should not happen after a successful C<read>.
567 Returns true if the file type is C<unknown>
573 #stupid perl5.5.3 needs to warn if it's not numeric
574 sub is_file { local $^W; FILE == $_[0]->type }
575 sub is_dir { local $^W; DIR == $_[0]->type }
576 sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
577 sub is_symlink { local $^W; SYMLINK == $_[0]->type }
578 sub is_chardev { local $^W; CHARDEV == $_[0]->type }
579 sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
580 sub is_fifo { local $^W; FIFO == $_[0]->type }
581 sub is_socket { local $^W; SOCKET == $_[0]->type }
582 sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
583 sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
584 sub is_label { local $^W; LABEL eq $_[0]->type }