1 package Archive::Tar::File;
5 use File::Spec::Unix ();
8 use Archive::Tar::Constant;
10 use vars qw[@ISA $VERSION];
11 @ISA = qw[Archive::Tar];
14 ### set value to 1 to oct() it during the unpack ###
23 type => 0, # character
24 linkname => 0, # string
26 version => 0, # 2 bytes
29 devmajor => 1, # octal
30 devminor => 1, # octal
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
39 ### install get/set accessors for this object.
40 for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
41 my $key = $tmpl->[$i];
43 *{__PACKAGE__."::$key"} = sub {
45 $self->{$key} = $_[0] if @_;
47 ### just in case the key is not there or undef or something ###
56 Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
60 my @items = $tar->get_files;
62 print $_->name, ' ', $_->size, "\n" for @items;
64 print $object->get_content;
65 $object->replace_content('new content');
67 $object->rename( 'new/full/path/to/file.c' );
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
78 A lot of the methods in this package are accessors to the various
79 fields in the tar header:
93 The user id owning the file
97 The group id owning the file
105 Modification time. Adjusted to mac-time on MacOS if required
109 Checksum field for the tar header
113 File type -- numeric, but comparable to exported constants -- see
114 Archive::Tar's documentation
118 If the file is a symlink, the file it's pointing to
122 Tar magic string -- not useful for most users
126 Tar version string -- not useful for most users
130 The user name that owns the file
134 The group name that owns the file
138 Device major number in case of a special file
142 Device minor number in case of a special file
146 Any directory to prefix to the extraction path, if any
150 Raw tar header -- not useful for most users
156 =head2 new( file => $path )
158 Returns a new Archive::Tar::File object from an existing file.
160 Returns undef on failure.
162 =head2 new( data => $path, $data, $opt )
164 Returns a new Archive::Tar::File object from data.
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.
171 Returns undef on failure.
173 =head2 new( chunk => $chunk )
175 Returns a new Archive::Tar::File object from a raw 512-byte tar
178 Returns undef on failure.
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( @_ ) :
194 ### copies the data, creates a clone ###
197 return bless { %$self }, ref $self;
200 sub _new_from_chunk {
202 my $chunk = shift or return;
204 ### makes it start at 0 actually... :) ###
207 $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
208 } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
210 my $obj = bless \%entry, $class;
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/;
216 ### store the original chunk ###
219 $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
220 $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
229 my $path = shift or return;
230 my $type = __PACKAGE__->_filetype($path);
233 unless ($type == DIR) {
234 my $fh = IO::File->new;
235 $fh->open($path) or return;
237 ### binmode needed to read files properly on win32 ###
239 $data = do { local $/; <$fh> };
243 my @items = qw[mode uid gid size mtime];
244 my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
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;
252 ### strip the high bits off the mode, which we don't need to store
253 $hash{mode} = STRIP_MODE->( $hash{mode} );
256 ### probably requires some file path munging here ... ###
257 ### name and prefix are set later
263 linkname => ($type == SYMLINK and CAN_READLINK)
267 version => TAR_VERSION,
268 uname => UNAME->( $hash{uid} ),
269 gname => GNAME->( $hash{gid} ),
270 devmajor => 0, # not handled
271 devminor => 0, # not handled
278 ### fix up the prefix and file from the path
279 my($prefix,$file) = $obj->_prefix_and_file( $path );
280 $obj->prefix( $prefix );
288 my $path = shift or return;
289 my $data = shift; return unless defined $data;
298 size => length $data,
299 mtime => time - TIME_OFFSET,
304 version => TAR_VERSION,
305 uname => UNAME->( UID ),
306 gname => GNAME->( GID ),
312 ### overwrite with user options, if provided ###
313 if( $opt and ref $opt eq 'HASH' ) {
314 for my $key ( keys %$opt ) {
316 ### don't write bogus options ###
317 next unless exists $obj->{$key};
318 $obj->{$key} = $opt->{$key};
324 ### fix up the prefix and file from the path
325 my($prefix,$file) = $obj->_prefix_and_file( $path );
326 $obj->prefix( $prefix );
332 sub _prefix_and_file {
336 my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
337 my @dirs = File::Spec->splitdir( $dirs );
339 ### so sometimes the last element is '' -- probably when trailing
340 ### dir slashes are encountered... this is is of course pointless,
342 pop @dirs while @dirs and not length $dirs[-1];
344 ### if it's a directory, then $file might be empty
345 $file = pop @dirs if $self->is_dir and not length $file;
347 my $prefix = File::Spec::Unix->catdir(
348 grep { length } $vol, @dirs
350 return( $prefix, $file );
355 my $file = shift or return;
357 return SYMLINK if (-l $file); # Symlink
359 return FILE if (-f _); # Plain file
361 return DIR if (-d _); # Directory
363 return FIFO if (-p _); # Named pipe
365 return SOCKET if (-S _); # Socket
367 return BLOCKDEV if (-b _); # Block special
369 return CHARDEV if (-c _); # Character special
371 ### shouldn't happen, this is when making archives, not reading ###
372 return LONGLINK if ( $file eq LONGLINK_NAME );
374 return UNKNOWN; # Something else (like what?)
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 {
382 $entry->type( FILE );
383 $entry->mode( MODE );
384 $entry->linkname('');
391 Returns the full path from the tar header; this is basically a
392 concatenation of the C<prefix> and C<name> fields.
399 ### if prefix field is emtpy
400 return $self->name unless defined $self->prefix and length $self->prefix;
402 ### or otherwise, catfile'd
403 return File::Spec::Unix->catfile( $self->prefix, $self->name );
409 Done by Archive::Tar internally when reading the tar file:
410 validate the header against the checksum to ensure integer tar file.
412 Returns true on success, false on failure
419 my $raw = $self->raw;
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;
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.
437 return defined $self->data() && length $self->data() ? 1 : 0;
442 Returns the current content for the in-memory file
451 =head2 get_content_by_ref
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
461 sub get_content_by_ref {
464 return \$self->{data};
467 =head2 replace_content( $content )
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
473 Returns true on success, false on failure.
477 sub replace_content {
479 my $data = shift || '';
481 $self->data( $data );
482 $self->size( length $data );
486 =head2 rename( $new_name )
488 Rename the current file to $new_name.
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.
493 Returns true on success and false on failure.
499 my $path = shift or return;
501 my ($prefix,$file) = $self->_prefix_and_file( $path );
503 $self->name( $file );
504 $self->prefix( $prefix );
509 =head1 Convenience methods
511 To quickly check the type of a C<Archive::Tar::File> object, you can
512 use the following methods:
518 Returns true if the file is of type C<file>
522 Returns true if the file is of type C<dir>
526 Returns true if the file is of type C<hardlink>
530 Returns true if the file is of type C<symlink>
534 Returns true if the file is of type C<chardev>
538 Returns true if the file is of type C<blockdev>
542 Returns true if the file is of type C<fifo>
546 Returns true if the file is of type C<socket>
550 Returns true if the file is of type C<LongLink>.
551 Should not happen after a successful C<read>.
555 Returns true if the file is of type C<Label>.
556 Should not happen after a successful C<read>.
560 Returns true if the file type is C<unknown>
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 }