[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;

    ### 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, $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        = '';

    unless ($type == DIR) {
        my $fh = IO::File->new;
        $fh->open($path) or 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;
	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;