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';
19 use File::Spec::Unix ();
20 use File::Basename ();
24 use Archive::Tar::Constant;
27 ### * change to fullname
28 ### * add tests for global variables
30 ### set up the environment ###
32 ### dirs filename contents
33 [ [], 'c', qr/^iiiiiiiiiiii\s*$/ ],
34 [ [], 'd', qr/^uuuuuuuu\s*$/ ],
37 ### includes binary data
38 my $ALL_CHARS = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";
40 ### @EXPECTBIN is used to ensure that $tarbin is written in the right
41 ### order and that the contents and order match exactly when extracted
43 ### dirs filename contents ###
44 [ [], 'bIn11', $ALL_CHARS x 11 ],
45 [ [], 'bIn3', $ALL_CHARS x 3 ],
46 [ [], 'bIn4', $ALL_CHARS x 4 ],
47 [ [], 'bIn1', $ALL_CHARS ],
48 [ [], 'bIn2', $ALL_CHARS x 2 ],
51 ### @EXPECTX is used to ensure that $tarx is written in the right
52 ### order and that the contents and order match exactly when extracted
53 ### the 'x/x' extraction used to fail before A::T 1.08
55 ### dirs filename contents
56 [ [ 'x' ], 'k', '', ],
57 [ [ 'x' ], 'x', 'j', ], # failed before A::T 1.08
60 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];
62 ### wintendo can't deal with too long paths, so we might have to skip tests ###
63 my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin')
64 && length( cwd(). $LONG_FILE ) > 247;
66 ### warn if we are going to skip long file names
67 $TOO_LONG ? diag("No long filename support - long filename extraction disabled")
68 : ( push @EXPECT_NORMAL, [ [], $LONG_FILE, qr/^hello\s*$/] ) ;
70 my @ROOT = grep { length } 'src', $TOO_LONG ? 'short' : 'long';
72 my $ZLIB = eval { require IO::Zlib; 1 } ? 1 : 0;
73 my $NO_UNLINK = $ARGV[0] ? 1 : 0;
76 $Archive::Tar::DEBUG = 1 if $ARGV[1];
78 ### tests for binary and x/x files
79 my $TARBIN = Archive::Tar->new;
80 my $TARX = Archive::Tar->new;
82 ### paths to a .tar and .tgz file to use for tests
83 my $TAR_FILE = File::Spec->catfile( @ROOT, 'bar.tar' );
84 my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' );
85 my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' );
86 my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' );
88 copy( File::Basename::basename($0), 'copy' );
89 my $COMPRESS_FILE = 'copy';
90 chmod 0644, $COMPRESS_FILE;
92 ### done setting up environment ###
95 ### did we probe IO::Zlib support ok? ###
96 { is( Archive::Tar->can_handle_compressed_files, $ZLIB,
97 "Proper IO::Zlib support detected" );
102 { my $tar = Archive::Tar->new;
104 ok( $tar, "Object created" );
105 isa_ok( $tar, 'Archive::Tar');
107 local $Archive::Tar::WARN = 0;
109 ### should be empty to begin with
110 is( $tar->error, '', "The error string is empty" );
112 ### try a read on nothing
113 my @list = $tar->read();
115 ok(!(scalar @list), "Function read returns 0 files on error" );
116 ok( $tar->error, " error string is non empty" );
117 like( $tar->error, qr/No file to read from/,
118 " error string from create()" );
119 unlike( $tar->error, qr/add/, " error string does not contain add" );
121 ### now, add empty data
122 my $obj = $tar->add_data( '' );
124 ok( !$obj, "'add_data' returns undef on error" );
125 ok( $tar->error, " error string is non empty" );
126 like( $tar->error, qr/add/, " error string contains add" );
127 unlike( $tar->error, qr/create/," error string does not contain create" );
129 ### check if ->error eq $error
130 is( $tar->error, $Archive::Tar::error,
131 '$error matches error() method' );
135 { ### normal tar + gz compressed file
136 my $archive = $TAR_FILE;
137 my $compressed = $TGZ_FILE;
138 my $tar = Archive::Tar->new;
141 ### check we got the object
142 ok( $tar, "Object created" );
143 isa_ok( $tar, 'Archive::Tar');
145 for my $type( $archive, $compressed ) {
146 my $state = $gzip ? 'compressed' : 'uncompressed';
150 ### skip gz compressed archives wihtout IO::Zlib
151 skip( "No IO::Zlib - cannot read compressed archives",
152 4 + 2 * (scalar @EXPECT_NORMAL)
153 ) if( $gzip and !$ZLIB);
156 { my @list = $tar->read( $type );
157 my $cnt = scalar @list;
158 my $expect = scalar __PACKAGE__->get_expect();
160 ok( $cnt, "Reading $state file using 'read()'" );
161 is( $cnt, $expect, " All files accounted for" );
163 for my $file ( @list ) {
164 ok( $file, "Got File object" );
165 isa_ok( $file, "Archive::Tar::File" );
167 next unless $file->is_file;
169 my $name = $file->full_path;
170 my($expect_name, $expect_content) =
171 get_expect_name_and_contents( $name, \@EXPECT_NORMAL );
174 ok($expect_name," Found expected file '$name'" );
176 like($tar->get_content($name), $expect_content,
182 ### list_archive test
183 { my @list = Archive::Tar->list_archive( $archive );
184 my $cnt = scalar @list;
185 my $expect = scalar __PACKAGE__->get_expect();
187 ok( $cnt, "Reading $state file using 'list_archive'");
188 is( $cnt, $expect, " All files accounted for" );
190 for my $file ( @list ) {
191 next if __PACKAGE__->is_dir( $file ); # directories
193 my($expect_name, $expect_content) =
194 get_expect_name_and_contents( $file, \@EXPECT_NORMAL );
197 " Found expected file '$file'" );
202 ### now we try gz compressed archives
207 ### add files tests ###
208 { my @add = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
209 my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
210 my $tar = Archive::Tar->new;
212 ### check we got the object
213 ok( $tar, "Object created" );
214 isa_ok( $tar, 'Archive::Tar');
217 { my @files = $tar->add_files( @add );
219 is( scalar @files, scalar @add,
221 is( $files[0]->name, 'b', " Proper name" );
222 is( $files[0]->is_file, 1, " Proper type" );
223 like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/,
226 ### check if we have then in our tar object
227 for my $file ( @addunix ) {
228 ok( $tar->contains_file($file),
229 " File found in archive" );
233 ### check adding files doesn't conflict with a secondary archive
234 ### old A::T bug, we should keep testing for it
235 { my $tar2 = Archive::Tar->new;
236 my @added = $tar2->add_files( $COMPRESS_FILE );
237 my @count = $tar2->list_files;
239 is( scalar @added, 1, "Added files to secondary archive" );
240 is( scalar @added, scalar @count,
241 " Does not conflict with first archive" );
243 ### check the adding of directories
244 my @add_dirs = File::Spec->catfile( @ROOT );
245 my @dirs = $tar2->add_files( @add_dirs );
246 is( scalar @dirs, scalar @add_dirs,
248 ok( $dirs[0]->is_dir, " Proper type" );
252 ### add data tests ###
254 { ### standard data ###
255 my @to_add = ( 'a', 'aaaaa' );
256 my $tar = Archive::Tar->new;
258 ### check we got the object
259 ok( $tar, "Object created" );
260 isa_ok( $tar, 'Archive::Tar');
262 ### add a new file item as data
263 my $obj = $tar->add_data( @to_add );
265 ok( $obj, "Adding data" );
266 is( $obj->name, $to_add[0], " Proper name" );
267 is( $obj->is_file, 1, " Proper type" );
268 like( $obj->get_content, qr/^$to_add[1]\s*$/,
273 ### dir/file structure -- x/y always went ok, x/x used to extract
274 ### in the wrong way -- this test catches that
275 for my $list ( [$TARBIN, \@EXPECTBIN],
278 ### XXX GLOBAL! changes may affect other tests!
279 my($tar,$struct) = @$list;
281 for my $aref ( @$struct ) {
282 my ($dirs,$file,$data) = @$aref;
284 my $path = File::Spec::Unix->catfile(
285 grep { length } @$dirs, $file );
287 my $obj = $tar->add_data( $path, $data );
289 ok( $obj, "Adding data '$file'" );
290 is( $obj->full_path, $path,
292 ok( $obj->is_file, " Proper type" );
293 is( $obj->get_content, $data,
300 ### rename/replace_content tests ###
301 { my $tar = Archive::Tar->new;
305 ### read in the file, check the proper files are there
306 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
307 ok( $tar->get_files($from), " Found file '$from'" );
308 { local $Archive::Tar::WARN = 0;
309 ok(!$tar->get_files($to), " File '$to' not yet found" );
312 ### rename an entry, check the rename has happened
313 ok( $tar->rename( $from, $to ), " Renamed '$from' to '$to'" );
314 ok( $tar->get_files($to), " File '$to' now found" );
315 { local $Archive::Tar::WARN = 0;
316 ok(!$tar->get_files($from), " File '$from' no longer found'");
319 ### now, replace the content
320 my($expect_name, $expect_content) =
321 get_expect_name_and_contents( $from, \@EXPECT_NORMAL );
323 like( $tar->get_content($to), $expect_content,
324 "Original content of '$from' in '$to'" );
325 ok( $tar->replace_content( $to, $from ),
326 " Set content for '$to' to '$from'" );
327 is( $tar->get_content($to), $from,
328 " Content for '$to' is indeed '$from'" );
333 my $tar = Archive::Tar->new;
335 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
337 ### remove returns the files left, which should be equal to list_files
338 is( scalar($tar->remove($remove)), scalar($tar->list_files),
339 "Removing file '$remove'" );
341 ### so what's left should be all expected files minus 1
342 is( scalar($tar->list_files), scalar(__PACKAGE__->get_expect) - 1,
343 " Proper files remaining" );
346 ### write + read + extract tests ###
348 skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO &&
349 !$Archive::Tar::HAS_IO_STRING;
351 my $tar = Archive::Tar->new;
352 my $new = Archive::Tar->new;
353 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" );
355 for my $aref ( [$tar, \@EXPECT_NORMAL],
356 [$TARBIN, \@EXPECTBIN],
359 my($obj,$struct) = @$aref;
361 ### check if we stringify it ok
362 { my $string = $obj->write;
363 ok( $string, "Stringified tar file has size" );
364 cmp_ok( length($string) % BLOCK, '==', 0,
365 "Tar archive stringified" );
369 { my $out = $OUT_TAR_FILE;
372 ok( $obj->write($out),
373 "Wrote tarfile using 'write'" );
374 check_tar_file( $out );
375 check_tar_object( $obj, $struct );
377 ### now read it in again
378 ok( $new->read( $out ),
379 "Read '$out' in again" );
381 check_tar_object( $new, $struct );
383 ### now extract it again
384 ok( $new->extract, "Extracted '$out' with 'extract'" );
385 check_tar_extract( $new, $struct );
387 rm( $out ) unless $NO_UNLINK;
391 { ### create_archive()
392 ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
393 "Wrote tarfile using 'create_archive'" );
394 check_tar_file( $out );
396 ### now extract it again
397 ok( Archive::Tar->extract_archive( $out ),
398 "Extracted file using 'extract_archive'");
399 rm( $out ) unless $NO_UNLINK;
404 { my $out = $OUT_TGZ_FILE;
408 ### weird errors from scalar(@x,@y,@z), dot it this way...
410 map { $file_cnt += scalar @$_ } \@EXPECT_NORMAL, \@EXPECTBIN,
413 my $cnt = 5 + # the tests below
414 (5*3*2) + # check_tgz_file
415 # check_tar_object fixed tests
416 (3 * 2 * (2 + $file_cnt)) +
417 ((4*$file_cnt) + 1);# check_tar_extract tests
419 skip( "No IO::Zlib - cannot write compressed archives", $cnt )
423 ok($obj->write($out, 1),
424 "Writing compressed file using 'write'" );
425 check_tgz_file( $out );
426 check_tar_object( $obj, $struct );
428 ### now read it in again
429 ok( $new->read( $out ),
430 "Read '$out' in again" );
431 check_tar_object( $new, $struct );
433 ### now extract it again
435 "Extracted '$out' again" );
436 check_tar_extract( $new, $struct );
438 rm( $out ) unless $NO_UNLINK;
441 { ### create_archive()
442 ok( Archive::Tar->create_archive( $out, 1, $COMPRESS_FILE ),
443 "Wrote gzip file using 'create_archive'" );
444 check_tgz_file( $out );
446 ### now extract it again
447 ok( Archive::Tar->extract_archive( $out, 1 ),
448 "Extracted file using 'extract_archive'");
449 rm( $out ) unless $NO_UNLINK;
457 ### limited read + extract tests ###
458 { my $tar = Archive::Tar->new;
459 my @files = $tar->read( $TAR_FILE, 0, { limit => 1 } );
462 is( scalar @files, 1, "Limited read" );
464 my ($name,$content) = get_expect_name_and_contents(
465 $obj->full_path, \@EXPECT_NORMAL );
467 is( $obj->name, $name, " Expected file found" );
469 ### extract this single file to cwd()
470 for my $meth (qw[extract extract_file]) {
471 ok( $tar->$meth( $obj->full_path ),
472 "Extracted '$name' to cwd() with $meth" );
473 ok( -e $obj->full_path, " Extracted file exists" );
474 rm( $obj->full_path ) unless $NO_UNLINK;
477 ### extract this file to @ROOT
478 ### can only do that with 'extract_file', not with 'extract'
479 for my $meth (qw[extract_file]) {
480 my $outpath = File::Spec->catdir( @ROOT );
481 my $outfile = File::Spec->catfile( $outpath, $$ ); #$obj->full_path );
483 ok( $tar->$meth( $obj->full_path, $outfile ),
484 "Extracted file '$name' to $outpath with $meth" );
485 ok( -e $outfile, " Extracted file '$outfile' exists" );
486 rm( $outfile ) unless $NO_UNLINK;
493 { my $tar = Archive::Tar->new;
494 my @files = $tar->read( $TAR_FILE );
496 my $cnt = $tar->list_files();
497 ok( $cnt, "Found old data" );
498 ok( $tar->clear, " Clearing old data" );
500 my $new_cnt = $tar->list_files;
501 ok( !$new_cnt, " Old data cleared" );
504 ### $DO_NOT_USE_PREFIX tests
505 { my $tar = Archive::Tar->new;
508 ### first write a tar file without prefix
509 { my ($obj) = $tar->add_files( $COMPRESS_FILE );
510 my $dir = ''; # dir is empty!
511 my $file = File::Basename::basename( $COMPRESS_FILE );
513 ok( $obj, "File added" );
514 isa_ok( $obj, "Archive::Tar::File" );
516 ### internal storage ###
517 is( $obj->name, $file, " Name set to '$file'" );
518 is( $obj->prefix, $dir, " Prefix set to '$dir'" );
520 ### write the tar file without a prefix in it
521 local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
522 ok( $tar->write( $OUT_TAR_FILE ),
523 " Tar file written" );
525 ### and forget all about it...
529 ### now read it back in, there should be no prefix
530 { ok( $tar->read( $OUT_TAR_FILE ),
531 "Tar file read in again" );
533 my ($obj) = $tar->get_files;
534 ok( $obj, " File retrieved" );
535 isa_ok( $obj, "Archive::Tar::File" );
537 is( $obj->name, $COMPRESS_FILE,
538 " Name now set to '$COMPRESS_FILE'" );
539 is( $obj->prefix, '', " Prefix now empty" );
541 my $re = quotemeta $COMPRESS_FILE;
542 like( $obj->raw, qr/^$re/, " Prefix + name in name slot of header" );
545 rm( $OUT_TAR_FILE ) unless $NO_UNLINK;
550 for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) {
551 for my $aref (@$struct) {
553 my $dir = $aref->[0]->[0];
554 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
558 my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE );
559 rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
562 ###########################
564 ###########################
569 File::Spec::Unix->catfile(
570 grep { defined } @{$_->[0]}, $_->[1]
577 return $file =~ m|/$| ? 1 : 0;
582 is_dir($x) ? rmtree($x) : unlink $x;
587 my $filesize = -s $file;
588 my $contents = slurp_binfile( $file );
590 ok( defined( $contents ), " File read" );
591 ok( $filesize, " File written size=$filesize" );
593 cmp_ok( $filesize % BLOCK, '==', 0,
594 " File size is a multiple of 512" );
596 cmp_ok( length($contents), '==', $filesize,
597 " File contents match size" );
599 is( TAR_END x 2, substr( $contents, -(BLOCK*2) ),
600 " Ends with 1024 null bytes" );
607 my $filesize = -s $file;
608 my $contents = slurp_gzfile( $file );
609 my $uncompressedsize = length $contents;
611 ok( defined( $contents ), " File read and uncompressed" );
612 ok( $filesize, " File written size=$filesize uncompressed size=$uncompressedsize" );
614 cmp_ok( $uncompressedsize % BLOCK, '==', 0,
615 " Uncompressed size is a multiple of 512" );
617 is( TAR_END x 2, substr($contents, -(BLOCK*2)),
618 " Ends with 1024 null bytes" );
620 cmp_ok( $filesize, '<', $uncompressedsize,
621 " Compressed size < uncompressed size" );
626 sub check_tar_object {
628 my $struct = shift or return;
630 ### amount of files (not dirs!) there should be in the object
631 my $expect = scalar @$struct;
632 my @files = grep { $_->is_file } $obj->get_files;
634 ### count how many files there are in the object
635 ok( scalar @files, " Found some files in the archive" );
636 is( scalar @files, $expect, " Found expected number of files" );
638 for my $file (@files) {
641 #my $path = File::Spec::Unix->catfile(
642 # grep { length } $file->prefix, $file->name );
643 my($ename,$econtent) =
644 get_expect_name_and_contents( $file->full_path, $struct );
646 ok( $file->is_file, " It is a file" );
647 is( $file->full_path, $ename,
648 " Name matches expected name" );
649 like( $file->get_content, $econtent,
650 " Content as expected" );
654 sub check_tar_extract {
659 for my $file ($tar->get_files) {
660 push @dirs, $file && next if $file->is_dir;
663 my $path = $file->full_path;
664 my($ename,$econtent) =
665 get_expect_name_and_contents( $path, $struct );
668 is( $ename, $path, " Expected file found" );
669 ok( -e $path, " File '$path' exists" );
672 open $fh, "$path" or warn "Error opening file '$path': $!\n";
675 ok( $fh, " Opening file" );
677 my $content = do{local $/;<$fh>}; chomp $content;
678 like( $content, qr/$econtent/,
681 unlink $path unless $NO_UNLINK;
683 ### alternate extract path tests
684 ### to abs and rel paths
685 { for my $outpath ( File::Spec->catdir( @ROOT ),
687 File::Spec->catdir( @ROOT )
691 my $outfile = File::Spec->catfile( $outpath, $$ );
693 ok( $tar->extract_file( $file->full_path, $outfile ),
694 " Extracted file '$path' to $outfile" );
695 ok( -e $outfile," Extracted file '$outfile' exists" );
697 rm( $outfile ) unless $NO_UNLINK;
702 ### now check if list_files is returning the same info as get_files
703 is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files],
704 " Verified via list_files as well" );
706 #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK }
712 my $fh = IO::File->new;
714 $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef;
727 my $fh = new IO::Zlib;
728 $fh->open( $file, READ_ONLY->(1) )
729 or warn( "Error opening '$file' with IO::Zlib" ), return undef;
731 $str .= $buff while $fh->read( $buff, 4096 ) > 0;
736 sub get_expect_name_and_contents {
738 my $struct = shift or return;
740 ### find the proper name + contents for this file from
741 ### the expect structure
742 my ($name, $content) =
749 File::Spec::Unix->catfile(
750 grep { length } @{$_->[0]}, $_->[1]
758 unless( ref $content ) {
759 my $x = quotemeta ($content || '');
764 warn "Could not find '$find' in " . Dumper $struct;
767 return ($name, $content);