2 if( $ENV{PERL_CORE} ) {
3 chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
8 BEGIN { chdir 't' if -d 't' }
10 use Test::More 'no_plan';
20 use File::Spec::Unix ();
21 use File::Basename ();
25 use Archive::Tar::Constant;
28 ### * change to fullname
29 ### * add tests for global variables
31 ### set up the environment ###
33 ### dirs filename contents
34 [ [], 'c', qr/^iiiiiiiiiiii\s*$/ ],
35 [ [], 'd', qr/^uuuuuuuu\s*$/ ],
38 ### includes binary data
39 my $ALL_CHARS = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";
41 ### @EXPECTBIN is used to ensure that $tarbin is written in the right
42 ### order and that the contents and order match exactly when extracted
44 ### dirs filename contents ###
45 [ [], 'bIn11', $ALL_CHARS x 11 ],
46 [ [], 'bIn3', $ALL_CHARS x 3 ],
47 [ [], 'bIn4', $ALL_CHARS x 4 ],
48 [ [], 'bIn1', $ALL_CHARS ],
49 [ [], 'bIn2', $ALL_CHARS x 2 ],
52 ### @EXPECTX is used to ensure that $tarx is written in the right
53 ### order and that the contents and order match exactly when extracted
54 ### the 'x/x' extraction used to fail before A::T 1.08
56 ### dirs filename contents
57 [ [ 'x' ], 'k', '', ],
58 [ [ 'x' ], 'x', 'j', ], # failed before A::T 1.08
61 my $LONG_FILE = qq[directory/really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-really-long-directory-name/myfile];
63 ### wintendo can't deal with too long paths, so we might have to skip tests ###
64 my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS')
65 && length( cwd(). $LONG_FILE ) > 247;
67 ### warn if we are going to skip long file names
68 $TOO_LONG ? diag("No long filename support - long filename extraction disabled")
69 : ( push @EXPECT_NORMAL, [ [], $LONG_FILE, qr/^hello\s*$/] ) ;
71 my @ROOT = grep { length } 'src', $TOO_LONG ? 'short' : 'long';
73 my $ZLIB = eval { require IO::Zlib; 1 } ? 1 : 0;
74 my $NO_UNLINK = $ARGV[0] ? 1 : 0;
77 $Archive::Tar::DEBUG = 1 if $ARGV[1];
79 ### tests for binary and x/x files
80 my $TARBIN = Archive::Tar->new;
81 my $TARX = Archive::Tar->new;
83 ### paths to a .tar and .tgz file to use for tests
84 my $TAR_FILE = File::Spec->catfile( @ROOT, 'bar.tar' );
85 my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' );
86 my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' );
87 my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' );
89 my $COMPRESS_FILE = 'copy';
90 $^O eq 'VMS' and $COMPRESS_FILE .= '.';
91 copy( File::Basename::basename($0), $COMPRESS_FILE );
92 chmod 0644, $COMPRESS_FILE;
94 ### done setting up environment ###
97 ### did we probe IO::Zlib support ok? ###
98 { is( Archive::Tar->can_handle_compressed_files, $ZLIB,
99 "Proper IO::Zlib support detected" );
104 { my $tar = Archive::Tar->new;
106 ok( $tar, "Object created" );
107 isa_ok( $tar, 'Archive::Tar');
109 local $Archive::Tar::WARN = 0;
111 ### should be empty to begin with
112 is( $tar->error, '', "The error string is empty" );
114 ### try a read on nothing
115 my @list = $tar->read();
117 ok(!(scalar @list), "Function read returns 0 files on error" );
118 ok( $tar->error, " error string is non empty" );
119 like( $tar->error, qr/No file to read from/,
120 " error string from create()" );
121 unlike( $tar->error, qr/add/, " error string does not contain add" );
123 ### now, add empty data
124 my $obj = $tar->add_data( '' );
126 ok( !$obj, "'add_data' returns undef on error" );
127 ok( $tar->error, " error string is non empty" );
128 like( $tar->error, qr/add/, " error string contains add" );
129 unlike( $tar->error, qr/create/," error string does not contain create" );
131 ### check if ->error eq $error
132 is( $tar->error, $Archive::Tar::error,
133 '$error matches error() method' );
137 { ### normal tar + gz compressed file
138 my $archive = $TAR_FILE;
139 my $compressed = $TGZ_FILE;
140 my $tar = Archive::Tar->new;
143 ### check we got the object
144 ok( $tar, "Object created" );
145 isa_ok( $tar, 'Archive::Tar');
147 for my $type( $archive, $compressed ) {
148 my $state = $gzip ? 'compressed' : 'uncompressed';
152 ### skip gz compressed archives wihtout IO::Zlib
153 skip( "No IO::Zlib - cannot read compressed archives",
154 4 + 2 * (scalar @EXPECT_NORMAL)
155 ) if( $gzip and !$ZLIB);
158 { my @list = $tar->read( $type );
159 my $cnt = scalar @list;
160 my $expect = scalar __PACKAGE__->get_expect();
162 ok( $cnt, "Reading $state file using 'read()'" );
163 is( $cnt, $expect, " All files accounted for" );
165 for my $file ( @list ) {
166 ok( $file, "Got File object" );
167 isa_ok( $file, "Archive::Tar::File" );
169 ### whitebox test -- make sure find_entry gets the
171 for my $test ( $file->full_path, $file ) {
172 is( $tar->_find_entry( $test ), $file,
173 " Found proper object" );
176 next unless $file->is_file;
178 my $name = $file->full_path;
179 my($expect_name, $expect_content) =
180 get_expect_name_and_contents( $name, \@EXPECT_NORMAL );
183 ok($expect_name," Found expected file '$name'" );
185 like($tar->get_content($name), $expect_content,
191 ### list_archive test
192 { my @list = Archive::Tar->list_archive( $archive );
193 my $cnt = scalar @list;
194 my $expect = scalar __PACKAGE__->get_expect();
196 ok( $cnt, "Reading $state file using 'list_archive'");
197 is( $cnt, $expect, " All files accounted for" );
199 for my $file ( @list ) {
200 next if __PACKAGE__->is_dir( $file ); # directories
202 my($expect_name, $expect_content) =
203 get_expect_name_and_contents( $file, \@EXPECT_NORMAL );
206 " Found expected file '$file'" );
211 ### now we try gz compressed archives
216 ### add files tests ###
217 { my @add = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
218 my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
219 my $tar = Archive::Tar->new;
221 ### check we got the object
222 ok( $tar, "Object created" );
223 isa_ok( $tar, 'Archive::Tar');
226 { my @files = $tar->add_files( @add );
228 is( scalar @files, scalar @add,
230 is( $files[0]->name, 'b', " Proper name" );
233 skip( "You are building perl using symlinks", 1)
234 if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/);
236 is( $files[0]->is_file, 1,
240 like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/,
243 ### check if we have then in our tar object
244 for my $file ( @addunix ) {
245 ok( $tar->contains_file($file),
246 " File found in archive" );
250 ### check adding files doesn't conflict with a secondary archive
251 ### old A::T bug, we should keep testing for it
252 { my $tar2 = Archive::Tar->new;
253 my @added = $tar2->add_files( $COMPRESS_FILE );
254 my @count = $tar2->list_files;
256 is( scalar @added, 1, "Added files to secondary archive" );
257 is( scalar @added, scalar @count,
258 " Does not conflict with first archive" );
260 ### check the adding of directories
261 my @add_dirs = File::Spec->catfile( @ROOT );
262 my @dirs = $tar2->add_files( @add_dirs );
263 is( scalar @dirs, scalar @add_dirs,
265 ok( $dirs[0]->is_dir, " Proper type" );
269 ### add data tests ###
271 { ### standard data ###
272 my @to_add = ( 'a', 'aaaaa' );
273 my $tar = Archive::Tar->new;
275 ### check we got the object
276 ok( $tar, "Object created" );
277 isa_ok( $tar, 'Archive::Tar');
279 ### add a new file item as data
280 my $obj = $tar->add_data( @to_add );
282 ok( $obj, "Adding data" );
283 is( $obj->name, $to_add[0], " Proper name" );
284 is( $obj->is_file, 1, " Proper type" );
285 like( $obj->get_content, qr/^$to_add[1]\s*$/,
290 ### dir/file structure -- x/y always went ok, x/x used to extract
291 ### in the wrong way -- this test catches that
292 for my $list ( [$TARBIN, \@EXPECTBIN],
295 ### XXX GLOBAL! changes may affect other tests!
296 my($tar,$struct) = @$list;
298 for my $aref ( @$struct ) {
299 my ($dirs,$file,$data) = @$aref;
301 my $path = File::Spec::Unix->catfile(
302 grep { length } @$dirs, $file );
304 my $obj = $tar->add_data( $path, $data );
306 ok( $obj, "Adding data '$file'" );
307 is( $obj->full_path, $path,
309 ok( $obj->is_file, " Proper type" );
310 is( $obj->get_content, $data,
317 ### rename/replace_content tests ###
318 { my $tar = Archive::Tar->new;
322 ### read in the file, check the proper files are there
323 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
324 ok( $tar->get_files($from), " Found file '$from'" );
325 { local $Archive::Tar::WARN = 0;
326 ok(!$tar->get_files($to), " File '$to' not yet found" );
329 ### rename an entry, check the rename has happened
330 ok( $tar->rename( $from, $to ), " Renamed '$from' to '$to'" );
331 ok( $tar->get_files($to), " File '$to' now found" );
332 { local $Archive::Tar::WARN = 0;
333 ok(!$tar->get_files($from), " File '$from' no longer found'");
336 ### now, replace the content
337 my($expect_name, $expect_content) =
338 get_expect_name_and_contents( $from, \@EXPECT_NORMAL );
340 like( $tar->get_content($to), $expect_content,
341 "Original content of '$from' in '$to'" );
342 ok( $tar->replace_content( $to, $from ),
343 " Set content for '$to' to '$from'" );
344 is( $tar->get_content($to), $from,
345 " Content for '$to' is indeed '$from'" );
350 my $tar = Archive::Tar->new;
352 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
354 ### remove returns the files left, which should be equal to list_files
355 is( scalar($tar->remove($remove)), scalar($tar->list_files),
356 "Removing file '$remove'" );
358 ### so what's left should be all expected files minus 1
359 is( scalar($tar->list_files), scalar(__PACKAGE__->get_expect) - 1,
360 " Proper files remaining" );
363 ### write + read + extract tests ###
365 skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO &&
366 !$Archive::Tar::HAS_IO_STRING;
368 my $tar = Archive::Tar->new;
369 my $new = Archive::Tar->new;
370 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
372 for my $aref ( [$tar, \@EXPECT_NORMAL],
373 [$TARBIN, \@EXPECTBIN],
376 my($obj,$struct) = @$aref;
378 ### check if we stringify it ok
379 { my $string = $obj->write;
380 ok( $string, "Stringified tar file has size" );
381 cmp_ok( length($string) % BLOCK, '==', 0,
382 "Tar archive stringified" );
386 { my $out = $OUT_TAR_FILE;
389 ok( $obj->write($out),
390 "Wrote tarfile using 'write'" );
391 check_tar_file( $out );
392 check_tar_object( $obj, $struct );
394 ### now read it in again
395 ok( $new->read( $out ),
396 "Read '$out' in again" );
398 check_tar_object( $new, $struct );
400 ### now extract it again
401 ok( $new->extract, "Extracted '$out' with 'extract'" );
402 check_tar_extract( $new, $struct );
404 rm( $out ) unless $NO_UNLINK;
408 { ### create_archive()
409 ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
410 "Wrote tarfile using 'create_archive'" );
411 check_tar_file( $out );
413 ### now extract it again
414 ok( Archive::Tar->extract_archive( $out ),
415 "Extracted file using 'extract_archive'");
416 rm( $out ) unless $NO_UNLINK;
421 { my $out = $OUT_TGZ_FILE;
425 ### weird errors from scalar(@x,@y,@z), dot it this way...
427 map { $file_cnt += scalar @$_ } \@EXPECT_NORMAL, \@EXPECTBIN,
430 my $cnt = 5 + # the tests below
431 (5*3*2) + # check_tgz_file
432 # check_tar_object fixed tests
433 (3 * 2 * (2 + $file_cnt)) +
434 ((4*$file_cnt) + 1);# check_tar_extract tests
436 skip( "No IO::Zlib - cannot write compressed archives", $cnt )
440 ok($obj->write($out, 1),
441 "Writing compressed file using 'write'" );
442 check_tgz_file( $out );
443 check_tar_object( $obj, $struct );
445 ### now read it in again
446 ok( $new->read( $out ),
447 "Read '$out' in again" );
448 check_tar_object( $new, $struct );
450 ### now extract it again
452 "Extracted '$out' again" );
453 check_tar_extract( $new, $struct );
455 rm( $out ) unless $NO_UNLINK;
458 { ### create_archive()
459 ok( Archive::Tar->create_archive( $out, 1, $COMPRESS_FILE ),
460 "Wrote gzip file using 'create_archive'" );
461 check_tgz_file( $out );
463 ### now extract it again
464 ok( Archive::Tar->extract_archive( $out, 1 ),
465 "Extracted file using 'extract_archive'");
466 rm( $out ) unless $NO_UNLINK;
474 ### limited read + extract tests ###
475 { my $tar = Archive::Tar->new;
476 my @files = $tar->read( $TAR_FILE, 0, { limit => 1 } );
479 is( scalar @files, 1, "Limited read" );
481 my ($name,$content) = get_expect_name_and_contents(
482 $obj->full_path, \@EXPECT_NORMAL );
484 is( $obj->name, $name, " Expected file found" );
487 ### extract this single file to cwd()
488 for my $meth (qw[extract extract_file]) {
490 ### extract it by full path and object
491 for my $arg ( $obj, $obj->full_path ) {
493 ok( $tar->$meth( $arg ),
494 "Extracted '$name' to cwd() with $meth" );
495 ok( -e $obj->full_path, " Extracted file exists" );
496 rm( $obj->full_path ) unless $NO_UNLINK;
500 ### extract this file to @ROOT
501 ### can only do that with 'extract_file', not with 'extract'
502 for my $meth (qw[extract_file]) {
503 my $outpath = File::Spec->catdir( @ROOT );
504 my $outfile = File::Spec->catfile( $outpath, $$ ); #$obj->full_path );
506 ok( $tar->$meth( $obj->full_path, $outfile ),
507 "Extracted file '$name' to $outpath with $meth" );
508 ok( -e $outfile, " Extracted file '$outfile' exists" );
509 rm( $outfile ) unless $NO_UNLINK;
516 { my $tar = Archive::Tar->new;
517 my @files = $tar->read( $TAR_FILE );
519 my $cnt = $tar->list_files();
520 ok( $cnt, "Found old data" );
521 ok( $tar->clear, " Clearing old data" );
523 my $new_cnt = $tar->list_files;
524 ok( !$new_cnt, " Old data cleared" );
527 ### $DO_NOT_USE_PREFIX tests
528 { my $tar = Archive::Tar->new;
531 ### first write a tar file without prefix
532 { my ($obj) = $tar->add_files( $COMPRESS_FILE );
533 my $dir = ''; # dir is empty!
534 my $file = File::Basename::basename( $COMPRESS_FILE );
536 ok( $obj, "File added" );
537 isa_ok( $obj, "Archive::Tar::File" );
539 ### internal storage ###
540 is( $obj->name, $file, " Name set to '$file'" );
541 is( $obj->prefix, $dir, " Prefix set to '$dir'" );
543 ### write the tar file without a prefix in it
544 local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
545 ok( $tar->write( $OUT_TAR_FILE ),
546 " Tar file written" );
548 ### and forget all about it...
552 ### now read it back in, there should be no prefix
553 { ok( $tar->read( $OUT_TAR_FILE ),
554 "Tar file read in again" );
556 my ($obj) = $tar->get_files;
557 ok( $obj, " File retrieved" );
558 isa_ok( $obj, "Archive::Tar::File" );
560 is( $obj->name, $COMPRESS_FILE,
561 " Name now set to '$COMPRESS_FILE'" );
562 is( $obj->prefix, '', " Prefix now empty" );
564 my $re = quotemeta $COMPRESS_FILE;
565 like( $obj->raw, qr/^$re/, " Prefix + name in name slot of header" );
568 rm( $OUT_TAR_FILE ) unless $NO_UNLINK;
573 for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) {
574 for my $aref (@$struct) {
576 my $dir = $aref->[0]->[0];
577 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
581 my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE );
582 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
583 1 while unlink $COMPRESS_FILE;
586 ###########################
588 ###########################
593 File::Spec::Unix->catfile(
594 grep { defined } @{$_->[0]}, $_->[1]
601 return $file =~ m|/$| ? 1 : 0;
615 my $filesize = -s $file;
616 my $contents = slurp_binfile( $file );
618 ok( defined( $contents ), " File read" );
619 ok( $filesize, " File written size=$filesize" );
621 cmp_ok( $filesize % BLOCK, '==', 0,
622 " File size is a multiple of 512" );
624 cmp_ok( length($contents), '==', $filesize,
625 " File contents match size" );
627 is( TAR_END x 2, substr( $contents, -(BLOCK*2) ),
628 " Ends with 1024 null bytes" );
635 my $filesize = -s $file;
636 my $contents = slurp_gzfile( $file );
637 my $uncompressedsize = length $contents;
639 ok( defined( $contents ), " File read and uncompressed" );
640 ok( $filesize, " File written size=$filesize uncompressed size=$uncompressedsize" );
642 cmp_ok( $uncompressedsize % BLOCK, '==', 0,
643 " Uncompressed size is a multiple of 512" );
645 is( TAR_END x 2, substr($contents, -(BLOCK*2)),
646 " Ends with 1024 null bytes" );
648 cmp_ok( $filesize, '<', $uncompressedsize,
649 " Compressed size < uncompressed size" );
654 sub check_tar_object {
656 my $struct = shift or return;
658 ### amount of files (not dirs!) there should be in the object
659 my $expect = scalar @$struct;
660 my @files = grep { $_->is_file } $obj->get_files;
662 ### count how many files there are in the object
663 ok( scalar @files, " Found some files in the archive" );
664 is( scalar @files, $expect, " Found expected number of files" );
666 for my $file (@files) {
669 #my $path = File::Spec::Unix->catfile(
670 # grep { length } $file->prefix, $file->name );
671 my($ename,$econtent) =
672 get_expect_name_and_contents( $file->full_path, $struct );
674 ok( $file->is_file, " It is a file" );
675 is( $file->full_path, $ename,
676 " Name matches expected name" );
677 like( $file->get_content, $econtent,
678 " Content as expected" );
682 sub check_tar_extract {
687 for my $file ($tar->get_files) {
688 push @dirs, $file && next if $file->is_dir;
691 my $path = $file->full_path;
692 my($ename,$econtent) =
693 get_expect_name_and_contents( $path, $struct );
696 is( $ename, $path, " Expected file found" );
697 ok( -e $path, " File '$path' exists" );
700 open $fh, "$path" or warn "Error opening file '$path': $!\n";
703 ok( $fh, " Opening file" );
705 my $content = do{local $/;<$fh>}; chomp $content;
706 like( $content, qr/$econtent/,
709 $NO_UNLINK or 1 while unlink $path;
711 ### alternate extract path tests
712 ### to abs and rel paths
713 { for my $outpath ( File::Spec->catdir( @ROOT ),
715 File::Spec->catdir( @ROOT )
719 my $outfile = File::Spec->catfile( $outpath, $$ );
721 ok( $tar->extract_file( $file->full_path, $outfile ),
722 " Extracted file '$path' to $outfile" );
723 ok( -e $outfile," Extracted file '$outfile' exists" );
725 rm( $outfile ) unless $NO_UNLINK;
730 ### now check if list_files is returning the same info as get_files
731 is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files],
732 " Verified via list_files as well" );
734 #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK }
740 my $fh = IO::File->new;
742 $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef;
755 my $fh = new IO::Zlib;
756 $fh->open( $file, READ_ONLY->(1) )
757 or warn( "Error opening '$file' with IO::Zlib" ), return undef;
759 $str .= $buff while $fh->read( $buff, 4096 ) > 0;
764 sub get_expect_name_and_contents {
766 my $struct = shift or return;
768 ### find the proper name + contents for this file from
769 ### the expect structure
770 my ($name, $content) =
777 File::Spec::Unix->catfile(
778 grep { length } @{$_->[0]}, $_->[1]
786 unless( ref $content ) {
787 my $x = quotemeta ($content || '');
792 warn "Could not find '$find' in " . Dumper $struct;
795 return ($name, $content);