[p5sagit/p5-mst-13.2.git] / lib / Archive / Tar / File.pm

package Archive::Tar::File;
use strict;

use IO::File;
use File::Spec::Unix    ();
use File::Spec          ();
use File::Basename      ();

use Archive::Tar::Constant;

use vars qw[@ISA $VERSION];
@ISA        = qw[Archive::Tar];
$VERSION    = '0.02';

### set value to 1 to oct() it during the unpack ###
my $tmpl = [
        name        => 0,   # string
        mode        => 1,   # octal
        uid         => 1,   # octal
        gid         => 1,   # octal
        size        => 1,   # octal
        mtime       => 1,   # octal
        chksum      => 1,   # octal
        type        => 0,   # character
        linkname    => 0,   # string
        magic       => 0,   # string
        version     => 0,   # 2 bytes
        uname       => 0,   # string
        gname       => 0,   # string
        devmajor    => 1,   # octal
        devminor    => 1,   # octal
        prefix      => 0,

### end UNPACK items ###
        raw         => 0,   # the raw data chunk
        data        => 0,   # the data associated with the file --
                            # This  might be very memory intensive
];

### install get/set accessors for this object.
for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
    my $key = $tmpl->[$i];
    no strict 'refs';
    *{__PACKAGE__."::$key"} = sub {
        my $self = shift;
        $self->{$key} = $_[0] if @_;

        ### just in case the key is not there or undef or something ###
        {   local $^W = 0;
            return $self->{$key};
        }
    }
}

=head1 NAME

Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar

=head1 SYNOPSIS

    my @items = $tar->get_files;

    print $_->name, ' ', $_->size, "\n" for @items;

    print $object->get_content;
    $object->replace_content('new content');

    $object->rename( 'new/full/path/to/file.c' );

=head1 DESCRIPTION

Archive::Tar::Files provides a neat little object layer for in-memory
extracted files. It's mostly used internally in Archive::Tar to tidy
up the code, but there's no reason users shouldn't use this API as
well.

=head2 Accessors

A lot of the methods in this package are accessors to the various
fields in the tar header:

=over 4

=item name

The file's name

=item mode

The file's mode

=item uid

The user id owning the file

=item gid

The group id owning the file

=item size

File size in bytes

=item mtime

Modification time. Adjusted to mac-time on MacOS if required

=item chksum

Checksum field for the tar header

=item type

File type -- numeric, but comparable to exported constants -- see
Archive::Tar's documentation

=item linkname

If the file is a symlink, the file it's pointing to

=item magic

Tar magic string -- not useful for most users

=item version

Tar version string -- not useful for most users

=item uname

The user name that owns the file

=item gname

The group name that owns the file

=item devmajor

Device major number in case of a special file

=item devminor

Device minor number in case of a special file

=item prefix

Any directory to prefix to the extraction path, if any

=item raw

Raw tar header -- not useful for most users

=back

=head1 Methods

=head2 new( file => $path )

Returns a new Archive::Tar::File object from an existing file.

Returns undef on failure.

=head2 new( data => $path, $data, $opt )

Returns a new Archive::Tar::File object from data.

C<$path> defines the file name (which need not exist), C<$data> the
file contents, and C<$opt> is a reference to a hash of attributes
which may be used to override the default attributes (fields in the
tar header), which are described above in the Accessors section.

Returns undef on failure.

=head2 new( chunk => $chunk )

Returns a new Archive::Tar::File object from a raw 512-byte tar
archive chunk.

Returns undef on failure.

=cut

sub new {
    my $class   = shift;
    my $what    = shift;

    my $obj =   ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
                ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
                ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
                undef;

    return $obj;
}

### copies the data, creates a clone ###
sub clone {
    my $self = shift;
    return bless { %$self }, ref $self;
}

sub _new_from_chunk {
    my $class = shift;
    my $chunk = shift or return;
    my %hash  = @_;

    ### filter any arguments on defined-ness of values.
    ### this allows overriding from what the tar-header is saying
    ### about this tar-entry. Particularly useful for @LongLink files
    my %args  = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;

    ### makes it start at 0 actually... :) ###
    my $i = -1;
    my %entry = map {
        $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
    } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );

    my $obj = bless { %entry, %args }, $class;

	### magic is a filetype string.. it should have something like 'ustar' or
	### something similar... if the chunk is garbage, skip it
	return unless $obj->magic !~ /\W/;

    ### store the original chunk ###
    $obj->raw( $chunk );

    $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
    $obj->type(DIR)  if ( ($obj->is_file) && ($obj->name =~ m|/$|) );


    return $obj;

}

sub _new_from_file {
    my $class       = shift;
    my $path        = shift or return;
    my $type        = __PACKAGE__->_filetype($path);
    my $data        = '';

    READ: { 
        unless ($type == DIR ) {
            my $fh = IO::File->new;
        
            unless( $fh->open($path) ) {
                ### dangling symlinks are fine, stop reading but continue
                ### creating the object
                last READ if $type == SYMLINK;
                
                ### otherwise, return from this function --
                ### anything that's *not* a symlink should be
                ### resolvable
                return;
            }

            ### binmode needed to read files properly on win32 ###
            binmode $fh;
            $data = do { local $/; <$fh> };
            close $fh;
        }
    }

    my @items       = qw[mode uid gid size mtime];
    my %hash        = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];

    ### you *must* set size == 0 on symlinks, or the next entry will be
    ### though of as the contents of the symlink, which is wrong.
    ### this fixes bug #7937
    $hash{size}     = 0 if ($type == DIR or $type == SYMLINK);
    $hash{mtime}    -= TIME_OFFSET;

    ### strip the high bits off the mode, which we don't need to store
    $hash{mode}     = STRIP_MODE->( $hash{mode} );


    ### probably requires some file path munging here ... ###
    ### name and prefix are set later
    my $obj = {
        %hash,
        name        => '',
        chksum      => CHECK_SUM,
        type        => $type,
        linkname    => ($type == SYMLINK and CAN_READLINK)
                            ? readlink $path
                            : '',
        magic       => MAGIC,
        version     => TAR_VERSION,
        uname       => UNAME->( $hash{uid} ),
        gname       => GNAME->( $hash{gid} ),
        devmajor    => 0,   # not handled
        devminor    => 0,   # not handled
        prefix      => '',
        data        => $data,
    };

    bless $obj, $class;

    ### fix up the prefix and file from the path
    my($prefix,$file) = $obj->_prefix_and_file( $path );
    $obj->prefix( $prefix );
    $obj->name( $file );

    return $obj;
}

sub _new_from_data {
    my $class   = shift;
    my $path    = shift     or return;
    my $data    = shift;    return unless defined $data;
    my $opt     = shift;

    my $obj = {
        data        => $data,
        name        => '',
        mode        => MODE,
        uid         => UID,
        gid         => GID,
        size        => length $data,
        mtime       => time - TIME_OFFSET,
        chksum      => CHECK_SUM,
        type        => FILE,
        linkname    => '',
        magic       => MAGIC,
        version     => TAR_VERSION,
        uname       => UNAME->( UID ),
        gname       => GNAME->( GID ),
        devminor    => 0,
        devmajor    => 0,
        prefix      => '',
    };

    ### overwrite with user options, if provided ###
    if( $opt and ref $opt eq 'HASH' ) {
        for my $key ( keys %$opt ) {

            ### don't write bogus options ###
            next unless exists $obj->{$key};
            $obj->{$key} = $opt->{$key};
        }
    }

    bless $obj, $class;

    ### fix up the prefix and file from the path
    my($prefix,$file) = $obj->_prefix_and_file( $path );
    $obj->prefix( $prefix );
    $obj->name( $file );

    return $obj;
}

sub _prefix_and_file {
    my $self = shift;
    my $path = shift;

    my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
    my @dirs = File::Spec->splitdir( $dirs );

    ### so sometimes the last element is '' -- probably when trailing
    ### dir slashes are encountered... this is is of course pointless,
    ### so remove it
    pop @dirs while @dirs and not length $dirs[-1];

    ### if it's a directory, then $file might be empty
    $file = pop @dirs if $self->is_dir and not length $file;

    my $prefix = File::Spec::Unix->catdir(
                        grep { length } $vol, @dirs
                    );
    return( $prefix, $file );
}

sub _filetype {
    my $self = shift;
    my $file = shift or return;

    return SYMLINK  if (-l $file);	# Symlink

    return FILE     if (-f _);		# Plain file

    return DIR      if (-d _);		# Directory

    return FIFO     if (-p _);		# Named pipe

    return SOCKET   if (-S _);		# Socket

    return BLOCKDEV if (-b _);		# Block special

    return CHARDEV  if (-c _);		# Character special

    ### shouldn't happen, this is when making archives, not reading ###
    return LONGLINK if ( $file eq LONGLINK_NAME );

    return UNKNOWN;		            # Something else (like what?)

}

### this method 'downgrades' a file to plain file -- this is used for
### symlinks when FOLLOW_SYMLINKS is true.
sub _downgrade_to_plainfile {
    my $entry = shift;
    $entry->type( FILE );
    $entry->mode( MODE );
    $entry->linkname('');

    return 1;
}

=head2 full_path

Returns the full path from the tar header; this is basically a
concatenation of the C<prefix> and C<name> fields.

=cut

sub full_path {
    my $self = shift;

    ### if prefix field is emtpy
    return $self->name unless defined $self->prefix and length $self->prefix;

    ### or otherwise, catfile'd
    return File::Spec::Unix->catfile( $self->prefix, $self->name );
}


=head2 validate

Done by Archive::Tar internally when reading the tar file:
validate the header against the checksum to ensure integer tar file.

Returns true on success, false on failure

=cut

sub validate {
    my $self = shift;

    my $raw = $self->raw;

    ### don't know why this one is different from the one we /write/ ###
    substr ($raw, 148, 8) = "        ";
	return unpack ("%16C*", $raw) == $self->chksum ? 1 : 0;
}

=head2 has_content

Returns a boolean to indicate whether the current object has content.
Some special files like directories and so on never will have any
content. This method is mainly to make sure you don't get warnings
for using uninitialized values when looking at an object's content.

=cut

sub has_content {
    my $self = shift;
    return defined $self->data() && length $self->data() ? 1 : 0;
}

=head2 get_content

Returns the current content for the in-memory file

=cut

sub get_content {
    my $self = shift;
    $self->data( );
}

=head2 get_content_by_ref

Returns the current content for the in-memory file as a scalar
reference. Normal users won't need this, but it will save memory if
you are dealing with very large data files in your tar archive, since
it will pass the contents by reference, rather than make a copy of it
first.

=cut

sub get_content_by_ref {
    my $self = shift;

    return \$self->{data};
}

=head2 replace_content( $content )

Replace the current content of the file with the new content. This
only affects the in-memory archive, not the on-disk version until
you write it.

Returns true on success, false on failure.

=cut

sub replace_content {
    my $self = shift;
    my $data = shift || '';

    $self->data( $data );
    $self->size( length $data );
    return 1;
}

=head2 rename( $new_name )

Rename the current file to $new_name.

Note that you must specify a Unix path for $new_name, since per tar
standard, all files in the archive must be Unix paths.

Returns true on success and false on failure.

=cut

sub rename {
    my $self = shift;
    my $path = shift or return;

    my ($prefix,$file) = $self->_prefix_and_file( $path );

    $self->name( $file );
    $self->prefix( $prefix );

	return 1;
}

=head1 Convenience methods

To quickly check the type of a C<Archive::Tar::File> object, you can
use the following methods:

=over 4

=item is_file

Returns true if the file is of type C<file>

=item is_dir

Returns true if the file is of type C<dir>

=item is_hardlink

Returns true if the file is of type C<hardlink>

=item is_symlink

Returns true if the file is of type C<symlink>

=item is_chardev

Returns true if the file is of type C<chardev>

=item is_blockdev

Returns true if the file is of type C<blockdev>

=item is_fifo

Returns true if the file is of type C<fifo>

=item is_socket

Returns true if the file is of type C<socket>

=item is_longlink

Returns true if the file is of type C<LongLink>.
Should not happen after a successful C<read>.

=item is_label

Returns true if the file is of type C<Label>.
Should not happen after a successful C<read>.

=item is_unknown

Returns true if the file type is C<unknown>

=back

=cut

#stupid perl5.5.3 needs to warn if it's not numeric
sub is_file     { local $^W;    FILE      == $_[0]->type }
sub is_dir      { local $^W;    DIR       == $_[0]->type }
sub is_hardlink { local $^W;    HARDLINK  == $_[0]->type }
sub is_symlink  { local $^W;    SYMLINK   == $_[0]->type }
sub is_chardev  { local $^W;    CHARDEV   == $_[0]->type }
sub is_blockdev { local $^W;    BLOCKDEV  == $_[0]->type }
sub is_fifo     { local $^W;    FIFO      == $_[0]->type }
sub is_socket   { local $^W;    SOCKET    == $_[0]->type }
sub is_unknown  { local $^W;    UNKNOWN   == $_[0]->type }
sub is_longlink { local $^W;    LONGLINK  eq $_[0]->type }
sub is_label    { local $^W;    LABEL     eq $_[0]->type }

1;
Commit	Line	Data
39713df4	1	package Archive::Tar::File;
	2	use strict;
	3
	4	use IO::File;
81a5970e	5	use File::Spec::Unix ();
	6	use File::Spec ();
	7	use File::Basename ();
	8
39713df4	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;
81a5970e	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;
39713df4	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
81a5970e	217	my $obj = bless { %entry, %args }, $class;
39713df4	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 or return;
	237	my $type = __PACKAGE__->_filetype($path);
	238	my $data = '';
	239
97a504ba	240	READ: {
	241	unless ($type == DIR ) {
	242	my $fh = IO::File->new;
	243
	244	unless( $fh->open($path) ) {
	245	### dangling symlinks are fine, stop reading but continue
	246	### creating the object
	247	last READ if $type == SYMLINK;
	248
	249	### otherwise, return from this function --
	250	### anything that's not a symlink should be
	251	### resolvable
	252	return;
	253	}
	254
	255	### binmode needed to read files properly on win32 ###
	256	binmode $fh;
	257	$data = do { local $/; <$fh> };
	258	close $fh;
	259	}
39713df4	260	}
	261
	262	my @items = qw[mode uid gid size mtime];
	263	my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
	264
	265	### you must set size == 0 on symlinks, or the next entry will be
	266	### though of as the contents of the symlink, which is wrong.
	267	### this fixes bug #7937
	268	$hash{size} = 0 if ($type == DIR or $type == SYMLINK);
	269	$hash{mtime} -= TIME_OFFSET;
	270
	271	### strip the high bits off the mode, which we don't need to store
	272	$hash{mode} = STRIP_MODE->( $hash{mode} );
	273
	274
	275	### probably requires some file path munging here ... ###
	276	### name and prefix are set later
	277	my $obj = {
	278	%hash,
	279	name => '',
	280	chksum => CHECK_SUM,
	281	type => $type,
	282	linkname => ($type == SYMLINK and CAN_READLINK)
	283	? readlink $path
	284	: '',
	285	magic => MAGIC,
	286	version => TAR_VERSION,
	287	uname => UNAME->( $hash{uid} ),
	288	gname => GNAME->( $hash{gid} ),
	289	devmajor => 0, # not handled
	290	devminor => 0, # not handled
	291	prefix => '',
	292	data => $data,
	293	};
	294
	295	bless $obj, $class;
	296
	297	### fix up the prefix and file from the path
	298	my($prefix,$file) = $obj->_prefix_and_file( $path );
	299	$obj->prefix( $prefix );
	300	$obj->name( $file );
	301
	302	return $obj;
	303	}
	304
	305	sub _new_from_data {
	306	my $class = shift;
	307	my $path = shift or return;
	308	my $data = shift; return unless defined $data;
	309	my $opt = shift;
	310
	311	my $obj = {
	312	data => $data,
	313	name => '',
	314	mode => MODE,
	315	uid => UID,
	316	gid => GID,
	317	size => length $data,
	318	mtime => time - TIME_OFFSET,
	319	chksum => CHECK_SUM,
	320	type => FILE,
	321	linkname => '',
	322	magic => MAGIC,
	323	version => TAR_VERSION,
324	uname => UNAME->( UID ),
325	gname => GNAME->( GID ),
326	devminor => 0,
327	devmajor => 0,
328	prefix => '',
329	};
330
331	### overwrite with user options, if provided ###
332	if( $opt and ref $opt eq 'HASH' ) {
333	for my $key ( keys %$opt ) {
334
335	### don't write bogus options ###
336	next unless exists $obj->{$key};
337	$obj->{$key} = $opt->{$key};
338	}
339	}
340
341	bless $obj, $class;
342
343	### fix up the prefix and file from the path
344	my($prefix,$file) = $obj->_prefix_and_file( $path );
345	$obj->prefix( $prefix );
346	$obj->name( $file );
347
348	return $obj;
349	}
350
351	sub _prefix_and_file {
352	my $self = shift;
353	my $path = shift;
354
355	my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
356	my @dirs = File::Spec->splitdir( $dirs );
357
358	### so sometimes the last element is '' -- probably when trailing
359	### dir slashes are encountered... this is is of course pointless,
360	### so remove it
361	pop @dirs while @dirs and not length $dirs[-1];
362
363	### if it's a directory, then $file might be empty
364	$file = pop @dirs if $self->is_dir and not length $file;
365
366	my $prefix = File::Spec::Unix->catdir(
367	grep { length } $vol, @dirs
368	);
369	return( $prefix, $file );
370	}
371
372	sub _filetype {
373	my $self = shift;
374	my $file = shift or return;
375
376	return SYMLINK if (-l $file); # Symlink
377
378	return FILE if (-f _); # Plain file
379
380	return DIR if (-d _); # Directory
381
382	return FIFO if (-p _); # Named pipe
383
384	return SOCKET if (-S _); # Socket
385
386	return BLOCKDEV if (-b _); # Block special
387
388	return CHARDEV if (-c _); # Character special
389
390	### shouldn't happen, this is when making archives, not reading ###
391	return LONGLINK if ( $file eq LONGLINK_NAME );
392
393	return UNKNOWN; # Something else (like what?)
394
395	}
396
397	### this method 'downgrades' a file to plain file -- this is used for
398	### symlinks when FOLLOW_SYMLINKS is true.
399	sub _downgrade_to_plainfile {
400	my $entry = shift;
401	$entry->type( FILE );
402	$entry->mode( MODE );
403	$entry->linkname('');
404
405	return 1;
406	}
407
408	=head2 full_path
409
410	Returns the full path from the tar header; this is basically a
411	concatenation of the C<prefix> and C<name> fields.
412
413	=cut
414
415	sub full_path {
416	my $self = shift;
417
418	### if prefix field is emtpy
419	return $self->name unless defined $self->prefix and length $self->prefix;
420
421	### or otherwise, catfile'd
422	return File::Spec::Unix->catfile( $self->prefix, $self->name );
423	}
424
425
426	=head2 validate
427
428	Done by Archive::Tar internally when reading the tar file:
429	validate the header against the checksum to ensure integer tar file.
430
431	Returns true on success, false on failure
432
433	=cut
434
435	sub validate {
436	my $self = shift;
437
438	my $raw = $self->raw;
439
440	### don't know why this one is different from the one we /write/ ###
441	substr ($raw, 148, 8) = " ";
442	return unpack ("%16C*", $raw) == $self->chksum ? 1 : 0;
443	}
444
445	=head2 has_content
446
447	Returns a boolean to indicate whether the current object has content.
448	Some special files like directories and so on never will have any
449	content. This method is mainly to make sure you don't get warnings
450	for using uninitialized values when looking at an object's content.
451
452	=cut
453
454	sub has_content {
455	my $self = shift;
456	return defined $self->data() && length $self->data() ? 1 : 0;
457	}
458
459	=head2 get_content
460
461	Returns the current content for the in-memory file
462
463	=cut
464
465	sub get_content {
466	my $self = shift;
467	$self->data( );
468	}
469
470	=head2 get_content_by_ref
471
472	Returns the current content for the in-memory file as a scalar
473	reference. Normal users won't need this, but it will save memory if
474	you are dealing with very large data files in your tar archive, since
475	it will pass the contents by reference, rather than make a copy of it
476	first.
477
478	=cut
479
480	sub get_content_by_ref {
481	my $self = shift;
482
483	return \$self->{data};
484	}
485
486	=head2 replace_content( $content )
487
488	Replace the current content of the file with the new content. This
489	only affects the in-memory archive, not the on-disk version until
490	you write it.
491
492	Returns true on success, false on failure.
493
494	=cut
495
496	sub replace_content {
497	my $self = shift;
498	my $data = shift \|\| '';
499
500	$self->data( $data );
501	$self->size( length $data );
502	return 1;
503	}
504
505	=head2 rename( $new_name )
506
507	Rename the current file to $new_name.
508
509	Note that you must specify a Unix path for $new_name, since per tar
510	standard, all files in the archive must be Unix paths.
511
512	Returns true on success and false on failure.
513
514	=cut
515
516	sub rename {
517	my $self = shift;
518	my $path = shift or return;
519
520	my ($prefix,$file) = $self->_prefix_and_file( $path );
521
522	$self->name( $file );
523	$self->prefix( $prefix );
524
525	return 1;
526	}
527
528	=head1 Convenience methods
529
530	To quickly check the type of a C<Archive::Tar::File> object, you can
531	use the following methods:
532
533	=over 4
534
535	=item is_file
536
537	Returns true if the file is of type C<file>
538
539	=item is_dir
540
541	Returns true if the file is of type C<dir>
542
543	=item is_hardlink
544
545	Returns true if the file is of type C<hardlink>
546
547	=item is_symlink
548
549	Returns true if the file is of type C<symlink>
550
551	=item is_chardev
552
553	Returns true if the file is of type C<chardev>
554
555	=item is_blockdev
556
557	Returns true if the file is of type C<blockdev>
558
559	=item is_fifo
560
561	Returns true if the file is of type C<fifo>
562
563	=item is_socket
564
565	Returns true if the file is of type C<socket>
566
567	=item is_longlink
568
569	Returns true if the file is of type C<LongLink>.
570	Should not happen after a successful C<read>.
571
572	=item is_label
573
574	Returns true if the file is of type C<Label>.
575	Should not happen after a successful C<read>.
576
577	=item is_unknown
578
579	Returns true if the file type is C<unknown>
580
581	=back
582
583	=cut
584
585	#stupid perl5.5.3 needs to warn if it's not numeric
586	sub is_file { local $^W; FILE == $_[0]->type }
587	sub is_dir { local $^W; DIR == $_[0]->type }
588	sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
589	sub is_symlink { local $^W; SYMLINK == $_[0]->type }
590	sub is_chardev { local $^W; CHARDEV == $_[0]->type }
591	sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
592	sub is_fifo { local $^W; FIFO == $_[0]->type }
593	sub is_socket { local $^W; SOCKET == $_[0]->type }
594	sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
595	sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
596	sub is_label { local $^W; LABEL eq $_[0]->type }
597
598	1;