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