Commit | Line | Data |
39713df4 |
1 | ### the gnu tar specification: |
2 | ### http://www.gnu.org/software/tar/manual/html_mono/tar.html |
3 | ### |
4 | ### and the pax format spec, which tar derives from: |
5 | ### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html |
6 | |
7 | package Archive::Tar; |
8 | require 5.005_03; |
9 | |
10 | use strict; |
11 | use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD |
12 | $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING]; |
13 | |
14 | $DEBUG = 0; |
15 | $WARN = 1; |
16 | $FOLLOW_SYMLINK = 0; |
d78ab5f9 |
17 | $VERSION = "1.29_01"; |
39713df4 |
18 | $CHOWN = 1; |
19 | $CHMOD = 1; |
20 | $DO_NOT_USE_PREFIX = 0; |
21 | |
22 | BEGIN { |
23 | use Config; |
24 | $HAS_PERLIO = $Config::Config{useperlio}; |
25 | |
26 | ### try and load IO::String anyway, so you can dynamically |
27 | ### switch between perlio and IO::String |
28 | eval { |
29 | require IO::String; |
30 | import IO::String; |
31 | }; |
32 | $HAS_IO_STRING = $@ ? 0 : 1; |
33 | |
34 | } |
35 | |
36 | use Cwd; |
37 | use IO::File; |
38 | use Carp qw(carp croak); |
39 | use File::Spec (); |
40 | use File::Spec::Unix (); |
41 | use File::Path (); |
42 | |
43 | use Archive::Tar::File; |
44 | use Archive::Tar::Constant; |
45 | |
46 | =head1 NAME |
47 | |
48 | Archive::Tar - module for manipulations of tar archives |
49 | |
50 | =head1 SYNOPSIS |
51 | |
52 | use Archive::Tar; |
53 | my $tar = Archive::Tar->new; |
54 | |
55 | $tar->read('origin.tgz',1); |
56 | $tar->extract(); |
57 | |
58 | $tar->add_files('file/foo.pl', 'docs/README'); |
59 | $tar->add_data('file/baz.txt', 'This is the contents now'); |
60 | |
61 | $tar->rename('oldname', 'new/file/name'); |
62 | |
63 | $tar->write('files.tar'); |
64 | |
65 | =head1 DESCRIPTION |
66 | |
67 | Archive::Tar provides an object oriented mechanism for handling tar |
68 | files. It provides class methods for quick and easy files handling |
69 | while also allowing for the creation of tar file objects for custom |
70 | manipulation. If you have the IO::Zlib module installed, |
71 | Archive::Tar will also support compressed or gzipped tar files. |
72 | |
73 | An object of class Archive::Tar represents a .tar(.gz) archive full |
74 | of files and things. |
75 | |
76 | =head1 Object Methods |
77 | |
78 | =head2 Archive::Tar->new( [$file, $compressed] ) |
79 | |
80 | Returns a new Tar object. If given any arguments, C<new()> calls the |
81 | C<read()> method automatically, passing on the arguments provided to |
82 | the C<read()> method. |
83 | |
84 | If C<new()> is invoked with arguments and the C<read()> method fails |
85 | for any reason, C<new()> returns undef. |
86 | |
87 | =cut |
88 | |
89 | my $tmpl = { |
90 | _data => [ ], |
91 | _file => 'Unknown', |
92 | }; |
93 | |
94 | ### install get/set accessors for this object. |
95 | for my $key ( keys %$tmpl ) { |
96 | no strict 'refs'; |
97 | *{__PACKAGE__."::$key"} = sub { |
98 | my $self = shift; |
99 | $self->{$key} = $_[0] if @_; |
100 | return $self->{$key}; |
101 | } |
102 | } |
103 | |
104 | sub new { |
105 | my $class = shift; |
106 | $class = ref $class if ref $class; |
107 | |
108 | ### copying $tmpl here since a shallow copy makes it use the |
109 | ### same aref, causing for files to remain in memory always. |
110 | my $obj = bless { _data => [ ], _file => 'Unknown' }, $class; |
111 | |
112 | if (@_) { |
81a5970e |
113 | unless ( $obj->read( @_ ) ) { |
114 | $obj->_error(qq[No data could be read from file]); |
115 | return; |
116 | } |
39713df4 |
117 | } |
118 | |
119 | return $obj; |
120 | } |
121 | |
122 | =head2 $tar->read ( $filename|$handle, $compressed, {opt => 'val'} ) |
123 | |
124 | Read the given tar file into memory. |
125 | The first argument can either be the name of a file or a reference to |
126 | an already open filehandle (or an IO::Zlib object if it's compressed) |
127 | The second argument indicates whether the file referenced by the first |
128 | argument is compressed. |
129 | |
130 | The C<read> will I<replace> any previous content in C<$tar>! |
131 | |
132 | The second argument may be considered optional if IO::Zlib is |
133 | installed, since it will transparently Do The Right Thing. |
134 | Archive::Tar will warn if you try to pass a compressed file if |
135 | IO::Zlib is not available and simply return. |
136 | |
b3200c5d |
137 | Note that you can currently B<not> pass a C<gzip> compressed |
138 | filehandle, which is not opened with C<IO::Zlib>, nor a string |
139 | containing the full archive information (either compressed or |
140 | uncompressed). These are worth while features, but not currently |
141 | implemented. See the C<TODO> section. |
142 | |
39713df4 |
143 | The third argument can be a hash reference with options. Note that |
144 | all options are case-sensitive. |
145 | |
146 | =over 4 |
147 | |
148 | =item limit |
149 | |
150 | Do not read more than C<limit> files. This is useful if you have |
151 | very big archives, and are only interested in the first few files. |
152 | |
153 | =item extract |
154 | |
155 | If set to true, immediately extract entries when reading them. This |
156 | gives you the same memory break as the C<extract_archive> function. |
157 | Note however that entries will not be read into memory, but written |
158 | straight to disk. |
159 | |
160 | =back |
161 | |
162 | All files are stored internally as C<Archive::Tar::File> objects. |
163 | Please consult the L<Archive::Tar::File> documentation for details. |
164 | |
165 | Returns the number of files read in scalar context, and a list of |
166 | C<Archive::Tar::File> objects in list context. |
167 | |
168 | =cut |
169 | |
170 | sub read { |
171 | my $self = shift; |
172 | my $file = shift; |
173 | my $gzip = shift || 0; |
174 | my $opts = shift || {}; |
175 | |
176 | unless( defined $file ) { |
177 | $self->_error( qq[No file to read from!] ); |
178 | return; |
179 | } else { |
180 | $self->_file( $file ); |
181 | } |
182 | |
183 | my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) ) |
184 | or return; |
185 | |
186 | my $data = $self->_read_tar( $handle, $opts ) or return; |
187 | |
188 | $self->_data( $data ); |
189 | |
190 | return wantarray ? @$data : scalar @$data; |
191 | } |
192 | |
193 | sub _get_handle { |
194 | my $self = shift; |
195 | my $file = shift; return unless defined $file; |
196 | return $file if ref $file; |
197 | |
198 | my $gzip = shift || 0; |
199 | my $mode = shift || READ_ONLY->( ZLIB ); # default to read only |
200 | |
201 | my $fh; my $bin; |
202 | |
203 | ### only default to ZLIB if we're not trying to /write/ to a handle ### |
204 | if( ZLIB and $gzip || MODE_READ->( $mode ) ) { |
205 | |
206 | ### IO::Zlib will Do The Right Thing, even when passed |
207 | ### a plain file ### |
208 | $fh = new IO::Zlib; |
209 | |
210 | } else { |
211 | if( $gzip ) { |
212 | $self->_error(qq[Compression not available - Install IO::Zlib!]); |
213 | return; |
214 | |
215 | } else { |
216 | $fh = new IO::File; |
217 | $bin++; |
218 | } |
219 | } |
220 | |
221 | unless( $fh->open( $file, $mode ) ) { |
222 | $self->_error( qq[Could not create filehandle for '$file': $!!] ); |
223 | return; |
224 | } |
225 | |
226 | binmode $fh if $bin; |
227 | |
228 | return $fh; |
229 | } |
230 | |
231 | sub _read_tar { |
232 | my $self = shift; |
233 | my $handle = shift or return; |
234 | my $opts = shift || {}; |
235 | |
236 | my $count = $opts->{limit} || 0; |
237 | my $extract = $opts->{extract} || 0; |
238 | |
239 | ### set a cap on the amount of files to extract ### |
240 | my $limit = 0; |
241 | $limit = 1 if $count > 0; |
242 | |
243 | my $tarfile = [ ]; |
244 | my $chunk; |
245 | my $read = 0; |
246 | my $real_name; # to set the name of a file when |
247 | # we're encountering @longlink |
248 | my $data; |
249 | |
250 | LOOP: |
251 | while( $handle->read( $chunk, HEAD ) ) { |
252 | ### IO::Zlib doesn't support this yet |
253 | my $offset = eval { tell $handle } || 'unknown'; |
254 | |
255 | unless( $read++ ) { |
256 | my $gzip = GZIP_MAGIC_NUM; |
257 | if( $chunk =~ /$gzip/ ) { |
258 | $self->_error( qq[Cannot read compressed format in tar-mode] ); |
259 | return; |
260 | } |
261 | } |
262 | |
263 | ### if we can't read in all bytes... ### |
264 | last if length $chunk != HEAD; |
265 | |
266 | ### Apparently this should really be two blocks of 512 zeroes, |
267 | ### but GNU tar sometimes gets it wrong. See comment in the |
268 | ### source code (tar.c) to GNU cpio. |
269 | next if $chunk eq TAR_END; |
270 | |
b30bcf62 |
271 | ### according to the posix spec, the last 12 bytes of the header are |
272 | ### null bytes, to pad it to a 512 byte block. That means if these |
273 | ### bytes are NOT null bytes, it's a corrrupt header. See: |
274 | ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx |
275 | ### line 111 |
276 | { my $nulls = join '', "\0" x 12; |
277 | unless( $nulls eq substr( $chunk, 500, 12 ) ) { |
278 | $self->_error( qq[Invalid header block at offset $offset] ); |
279 | next LOOP; |
280 | } |
281 | } |
282 | |
81a5970e |
283 | ### pass the realname, so we can set it 'proper' right away |
284 | ### some of the heuristics are done on the name, so important |
285 | ### to set it ASAP |
39713df4 |
286 | my $entry; |
81a5970e |
287 | { my %extra_args = (); |
288 | $extra_args{'name'} = $$real_name if defined $real_name; |
289 | |
290 | unless( $entry = Archive::Tar::File->new( chunk => $chunk, |
291 | %extra_args ) |
292 | ) { |
293 | $self->_error( qq[Couldn't read chunk at offset $offset] ); |
b30bcf62 |
294 | next LOOP; |
81a5970e |
295 | } |
39713df4 |
296 | } |
297 | |
298 | ### ignore labels: |
299 | ### http://www.gnu.org/manual/tar/html_node/tar_139.html |
300 | next if $entry->is_label; |
301 | |
302 | if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) { |
303 | |
304 | if ( $entry->is_file && !$entry->validate ) { |
305 | ### sometimes the chunk is rather fux0r3d and a whole 512 |
306 | ### bytes ends p in the ->name area. |
307 | ### clean it up, if need be |
308 | my $name = $entry->name; |
309 | $name = substr($name, 0, 100) if length $name > 100; |
310 | $name =~ s/\n/ /g; |
311 | |
312 | $self->_error( $name . qq[: checksum error] ); |
313 | next LOOP; |
314 | } |
315 | |
316 | my $block = BLOCK_SIZE->( $entry->size ); |
317 | |
318 | $data = $entry->get_content_by_ref; |
319 | |
320 | ### just read everything into memory |
321 | ### can't do lazy loading since IO::Zlib doesn't support 'seek' |
322 | ### this is because Compress::Zlib doesn't support it =/ |
323 | ### this reads in the whole data in one read() call. |
324 | if( $handle->read( $$data, $block ) < $block ) { |
325 | $self->_error( qq[Read error on tarfile (missing data) ']. |
326 | $entry->full_path ."' at offset $offset" ); |
b30bcf62 |
327 | next LOOP; |
39713df4 |
328 | } |
329 | |
330 | ### throw away trailing garbage ### |
331 | substr ($$data, $entry->size) = ""; |
332 | |
333 | ### part II of the @LongLink munging -- need to do /after/ |
334 | ### the checksum check. |
335 | if( $entry->is_longlink ) { |
336 | ### weird thing in tarfiles -- if the file is actually a |
337 | ### @LongLink, the data part seems to have a trailing ^@ |
338 | ### (unprintable) char. to display, pipe output through less. |
339 | ### but that doesn't *always* happen.. so check if the last |
340 | ### character is a control character, and if so remove it |
341 | ### at any rate, we better remove that character here, or tests |
342 | ### like 'eq' and hashlook ups based on names will SO not work |
343 | ### remove it by calculating the proper size, and then |
344 | ### tossing out everything that's longer than that size. |
345 | |
346 | ### count number of nulls |
347 | my $nulls = $$data =~ tr/\0/\0/; |
348 | |
349 | ### cut data + size by that many bytes |
350 | $entry->size( $entry->size - $nulls ); |
351 | substr ($$data, $entry->size) = ""; |
352 | } |
353 | } |
354 | |
355 | ### clean up of the entries.. posix tar /apparently/ has some |
356 | ### weird 'feature' that allows for filenames > 255 characters |
357 | ### they'll put a header in with as name '././@LongLink' and the |
358 | ### contents will be the name of the /next/ file in the archive |
359 | ### pretty crappy and kludgy if you ask me |
360 | |
361 | ### set the name for the next entry if this is a @LongLink; |
362 | ### this is one ugly hack =/ but needed for direct extraction |
363 | if( $entry->is_longlink ) { |
364 | $real_name = $data; |
b30bcf62 |
365 | next LOOP; |
39713df4 |
366 | } elsif ( defined $real_name ) { |
367 | $entry->name( $$real_name ); |
368 | $entry->prefix(''); |
369 | undef $real_name; |
370 | } |
371 | |
372 | $self->_extract_file( $entry ) if $extract |
373 | && !$entry->is_longlink |
374 | && !$entry->is_unknown |
375 | && !$entry->is_label; |
376 | |
377 | ### Guard against tarfiles with garbage at the end |
378 | last LOOP if $entry->name eq ''; |
379 | |
380 | ### push only the name on the rv if we're extracting |
381 | ### -- for extract_archive |
382 | push @$tarfile, ($extract ? $entry->name : $entry); |
383 | |
384 | if( $limit ) { |
385 | $count-- unless $entry->is_longlink || $entry->is_dir; |
386 | last LOOP unless $count; |
387 | } |
388 | } continue { |
389 | undef $data; |
390 | } |
391 | |
392 | return $tarfile; |
393 | } |
394 | |
395 | =head2 $tar->contains_file( $filename ) |
396 | |
397 | Check if the archive contains a certain file. |
398 | It will return true if the file is in the archive, false otherwise. |
399 | |
400 | Note however, that this function does an exact match using C<eq> |
401 | on the full path. So it cannot compensate for case-insensitive file- |
402 | systems or compare 2 paths to see if they would point to the same |
403 | underlying file. |
404 | |
405 | =cut |
406 | |
407 | sub contains_file { |
408 | my $self = shift; |
409 | my $full = shift or return; |
410 | |
411 | return 1 if $self->_find_entry($full); |
412 | return; |
413 | } |
414 | |
415 | =head2 $tar->extract( [@filenames] ) |
416 | |
417 | Write files whose names are equivalent to any of the names in |
418 | C<@filenames> to disk, creating subdirectories as necessary. This |
419 | might not work too well under VMS. |
420 | Under MacPerl, the file's modification time will be converted to the |
421 | MacOS zero of time, and appropriate conversions will be done to the |
422 | path. However, the length of each element of the path is not |
423 | inspected to see whether it's longer than MacOS currently allows (32 |
424 | characters). |
425 | |
426 | If C<extract> is called without a list of file names, the entire |
427 | contents of the archive are extracted. |
428 | |
429 | Returns a list of filenames extracted. |
430 | |
431 | =cut |
432 | |
433 | sub extract { |
434 | my $self = shift; |
b30bcf62 |
435 | my @args = @_; |
39713df4 |
436 | my @files; |
437 | |
438 | ### you requested the extraction of only certian files |
b30bcf62 |
439 | if( @args ) { |
440 | for my $file ( @args ) { |
441 | |
442 | ### it's already an object? |
443 | if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) { |
444 | push @files, $file; |
445 | next; |
39713df4 |
446 | |
b30bcf62 |
447 | ### go find it then |
448 | } else { |
449 | |
450 | my $found; |
451 | for my $entry ( @{$self->_data} ) { |
452 | next unless $file eq $entry->full_path; |
453 | |
454 | ### we found the file you're looking for |
455 | push @files, $entry; |
456 | $found++; |
457 | } |
458 | |
459 | unless( $found ) { |
460 | return $self->_error( |
461 | qq[Could not find '$file' in archive] ); |
462 | } |
39713df4 |
463 | } |
464 | } |
465 | |
466 | ### just grab all the file items |
467 | } else { |
468 | @files = $self->get_files; |
469 | } |
470 | |
471 | ### nothing found? that's an error |
472 | unless( scalar @files ) { |
473 | $self->_error( qq[No files found for ] . $self->_file ); |
474 | return; |
475 | } |
476 | |
477 | ### now extract them |
478 | for my $entry ( @files ) { |
479 | unless( $self->_extract_file( $entry ) ) { |
480 | $self->_error(q[Could not extract ']. $entry->full_path .q['] ); |
481 | return; |
482 | } |
483 | } |
484 | |
485 | return @files; |
486 | } |
487 | |
488 | =head2 $tar->extract_file( $file, [$extract_path] ) |
489 | |
490 | Write an entry, whose name is equivalent to the file name provided to |
491 | disk. Optionally takes a second parameter, which is the full (unix) |
492 | path (including filename) the entry will be written to. |
493 | |
494 | For example: |
495 | |
496 | $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' ); |
497 | |
b30bcf62 |
498 | $tar->extract_file( $at_file_object, 'name/i/want/to/give/it' ); |
499 | |
39713df4 |
500 | Returns true on success, false on failure. |
501 | |
502 | =cut |
503 | |
504 | sub extract_file { |
505 | my $self = shift; |
506 | my $file = shift or return; |
507 | my $alt = shift; |
508 | |
509 | my $entry = $self->_find_entry( $file ) |
510 | or $self->_error( qq[Could not find an entry for '$file'] ), return; |
511 | |
512 | return $self->_extract_file( $entry, $alt ); |
513 | } |
514 | |
515 | sub _extract_file { |
516 | my $self = shift; |
517 | my $entry = shift or return; |
518 | my $alt = shift; |
39713df4 |
519 | |
520 | ### you wanted an alternate extraction location ### |
521 | my $name = defined $alt ? $alt : $entry->full_path; |
522 | |
523 | ### splitpath takes a bool at the end to indicate |
524 | ### that it's splitting a dir |
7f10f74b |
525 | my ($vol,$dirs,$file); |
526 | if ( defined $alt ) { # It's a local-OS path |
527 | ($vol,$dirs,$file) = File::Spec->splitpath( $alt, |
528 | $entry->is_dir ); |
529 | } else { |
530 | ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name, |
531 | $entry->is_dir ); |
532 | } |
533 | |
39713df4 |
534 | my $dir; |
535 | ### is $name an absolute path? ### |
536 | if( File::Spec->file_name_is_absolute( $dirs ) ) { |
537 | $dir = $dirs; |
538 | |
539 | ### it's a relative path ### |
540 | } else { |
b30bcf62 |
541 | my $cwd = cwd(); |
39713df4 |
542 | my @dirs = File::Spec::Unix->splitdir( $dirs ); |
543 | my @cwd = File::Spec->splitdir( $cwd ); |
81a5970e |
544 | $dir = File::Spec->catdir( @cwd, @dirs ); |
545 | |
546 | # catdir() returns undef if the path is longer than 255 chars on VMS |
547 | unless ( defined $dir ) { |
548 | $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] ); |
549 | return; |
550 | } |
551 | |
39713df4 |
552 | } |
553 | |
554 | if( -e $dir && !-d _ ) { |
555 | $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] ); |
556 | return; |
557 | } |
558 | |
559 | unless ( -d _ ) { |
560 | eval { File::Path::mkpath( $dir, 0, 0777 ) }; |
561 | if( $@ ) { |
562 | $self->_error( qq[Could not create directory '$dir': $@] ); |
563 | return; |
564 | } |
565 | } |
566 | |
567 | ### we're done if we just needed to create a dir ### |
568 | return 1 if $entry->is_dir; |
569 | |
570 | my $full = File::Spec->catfile( $dir, $file ); |
571 | |
572 | if( $entry->is_unknown ) { |
573 | $self->_error( qq[Unknown file type for file '$full'] ); |
574 | return; |
575 | } |
576 | |
577 | if( length $entry->type && $entry->is_file ) { |
578 | my $fh = IO::File->new; |
579 | $fh->open( '>' . $full ) or ( |
580 | $self->_error( qq[Could not open file '$full': $!] ), |
581 | return |
582 | ); |
583 | |
584 | if( $entry->size ) { |
585 | binmode $fh; |
586 | syswrite $fh, $entry->data or ( |
587 | $self->_error( qq[Could not write data to '$full'] ), |
588 | return |
589 | ); |
590 | } |
591 | |
592 | close $fh or ( |
593 | $self->_error( qq[Could not close file '$full'] ), |
594 | return |
595 | ); |
596 | |
597 | } else { |
598 | $self->_make_special_file( $entry, $full ) or return; |
599 | } |
600 | |
601 | utime time, $entry->mtime - TIME_OFFSET, $full or |
602 | $self->_error( qq[Could not update timestamp] ); |
603 | |
604 | if( $CHOWN && CAN_CHOWN ) { |
605 | chown $entry->uid, $entry->gid, $full or |
606 | $self->_error( qq[Could not set uid/gid on '$full'] ); |
607 | } |
608 | |
609 | ### only chmod if we're allowed to, but never chmod symlinks, since they'll |
610 | ### change the perms on the file they're linking too... |
611 | if( $CHMOD and not -l $full ) { |
612 | chmod $entry->mode, $full or |
613 | $self->_error( qq[Could not chown '$full' to ] . $entry->mode ); |
614 | } |
615 | |
616 | return 1; |
617 | } |
618 | |
619 | sub _make_special_file { |
620 | my $self = shift; |
621 | my $entry = shift or return; |
622 | my $file = shift; return unless defined $file; |
623 | |
624 | my $err; |
625 | |
626 | if( $entry->is_symlink ) { |
627 | my $fail; |
628 | if( ON_UNIX ) { |
629 | symlink( $entry->linkname, $file ) or $fail++; |
630 | |
631 | } else { |
632 | $self->_extract_special_file_as_plain_file( $entry, $file ) |
633 | or $fail++; |
634 | } |
635 | |
636 | $err = qq[Making symbolink link from '] . $entry->linkname . |
637 | qq[' to '$file' failed] if $fail; |
638 | |
639 | } elsif ( $entry->is_hardlink ) { |
640 | my $fail; |
641 | if( ON_UNIX ) { |
642 | link( $entry->linkname, $file ) or $fail++; |
643 | |
644 | } else { |
645 | $self->_extract_special_file_as_plain_file( $entry, $file ) |
646 | or $fail++; |
647 | } |
648 | |
649 | $err = qq[Making hard link from '] . $entry->linkname . |
650 | qq[' to '$file' failed] if $fail; |
651 | |
652 | } elsif ( $entry->is_fifo ) { |
653 | ON_UNIX && !system('mknod', $file, 'p') or |
654 | $err = qq[Making fifo ']. $entry->name .qq[' failed]; |
655 | |
656 | } elsif ( $entry->is_blockdev or $entry->is_chardev ) { |
657 | my $mode = $entry->is_blockdev ? 'b' : 'c'; |
658 | |
659 | ON_UNIX && !system('mknod', $file, $mode, |
660 | $entry->devmajor, $entry->devminor) or |
661 | $err = qq[Making block device ']. $entry->name .qq[' (maj=] . |
662 | $entry->devmajor . qq[ min=] . $entry->devminor . |
663 | qq[) failed.]; |
664 | |
665 | } elsif ( $entry->is_socket ) { |
666 | ### the original doesn't do anything special for sockets.... ### |
667 | 1; |
668 | } |
669 | |
670 | return $err ? $self->_error( $err ) : 1; |
671 | } |
672 | |
673 | ### don't know how to make symlinks, let's just extract the file as |
674 | ### a plain file |
675 | sub _extract_special_file_as_plain_file { |
676 | my $self = shift; |
677 | my $entry = shift or return; |
678 | my $file = shift; return unless defined $file; |
679 | |
680 | my $err; |
681 | TRY: { |
682 | my $orig = $self->_find_entry( $entry->linkname ); |
683 | |
684 | unless( $orig ) { |
685 | $err = qq[Could not find file '] . $entry->linkname . |
686 | qq[' in memory.]; |
687 | last TRY; |
688 | } |
689 | |
690 | ### clone the entry, make it appear as a normal file ### |
691 | my $clone = $entry->clone; |
692 | $clone->_downgrade_to_plainfile; |
693 | $self->_extract_file( $clone, $file ) or last TRY; |
694 | |
695 | return 1; |
696 | } |
697 | |
698 | return $self->_error($err); |
699 | } |
700 | |
701 | =head2 $tar->list_files( [\@properties] ) |
702 | |
703 | Returns a list of the names of all the files in the archive. |
704 | |
705 | If C<list_files()> is passed an array reference as its first argument |
706 | it returns a list of hash references containing the requested |
707 | properties of each file. The following list of properties is |
708 | supported: name, size, mtime (last modified date), mode, uid, gid, |
709 | linkname, uname, gname, devmajor, devminor, prefix. |
710 | |
711 | Passing an array reference containing only one element, 'name', is |
712 | special cased to return a list of names rather than a list of hash |
713 | references, making it equivalent to calling C<list_files> without |
714 | arguments. |
715 | |
716 | =cut |
717 | |
718 | sub list_files { |
719 | my $self = shift; |
720 | my $aref = shift || [ ]; |
721 | |
722 | unless( $self->_data ) { |
723 | $self->read() or return; |
724 | } |
725 | |
726 | if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) { |
727 | return map { $_->full_path } @{$self->_data}; |
728 | } else { |
729 | |
730 | #my @rv; |
731 | #for my $obj ( @{$self->_data} ) { |
732 | # push @rv, { map { $_ => $obj->$_() } @$aref }; |
733 | #} |
734 | #return @rv; |
735 | |
736 | ### this does the same as the above.. just needs a +{ } |
737 | ### to make sure perl doesn't confuse it for a block |
738 | return map { my $o=$_; |
739 | +{ map { $_ => $o->$_() } @$aref } |
740 | } @{$self->_data}; |
741 | } |
742 | } |
743 | |
744 | sub _find_entry { |
745 | my $self = shift; |
746 | my $file = shift; |
747 | |
748 | unless( defined $file ) { |
749 | $self->_error( qq[No file specified] ); |
750 | return; |
751 | } |
752 | |
b30bcf62 |
753 | ### it's an object already |
754 | return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); |
755 | |
39713df4 |
756 | for my $entry ( @{$self->_data} ) { |
757 | my $path = $entry->full_path; |
758 | return $entry if $path eq $file; |
759 | } |
760 | |
761 | $self->_error( qq[No such file in archive: '$file'] ); |
762 | return; |
763 | } |
764 | |
765 | =head2 $tar->get_files( [@filenames] ) |
766 | |
767 | Returns the C<Archive::Tar::File> objects matching the filenames |
768 | provided. If no filename list was passed, all C<Archive::Tar::File> |
769 | objects in the current Tar object are returned. |
770 | |
771 | Please refer to the C<Archive::Tar::File> documentation on how to |
772 | handle these objects. |
773 | |
774 | =cut |
775 | |
776 | sub get_files { |
777 | my $self = shift; |
778 | |
779 | return @{ $self->_data } unless @_; |
780 | |
781 | my @list; |
782 | for my $file ( @_ ) { |
783 | push @list, grep { defined } $self->_find_entry( $file ); |
784 | } |
785 | |
786 | return @list; |
787 | } |
788 | |
789 | =head2 $tar->get_content( $file ) |
790 | |
791 | Return the content of the named file. |
792 | |
793 | =cut |
794 | |
795 | sub get_content { |
796 | my $self = shift; |
797 | my $entry = $self->_find_entry( shift ) or return; |
798 | |
799 | return $entry->data; |
800 | } |
801 | |
802 | =head2 $tar->replace_content( $file, $content ) |
803 | |
804 | Make the string $content be the content for the file named $file. |
805 | |
806 | =cut |
807 | |
808 | sub replace_content { |
809 | my $self = shift; |
810 | my $entry = $self->_find_entry( shift ) or return; |
811 | |
812 | return $entry->replace_content( shift ); |
813 | } |
814 | |
815 | =head2 $tar->rename( $file, $new_name ) |
816 | |
817 | Rename the file of the in-memory archive to $new_name. |
818 | |
819 | Note that you must specify a Unix path for $new_name, since per tar |
820 | standard, all files in the archive must be Unix paths. |
821 | |
822 | Returns true on success and false on failure. |
823 | |
824 | =cut |
825 | |
826 | sub rename { |
827 | my $self = shift; |
828 | my $file = shift; return unless defined $file; |
829 | my $new = shift; return unless defined $new; |
830 | |
831 | my $entry = $self->_find_entry( $file ) or return; |
832 | |
833 | return $entry->rename( $new ); |
834 | } |
835 | |
836 | =head2 $tar->remove (@filenamelist) |
837 | |
838 | Removes any entries with names matching any of the given filenames |
839 | from the in-memory archive. Returns a list of C<Archive::Tar::File> |
840 | objects that remain. |
841 | |
842 | =cut |
843 | |
844 | sub remove { |
845 | my $self = shift; |
846 | my @list = @_; |
847 | |
848 | my %seen = map { $_->full_path => $_ } @{$self->_data}; |
849 | delete $seen{ $_ } for @list; |
850 | |
851 | $self->_data( [values %seen] ); |
852 | |
853 | return values %seen; |
854 | } |
855 | |
856 | =head2 $tar->clear |
857 | |
858 | C<clear> clears the current in-memory archive. This effectively gives |
859 | you a 'blank' object, ready to be filled again. Note that C<clear> |
860 | only has effect on the object, not the underlying tarfile. |
861 | |
862 | =cut |
863 | |
864 | sub clear { |
865 | my $self = shift or return; |
866 | |
867 | $self->_data( [] ); |
868 | $self->_file( '' ); |
869 | |
870 | return 1; |
871 | } |
872 | |
873 | |
874 | =head2 $tar->write ( [$file, $compressed, $prefix] ) |
875 | |
876 | Write the in-memory archive to disk. The first argument can either |
877 | be the name of a file or a reference to an already open filehandle (a |
878 | GLOB reference). If the second argument is true, the module will use |
879 | IO::Zlib to write the file in a compressed format. If IO::Zlib is |
880 | not available, the C<write> method will fail and return. |
881 | |
882 | Note that when you pass in a filehandle, the compression argument |
883 | is ignored, as all files are printed verbatim to your filehandle. |
884 | If you wish to enable compression with filehandles, use an |
885 | C<IO::Zlib> filehandle instead. |
886 | |
887 | Specific levels of compression can be chosen by passing the values 2 |
888 | through 9 as the second parameter. |
889 | |
890 | The third argument is an optional prefix. All files will be tucked |
891 | away in the directory you specify as prefix. So if you have files |
892 | 'a' and 'b' in your archive, and you specify 'foo' as prefix, they |
893 | will be written to the archive as 'foo/a' and 'foo/b'. |
894 | |
895 | If no arguments are given, C<write> returns the entire formatted |
896 | archive as a string, which could be useful if you'd like to stuff the |
897 | archive into a socket or a pipe to gzip or something. |
898 | |
899 | =cut |
900 | |
901 | sub write { |
902 | my $self = shift; |
903 | my $file = shift; $file = '' unless defined $file; |
904 | my $gzip = shift || 0; |
905 | my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; |
906 | my $dummy = ''; |
907 | |
908 | ### only need a handle if we have a file to print to ### |
909 | my $handle = length($file) |
910 | ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) ) |
911 | or return ) |
912 | : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h } |
913 | : $HAS_IO_STRING ? IO::String->new |
914 | : __PACKAGE__->no_string_support(); |
915 | |
916 | |
917 | |
918 | for my $entry ( @{$self->_data} ) { |
919 | ### entries to be written to the tarfile ### |
920 | my @write_me; |
921 | |
922 | ### only now will we change the object to reflect the current state |
923 | ### of the name and prefix fields -- this needs to be limited to |
924 | ### write() only! |
925 | my $clone = $entry->clone; |
926 | |
927 | |
928 | ### so, if you don't want use to use the prefix, we'll stuff |
929 | ### everything in the name field instead |
930 | if( $DO_NOT_USE_PREFIX ) { |
931 | |
932 | ### you might have an extended prefix, if so, set it in the clone |
933 | ### XXX is ::Unix right? |
934 | $clone->name( length $ext_prefix |
935 | ? File::Spec::Unix->catdir( $ext_prefix, |
936 | $clone->full_path) |
937 | : $clone->full_path ); |
938 | $clone->prefix( '' ); |
939 | |
940 | ### otherwise, we'll have to set it properly -- prefix part in the |
941 | ### prefix and name part in the name field. |
942 | } else { |
943 | |
944 | ### split them here, not before! |
945 | my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path ); |
946 | |
947 | ### you might have an extended prefix, if so, set it in the clone |
948 | ### XXX is ::Unix right? |
949 | $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix ) |
950 | if length $ext_prefix; |
951 | |
952 | $clone->prefix( $prefix ); |
953 | $clone->name( $name ); |
954 | } |
955 | |
956 | ### names are too long, and will get truncated if we don't add a |
957 | ### '@LongLink' file... |
958 | my $make_longlink = ( length($clone->name) > NAME_LENGTH or |
959 | length($clone->prefix) > PREFIX_LENGTH |
960 | ) || 0; |
961 | |
962 | ### perhaps we need to make a longlink file? |
963 | if( $make_longlink ) { |
964 | my $longlink = Archive::Tar::File->new( |
965 | data => LONGLINK_NAME, |
966 | $clone->full_path, |
967 | { type => LONGLINK } |
968 | ); |
969 | |
970 | unless( $longlink ) { |
971 | $self->_error( qq[Could not create 'LongLink' entry for ] . |
972 | qq[oversize file '] . $clone->full_path ."'" ); |
973 | return; |
974 | }; |
975 | |
976 | push @write_me, $longlink; |
977 | } |
978 | |
979 | push @write_me, $clone; |
980 | |
981 | ### write the one, optionally 2 a::t::file objects to the handle |
982 | for my $clone (@write_me) { |
983 | |
984 | ### if the file is a symlink, there are 2 options: |
985 | ### either we leave the symlink intact, but then we don't write any |
986 | ### data OR we follow the symlink, which means we actually make a |
987 | ### copy. if we do the latter, we have to change the TYPE of the |
988 | ### clone to 'FILE' |
989 | my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK; |
990 | my $data_ok = !$clone->is_symlink && $clone->has_content; |
991 | |
992 | ### downgrade to a 'normal' file if it's a symlink we're going to |
993 | ### treat as a regular file |
994 | $clone->_downgrade_to_plainfile if $link_ok; |
995 | |
996 | ### get the header for this block |
997 | my $header = $self->_format_tar_entry( $clone ); |
998 | unless( $header ) { |
999 | $self->_error(q[Could not format header for: ] . |
1000 | $clone->full_path ); |
1001 | return; |
1002 | } |
1003 | |
1004 | unless( print $handle $header ) { |
1005 | $self->_error(q[Could not write header for: ] . |
1006 | $clone->full_path); |
1007 | return; |
1008 | } |
1009 | |
1010 | if( $link_ok or $data_ok ) { |
1011 | unless( print $handle $clone->data ) { |
1012 | $self->_error(q[Could not write data for: ] . |
1013 | $clone->full_path); |
1014 | return; |
1015 | } |
1016 | |
1017 | ### pad the end of the clone if required ### |
1018 | print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK |
1019 | } |
1020 | |
1021 | } ### done writing these entries |
1022 | } |
1023 | |
1024 | ### write the end markers ### |
1025 | print $handle TAR_END x 2 or |
1026 | return $self->_error( qq[Could not write tar end markers] ); |
b30bcf62 |
1027 | |
39713df4 |
1028 | ### did you want it written to a file, or returned as a string? ### |
b30bcf62 |
1029 | my $rv = length($file) ? 1 |
39713df4 |
1030 | : $HAS_PERLIO ? $dummy |
b30bcf62 |
1031 | : do { seek $handle, 0, 0; local $/; <$handle> }; |
1032 | |
1033 | ### make sure to close the handle; |
1034 | close $handle; |
1035 | |
1036 | return $rv; |
39713df4 |
1037 | } |
1038 | |
1039 | sub _format_tar_entry { |
1040 | my $self = shift; |
1041 | my $entry = shift or return; |
1042 | my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; |
1043 | my $no_prefix = shift || 0; |
1044 | |
1045 | my $file = $entry->name; |
1046 | my $prefix = $entry->prefix; $prefix = '' unless defined $prefix; |
1047 | |
1048 | ### remove the prefix from the file name |
1049 | ### not sure if this is still neeeded --kane |
1050 | ### no it's not -- Archive::Tar::File->_new_from_file will take care of |
1051 | ### this for us. Even worse, this would break if we tried to add a file |
1052 | ### like x/x. |
1053 | #if( length $prefix ) { |
1054 | # $file =~ s/^$match//; |
1055 | #} |
1056 | |
1057 | $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix) |
1058 | if length $ext_prefix; |
1059 | |
1060 | ### not sure why this is... ### |
1061 | my $l = PREFIX_LENGTH; # is ambiguous otherwise... |
1062 | substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH; |
1063 | |
1064 | my $f1 = "%06o"; my $f2 = "%11o"; |
1065 | |
1066 | ### this might be optimizable with a 'changed' flag in the file objects ### |
1067 | my $tar = pack ( |
1068 | PACK, |
1069 | $file, |
1070 | |
1071 | (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]), |
1072 | (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]), |
1073 | |
1074 | "", # checksum field - space padded a bit down |
1075 | |
1076 | (map { $entry->$_() } qw[type linkname magic]), |
1077 | |
1078 | $entry->version || TAR_VERSION, |
1079 | |
1080 | (map { $entry->$_() } qw[uname gname]), |
1081 | (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]), |
1082 | |
1083 | ($no_prefix ? '' : $prefix) |
1084 | ); |
1085 | |
1086 | ### add the checksum ### |
1087 | substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar)); |
1088 | |
1089 | return $tar; |
1090 | } |
1091 | |
1092 | =head2 $tar->add_files( @filenamelist ) |
1093 | |
1094 | Takes a list of filenames and adds them to the in-memory archive. |
1095 | |
1096 | The path to the file is automatically converted to a Unix like |
1097 | equivalent for use in the archive, and, if on MacOS, the file's |
1098 | modification time is converted from the MacOS epoch to the Unix epoch. |
1099 | So tar archives created on MacOS with B<Archive::Tar> can be read |
1100 | both with I<tar> on Unix and applications like I<suntar> or |
1101 | I<Stuffit Expander> on MacOS. |
1102 | |
1103 | Be aware that the file's type/creator and resource fork will be lost, |
1104 | which is usually what you want in cross-platform archives. |
1105 | |
1106 | Returns a list of C<Archive::Tar::File> objects that were just added. |
1107 | |
1108 | =cut |
1109 | |
1110 | sub add_files { |
1111 | my $self = shift; |
1112 | my @files = @_ or return; |
1113 | |
1114 | my @rv; |
1115 | for my $file ( @files ) { |
1116 | unless( -e $file ) { |
1117 | $self->_error( qq[No such file: '$file'] ); |
1118 | next; |
1119 | } |
1120 | |
1121 | my $obj = Archive::Tar::File->new( file => $file ); |
1122 | unless( $obj ) { |
1123 | $self->_error( qq[Unable to add file: '$file'] ); |
1124 | next; |
1125 | } |
1126 | |
1127 | push @rv, $obj; |
1128 | } |
1129 | |
1130 | push @{$self->{_data}}, @rv; |
1131 | |
1132 | return @rv; |
1133 | } |
1134 | |
1135 | =head2 $tar->add_data ( $filename, $data, [$opthashref] ) |
1136 | |
1137 | Takes a filename, a scalar full of data and optionally a reference to |
1138 | a hash with specific options. |
1139 | |
1140 | Will add a file to the in-memory archive, with name C<$filename> and |
1141 | content C<$data>. Specific properties can be set using C<$opthashref>. |
1142 | The following list of properties is supported: name, size, mtime |
1143 | (last modified date), mode, uid, gid, linkname, uname, gname, |
b3200c5d |
1144 | devmajor, devminor, prefix, type. (On MacOS, the file's path and |
39713df4 |
1145 | modification times are converted to Unix equivalents.) |
1146 | |
b3200c5d |
1147 | Valid values for the file type are the following constants defined in |
1148 | Archive::Tar::Constants: |
1149 | |
1150 | =over 4 |
1151 | |
1152 | =item FILE |
1153 | |
1154 | Regular file. |
1155 | |
1156 | =item HARDLINK |
1157 | |
1158 | =item SYMLINK |
1159 | |
1160 | Hard and symbolic ("soft") links; linkname should specify target. |
1161 | |
1162 | =item CHARDEV |
1163 | |
1164 | =item BLOCKDEV |
1165 | |
1166 | Character and block devices. devmajor and devminor should specify the major |
1167 | and minor device numbers. |
1168 | |
1169 | =item DIR |
1170 | |
1171 | Directory. |
1172 | |
1173 | =item FIFO |
1174 | |
1175 | FIFO (named pipe). |
1176 | |
1177 | =item SOCKET |
1178 | |
1179 | Socket. |
1180 | |
1181 | =back |
1182 | |
39713df4 |
1183 | Returns the C<Archive::Tar::File> object that was just added, or |
1184 | C<undef> on failure. |
1185 | |
1186 | =cut |
1187 | |
1188 | sub add_data { |
1189 | my $self = shift; |
1190 | my ($file, $data, $opt) = @_; |
1191 | |
1192 | my $obj = Archive::Tar::File->new( data => $file, $data, $opt ); |
1193 | unless( $obj ) { |
1194 | $self->_error( qq[Unable to add file: '$file'] ); |
1195 | return; |
1196 | } |
1197 | |
1198 | push @{$self->{_data}}, $obj; |
1199 | |
1200 | return $obj; |
1201 | } |
1202 | |
1203 | =head2 $tar->error( [$BOOL] ) |
1204 | |
1205 | Returns the current errorstring (usually, the last error reported). |
1206 | If a true value was specified, it will give the C<Carp::longmess> |
1207 | equivalent of the error, in effect giving you a stacktrace. |
1208 | |
1209 | For backwards compatibility, this error is also available as |
1210 | C<$Archive::Tar::error> although it is much recommended you use the |
1211 | method call instead. |
1212 | |
1213 | =cut |
1214 | |
1215 | { |
1216 | $error = ''; |
1217 | my $longmess; |
1218 | |
1219 | sub _error { |
1220 | my $self = shift; |
1221 | my $msg = $error = shift; |
1222 | $longmess = Carp::longmess($error); |
1223 | |
1224 | ### set Archive::Tar::WARN to 0 to disable printing |
1225 | ### of errors |
1226 | if( $WARN ) { |
1227 | carp $DEBUG ? $longmess : $msg; |
1228 | } |
1229 | |
1230 | return; |
1231 | } |
1232 | |
1233 | sub error { |
1234 | my $self = shift; |
1235 | return shift() ? $longmess : $error; |
1236 | } |
1237 | } |
1238 | |
1239 | |
1240 | =head2 $bool = $tar->has_io_string |
1241 | |
1242 | Returns true if we currently have C<IO::String> support loaded. |
1243 | |
1244 | Either C<IO::String> or C<perlio> support is needed to support writing |
3c4b39be |
1245 | stringified archives. Currently, C<perlio> is the preferred method, if |
39713df4 |
1246 | available. |
1247 | |
1248 | See the C<GLOBAL VARIABLES> section to see how to change this preference. |
1249 | |
1250 | =cut |
1251 | |
1252 | sub has_io_string { return $HAS_IO_STRING; } |
1253 | |
1254 | =head2 $bool = $tar->has_perlio |
1255 | |
1256 | Returns true if we currently have C<perlio> support loaded. |
1257 | |
1258 | This requires C<perl-5.8> or higher, compiled with C<perlio> |
1259 | |
1260 | Either C<IO::String> or C<perlio> support is needed to support writing |
3c4b39be |
1261 | stringified archives. Currently, C<perlio> is the preferred method, if |
39713df4 |
1262 | available. |
1263 | |
1264 | See the C<GLOBAL VARIABLES> section to see how to change this preference. |
1265 | |
1266 | =cut |
1267 | |
1268 | sub has_perlio { return $HAS_PERLIO; } |
1269 | |
1270 | |
1271 | =head1 Class Methods |
1272 | |
1273 | =head2 Archive::Tar->create_archive($file, $compression, @filelist) |
1274 | |
1275 | Creates a tar file from the list of files provided. The first |
1276 | argument can either be the name of the tar file to create or a |
1277 | reference to an open file handle (e.g. a GLOB reference). |
1278 | |
1279 | The second argument specifies the level of compression to be used, if |
1280 | any. Compression of tar files requires the installation of the |
1281 | IO::Zlib module. Specific levels of compression may be |
1282 | requested by passing a value between 2 and 9 as the second argument. |
1283 | Any other value evaluating as true will result in the default |
1284 | compression level being used. |
1285 | |
1286 | Note that when you pass in a filehandle, the compression argument |
1287 | is ignored, as all files are printed verbatim to your filehandle. |
1288 | If you wish to enable compression with filehandles, use an |
1289 | C<IO::Zlib> filehandle instead. |
1290 | |
1291 | The remaining arguments list the files to be included in the tar file. |
1292 | These files must all exist. Any files which don't exist or can't be |
1293 | read are silently ignored. |
1294 | |
1295 | If the archive creation fails for any reason, C<create_archive> will |
1296 | return false. Please use the C<error> method to find the cause of the |
1297 | failure. |
1298 | |
1299 | Note that this method does not write C<on the fly> as it were; it |
1300 | still reads all the files into memory before writing out the archive. |
1301 | Consult the FAQ below if this is a problem. |
1302 | |
1303 | =cut |
1304 | |
1305 | sub create_archive { |
1306 | my $class = shift; |
1307 | |
1308 | my $file = shift; return unless defined $file; |
1309 | my $gzip = shift || 0; |
1310 | my @files = @_; |
1311 | |
1312 | unless( @files ) { |
1313 | return $class->_error( qq[Cowardly refusing to create empty archive!] ); |
1314 | } |
1315 | |
1316 | my $tar = $class->new; |
1317 | $tar->add_files( @files ); |
1318 | return $tar->write( $file, $gzip ); |
1319 | } |
1320 | |
1321 | =head2 Archive::Tar->list_archive ($file, $compressed, [\@properties]) |
1322 | |
1323 | Returns a list of the names of all the files in the archive. The |
1324 | first argument can either be the name of the tar file to list or a |
1325 | reference to an open file handle (e.g. a GLOB reference). |
1326 | |
1327 | If C<list_archive()> is passed an array reference as its third |
1328 | argument it returns a list of hash references containing the requested |
1329 | properties of each file. The following list of properties is |
b3200c5d |
1330 | supported: full_path, name, size, mtime (last modified date), mode, |
1331 | uid, gid, linkname, uname, gname, devmajor, devminor, prefix. |
1332 | |
1333 | See C<Archive::Tar::File> for details about supported properties. |
39713df4 |
1334 | |
1335 | Passing an array reference containing only one element, 'name', is |
1336 | special cased to return a list of names rather than a list of hash |
1337 | references. |
1338 | |
1339 | =cut |
1340 | |
1341 | sub list_archive { |
1342 | my $class = shift; |
1343 | my $file = shift; return unless defined $file; |
1344 | my $gzip = shift || 0; |
1345 | |
1346 | my $tar = $class->new($file, $gzip); |
1347 | return unless $tar; |
1348 | |
1349 | return $tar->list_files( @_ ); |
1350 | } |
1351 | |
1352 | =head2 Archive::Tar->extract_archive ($file, $gzip) |
1353 | |
1354 | Extracts the contents of the tar file. The first argument can either |
1355 | be the name of the tar file to create or a reference to an open file |
1356 | handle (e.g. a GLOB reference). All relative paths in the tar file will |
1357 | be created underneath the current working directory. |
1358 | |
1359 | C<extract_archive> will return a list of files it extracted. |
1360 | If the archive extraction fails for any reason, C<extract_archive> |
1361 | will return false. Please use the C<error> method to find the cause |
1362 | of the failure. |
1363 | |
1364 | =cut |
1365 | |
1366 | sub extract_archive { |
1367 | my $class = shift; |
1368 | my $file = shift; return unless defined $file; |
1369 | my $gzip = shift || 0; |
1370 | |
1371 | my $tar = $class->new( ) or return; |
1372 | |
1373 | return $tar->read( $file, $gzip, { extract => 1 } ); |
1374 | } |
1375 | |
1376 | =head2 Archive::Tar->can_handle_compressed_files |
1377 | |
1378 | A simple checking routine, which will return true if C<Archive::Tar> |
1379 | is able to uncompress compressed archives on the fly with C<IO::Zlib>, |
1380 | or false if C<IO::Zlib> is not installed. |
1381 | |
1382 | You can use this as a shortcut to determine whether C<Archive::Tar> |
1383 | will do what you think before passing compressed archives to its |
1384 | C<read> method. |
1385 | |
1386 | =cut |
1387 | |
1388 | sub can_handle_compressed_files { return ZLIB ? 1 : 0 } |
1389 | |
1390 | sub no_string_support { |
1391 | croak("You have to install IO::String to support writing archives to strings"); |
1392 | } |
1393 | |
1394 | 1; |
1395 | |
1396 | __END__ |
1397 | |
1398 | =head1 GLOBAL VARIABLES |
1399 | |
1400 | =head2 $Archive::Tar::FOLLOW_SYMLINK |
1401 | |
1402 | Set this variable to C<1> to make C<Archive::Tar> effectively make a |
1403 | copy of the file when extracting. Default is C<0>, which |
1404 | means the symlink stays intact. Of course, you will have to pack the |
1405 | file linked to as well. |
1406 | |
1407 | This option is checked when you write out the tarfile using C<write> |
1408 | or C<create_archive>. |
1409 | |
1410 | This works just like C</bin/tar>'s C<-h> option. |
1411 | |
1412 | =head2 $Archive::Tar::CHOWN |
1413 | |
1414 | By default, C<Archive::Tar> will try to C<chown> your files if it is |
1415 | able to. In some cases, this may not be desired. In that case, set |
1416 | this variable to C<0> to disable C<chown>-ing, even if it were |
1417 | possible. |
1418 | |
1419 | The default is C<1>. |
1420 | |
1421 | =head2 $Archive::Tar::CHMOD |
1422 | |
1423 | By default, C<Archive::Tar> will try to C<chmod> your files to |
1424 | whatever mode was specified for the particular file in the archive. |
1425 | In some cases, this may not be desired. In that case, set this |
1426 | variable to C<0> to disable C<chmod>-ing. |
1427 | |
1428 | The default is C<1>. |
1429 | |
1430 | =head2 $Archive::Tar::DO_NOT_USE_PREFIX |
1431 | |
1432 | By default, C<Archive::Tar> will try to put paths that are over |
1433 | 100 characters in the C<prefix> field of your tar header. However, |
1434 | some older tar programs do not implement this spec. To retain |
1435 | compatibility with these older versions, you can set the |
1436 | C<$DO_NOT_USE_PREFIX> variable to a true value, and C<Archive::Tar> |
1437 | will use an alternate way of dealing with paths over 100 characters |
1438 | by using the C<GNU Extended Header> feature. |
1439 | |
1440 | The default is C<0>. |
1441 | |
1442 | =head2 $Archive::Tar::DEBUG |
1443 | |
1444 | Set this variable to C<1> to always get the C<Carp::longmess> output |
1445 | of the warnings, instead of the regular C<carp>. This is the same |
1446 | message you would get by doing: |
1447 | |
1448 | $tar->error(1); |
1449 | |
1450 | Defaults to C<0>. |
1451 | |
1452 | =head2 $Archive::Tar::WARN |
1453 | |
1454 | Set this variable to C<0> if you do not want any warnings printed. |
1455 | Personally I recommend against doing this, but people asked for the |
1456 | option. Also, be advised that this is of course not threadsafe. |
1457 | |
1458 | Defaults to C<1>. |
1459 | |
1460 | =head2 $Archive::Tar::error |
1461 | |
1462 | Holds the last reported error. Kept for historical reasons, but its |
1463 | use is very much discouraged. Use the C<error()> method instead: |
1464 | |
1465 | warn $tar->error unless $tar->extract; |
1466 | |
1467 | =head2 $Archive::Tar::HAS_PERLIO |
1468 | |
1469 | This variable holds a boolean indicating if we currently have |
1470 | C<perlio> support loaded. This will be enabled for any perl |
1471 | greater than C<5.8> compiled with C<perlio>. |
1472 | |
1473 | If you feel strongly about disabling it, set this variable to |
1474 | C<false>. Note that you will then need C<IO::String> installed |
1475 | to support writing stringified archives. |
1476 | |
1477 | Don't change this variable unless you B<really> know what you're |
1478 | doing. |
1479 | |
1480 | =head2 $Archive::Tar::HAS_IO_STRING |
1481 | |
1482 | This variable holds a boolean indicating if we currently have |
1483 | C<IO::String> support loaded. This will be enabled for any perl |
1484 | that has a loadable C<IO::String> module. |
1485 | |
1486 | If you feel strongly about disabling it, set this variable to |
1487 | C<false>. Note that you will then need C<perlio> support from |
1488 | your perl to be able to write stringified archives. |
1489 | |
1490 | Don't change this variable unless you B<really> know what you're |
1491 | doing. |
1492 | |
1493 | =head1 FAQ |
1494 | |
1495 | =over 4 |
1496 | |
1497 | =item What's the minimum perl version required to run Archive::Tar? |
1498 | |
1499 | You will need perl version 5.005_03 or newer. |
1500 | |
1501 | =item Isn't Archive::Tar slow? |
1502 | |
1503 | Yes it is. It's pure perl, so it's a lot slower then your C</bin/tar> |
1504 | However, it's very portable. If speed is an issue, consider using |
1505 | C</bin/tar> instead. |
1506 | |
1507 | =item Isn't Archive::Tar heavier on memory than /bin/tar? |
1508 | |
1509 | Yes it is, see previous answer. Since C<Compress::Zlib> and therefore |
1510 | C<IO::Zlib> doesn't support C<seek> on their filehandles, there is little |
1511 | choice but to read the archive into memory. |
1512 | This is ok if you want to do in-memory manipulation of the archive. |
1513 | If you just want to extract, use the C<extract_archive> class method |
1514 | instead. It will optimize and write to disk immediately. |
1515 | |
1516 | =item Can't you lazy-load data instead? |
1517 | |
1518 | No, not easily. See previous question. |
1519 | |
1520 | =item How much memory will an X kb tar file need? |
1521 | |
1522 | Probably more than X kb, since it will all be read into memory. If |
1523 | this is a problem, and you don't need to do in memory manipulation |
1524 | of the archive, consider using C</bin/tar> instead. |
1525 | |
1526 | =item What do you do with unsupported filetypes in an archive? |
1527 | |
1528 | C<Unix> has a few filetypes that aren't supported on other platforms, |
1529 | like C<Win32>. If we encounter a C<hardlink> or C<symlink> we'll just |
1530 | try to make a copy of the original file, rather than throwing an error. |
1531 | |
1532 | This does require you to read the entire archive in to memory first, |
1533 | since otherwise we wouldn't know what data to fill the copy with. |
1534 | (This means that you cannot use the class methods on archives that |
1535 | have incompatible filetypes and still expect things to work). |
1536 | |
1537 | For other filetypes, like C<chardevs> and C<blockdevs> we'll warn that |
1538 | the extraction of this particular item didn't work. |
1539 | |
b30bcf62 |
1540 | =item How do I extract only files that have property X from an archive? |
1541 | |
1542 | Sometimes, you might not wish to extract a complete archive, just |
1543 | the files that are relevant to you, based on some criteria. |
1544 | |
1545 | You can do this by filtering a list of C<Archive::Tar::File> objects |
1546 | based on your criteria. For example, to extract only files that have |
1547 | the string C<foo> in their title, you would use: |
1548 | |
1549 | $tar->extract( |
1550 | grep { $_->full_path =~ /foo/ } $tar->get_files |
1551 | ); |
1552 | |
1553 | This way, you can filter on any attribute of the files in the archive. |
1554 | Consult the C<Archive::Tar::File> documentation on how to use these |
1555 | objects. |
1556 | |
81a5970e |
1557 | =item How do I access .tar.Z files? |
1558 | |
1559 | The C<Archive::Tar> module can optionally use C<Compress::Zlib> (via |
1560 | the C<IO::Zlib> module) to access tar files that have been compressed |
1561 | with C<gzip>. Unfortunately tar files compressed with the Unix C<compress> |
1562 | utility cannot be read by C<Compress::Zlib> and so cannot be directly |
1563 | accesses by C<Archive::Tar>. |
1564 | |
1565 | If the C<uncompress> or C<gunzip> programs are available, you can use |
1566 | one of these workarounds to read C<.tar.Z> files from C<Archive::Tar> |
1567 | |
1568 | Firstly with C<uncompress> |
1569 | |
1570 | use Archive::Tar; |
1571 | |
1572 | open F, "uncompress -c $filename |"; |
1573 | my $tar = Archive::Tar->new(*F); |
1574 | ... |
1575 | |
1576 | and this with C<gunzip> |
1577 | |
1578 | use Archive::Tar; |
1579 | |
1580 | open F, "gunzip -c $filename |"; |
1581 | my $tar = Archive::Tar->new(*F); |
1582 | ... |
1583 | |
1584 | Similarly, if the C<compress> program is available, you can use this to |
1585 | write a C<.tar.Z> file |
1586 | |
1587 | use Archive::Tar; |
1588 | use IO::File; |
1589 | |
1590 | my $fh = new IO::File "| compress -c >$filename"; |
1591 | my $tar = Archive::Tar->new(); |
1592 | ... |
1593 | $tar->write($fh); |
1594 | $fh->close ; |
1595 | |
1596 | |
39713df4 |
1597 | =back |
1598 | |
1599 | =head1 TODO |
1600 | |
1601 | =over 4 |
1602 | |
1603 | =item Check if passed in handles are open for read/write |
1604 | |
1605 | Currently I don't know of any portable pure perl way to do this. |
1606 | Suggestions welcome. |
1607 | |
b3200c5d |
1608 | =item Allow archives to be passed in as string |
1609 | |
1610 | Currently, we only allow opened filehandles or filenames, but |
1611 | not strings. The internals would need some reworking to facilitate |
1612 | stringified archives. |
1613 | |
1614 | =item Facilitate processing an opened filehandle of a compressed archive |
1615 | |
1616 | Currently, we only support this if the filehandle is an IO::Zlib object. |
1617 | Environments, like apache, will present you with an opened filehandle |
1618 | to an uploaded file, which might be a compressed archive. |
1619 | |
39713df4 |
1620 | =back |
1621 | |
1622 | =head1 AUTHOR |
1623 | |
1624 | This module by |
1625 | Jos Boumans E<lt>kane@cpan.orgE<gt>. |
1626 | |
1627 | =head1 ACKNOWLEDGEMENTS |
1628 | |
1629 | Thanks to Sean Burke, Chris Nandor, Chip Salzenberg, Tim Heaney and |
1630 | especially Andrew Savige for their help and suggestions. |
1631 | |
1632 | =head1 COPYRIGHT |
1633 | |
1634 | This module is |
1635 | copyright (c) 2002 Jos Boumans E<lt>kane@cpan.orgE<gt>. |
1636 | All rights reserved. |
1637 | |
1638 | This library is free software; |
1639 | you may redistribute and/or modify it under the same |
1640 | terms as Perl itself. |
1641 | |
1642 | =cut |