File Coverage

lib/Archive/Tar/File.pm
Criterion Covered Total %
statement 155 161 96.3
branch 39 64 60.9
condition 20 28 71.4
subroutine 35 35 100.0
pod 19 20 95.0
total 268 308 87.0


line stmt bran cond sub pod time code
1             package Archive::Tar::File;
2 4     4   78 use strict;
  4         38  
  4         59  
3              
4 4     4   81 use IO::File;
  4         38  
  4         76  
5 4     4   863 use File::Spec::Unix ();
  4         205  
  4         44  
6 4     4   62 use File::Spec ();
  4         37  
  4         37  
7 4     4   58 use File::Basename ();
  4         36  
  4         38  
8              
9 4     4   129 use Archive::Tar::Constant;
  4         40  
  4         127  
10              
11 4     4   83 use vars qw[@ISA $VERSION];
  4         38  
  4         66  
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 4     4   81     no strict 'refs';
  4         36  
  4         65  
44                 *{__PACKAGE__."::$key"} = sub {
45 5578     5578   80033         my $self = shift;
46 5578 100       78771         $self->{$key} = $_[0] if @_;
47              
48             ### just in case the key is not there or undef or something ###
49 5578         55514         { local $^W = 0;
  5578         62173  
50 5578         142552             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 122     122 1 22577     my $class = shift;
185 122         1230     my $what = shift;
186              
187 122 50       2348     my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
    100          
    100          
188                             ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
189                             ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
190                             undef;
191              
192 122         1876     return $obj;
193             }
194              
195             ### copies the data, creates a clone ###
196             sub clone {
197 47     47 0 434     my $self = shift;
198 47         3577     return bless { %$self }, ref $self;
199             }
200              
201             sub _new_from_chunk {
202 92     92   860     my $class = shift;
203 92 50       2878     my $chunk = shift or return;
204 92         1072     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 92         923     my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
  20         259  
  20         434  
210              
211             ### makes it start at 0 actually... :) ###
212 92         891     my $i = -1;
213 1472 100       23055     my %entry = map {
214 1472         19106         $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
215 92         2059     } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
216              
217 92         3321     my $obj = bless { %entry, %args }, $class;
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 92 50       1314 return unless $obj->magic !~ /\W/;
222              
223             ### store the original chunk ###
224 92         1004     $obj->raw( $chunk );
225              
226 92 50 33     936     $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
227 92 50 66     2283     $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
228              
229              
230 92         1498     return $obj;
231              
232             }
233              
234             sub _new_from_file {
235 10     10   219     my $class = shift;
236 10 50       107     my $path = shift or return;
237 10         232     my $type = __PACKAGE__->_filetype($path);
238 10         278     my $data = '';
239              
240 10 100       108     unless ($type == DIR) {
241 9         195         my $fh = IO::File->new;
242 9 50       883         $fh->open($path) or return;
243              
244             ### binmode needed to read files properly on win32 ###
245 9         972         binmode $fh;
246 9         79         $data = do { local $/; <$fh> };
  9         103  
  9         4567  
247 9         164         close $fh;
248                 }
249              
250 10         277     my @items = qw[mode uid gid size mtime];
251 10         206     my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
  50         1249  
252              
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 10 100 66     731     $hash{size} = 0 if ($type == DIR or $type == SYMLINK);
257 10         147     $hash{mtime} -= TIME_OFFSET;
258              
259             ### strip the high bits off the mode, which we don't need to store
260 10         596     $hash{mode} = STRIP_MODE->( $hash{mode} );
261              
262              
263             ### probably requires some file path munging here ... ###
264             ### name and prefix are set later
265 10 50 50     395     my $obj = {
266                     %hash,
267                     name => '',
268                     chksum => CHECK_SUM,
269                     type => $type,
270                     linkname => ($type == SYMLINK and CAN_READLINK)
271                                         ? readlink $path
272                                         : '',
273                     magic => MAGIC,
274                     version => TAR_VERSION,
275                     uname => UNAME->( $hash{uid} ),
276                     gname => GNAME->( $hash{gid} ),
277                     devmajor => 0, # not handled
278                     devminor => 0, # not handled
279                     prefix => '',
280                     data => $data,
281                 };
282              
283 10         324     bless $obj, $class;
284              
285             ### fix up the prefix and file from the path
286 10         121     my($prefix,$file) = $obj->_prefix_and_file( $path );
287 10         143     $obj->prefix( $prefix );
288 10         103     $obj->name( $file );
289              
290 10         132     return $obj;
291             }
292              
293             sub _new_from_data {
294 20     20   214     my $class = shift;
295 20 100       257     my $path = shift or return;
296 19 50       218     my $data = shift; return unless defined $data;
  19         199  
297 19         168     my $opt = shift;
298              
299 19         521     my $obj = {
300                     data => $data,
301                     name => '',
302                     mode => MODE,
303                     uid => UID,
304                     gid => GID,
305                     size => length $data,
306                     mtime => time - TIME_OFFSET,
307                     chksum => CHECK_SUM,
308                     type => FILE,
309                     linkname => '',
310                     magic => MAGIC,
311                     version => TAR_VERSION,
312                     uname => UNAME->( UID ),
313                     gname => GNAME->( GID ),
314                     devminor => 0,
315                     devmajor => 0,
316                     prefix => '',
317                 };
318              
319             ### overwrite with user options, if provided ###
320 19 100 66     421     if( $opt and ref $opt eq 'HASH' ) {
321 11         167         for my $key ( keys %$opt ) {
322              
323             ### don't write bogus options ###
324 20 50       266             next unless exists $obj->{$key};
325 20         279             $obj->{$key} = $opt->{$key};
326                     }
327                 }
328              
329 19         258     bless $obj, $class;
330              
331             ### fix up the prefix and file from the path
332 19         212     my($prefix,$file) = $obj->_prefix_and_file( $path );
333 19         221     $obj->prefix( $prefix );
334 19         192     $obj->name( $file );
335              
336 19         191     return $obj;
337             }
338              
339             sub _prefix_and_file {
340 80     80   818     my $self = shift;
341 80         1571     my $path = shift;
342              
343 80         899     my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
344 80         4934     my @dirs = File::Spec->splitdir( $dirs );
345              
346             ### so sometimes the last element is '' -- probably when trailing
347             ### dir slashes are encountered... this is is of course pointless,
348             ### so remove it
349 80   100     10474     pop @dirs while @dirs and not length $dirs[-1];
350              
351             ### if it's a directory, then $file might be empty
352 80 100 66     1025     $file = pop @dirs if $self->is_dir and not length $file;
353              
354 128         1967     my $prefix = File::Spec::Unix->catdir