1BEGIN { chdir 't' if -d 't' } 2 3use Test::More 'no_plan'; 4use strict; 5use lib '../lib'; 6 7use Cwd; 8use Config; 9use IO::File; 10use File::Copy; 11use File::Path; 12use File::Spec (); 13use File::Spec::Unix (); 14use File::Basename (); 15use Data::Dumper; 16 17### need the constants at compile time; 18use Archive::Tar::Constant; 19 20my $Class = 'Archive::Tar'; 21my $FClass = $Class . '::File'; 22use_ok( $Class ); 23 24 25 26### XXX TODO: 27### * change to fullname 28### * add tests for global variables 29 30### set up the environment ### 31my @EXPECT_NORMAL = ( 32 ### dirs filename contents 33 [ [], 'c', qr/^iiiiiiiiiiii\s*$/ ], 34 [ [], 'd', qr/^uuuuuuuu\s*$/ ], 35); 36 37### includes binary data 38my $ALL_CHARS = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r"; 39 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 42my @EXPECTBIN = ( 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 ], 49); 50 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 54my @EXPECTX = ( 55 ### dirs filename contents 56 [ [ 'x' ], 'k', '', ], 57 [ [ 'x' ], 'x', 'j', ], # failed before A::T 1.08 58); 59 60my $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]; 61 62### wintendo can't deal with too long paths, so we might have to skip tests ### 63my $TOO_LONG = ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS') 64 && length( cwd(). $LONG_FILE ) > 247; 65 66if(!$TOO_LONG) { 67 my $alt = File::Spec->catfile( cwd(), $LONG_FILE); 68 eval 'mkpath([$alt]);'; 69 if($@) 70 { 71 $TOO_LONG = 1; 72 } 73 else 74 { 75 $@ = ''; 76 my $base = File::Spec->catfile( cwd(), 'directory'); 77 rmtree $base; 78 } 79} 80### warn if we are going to skip long file names 81if ($TOO_LONG) { 82 diag("No long filename support - long filename extraction disabled") if ! $ENV{PERL_CORE}; 83} else { 84 push @EXPECT_NORMAL, [ [], $LONG_FILE, qr/^hello\s*$/]; 85} 86 87my @ROOT = grep { length } 'src', $TOO_LONG ? 'short' : 'long'; 88my $NO_UNLINK = $ARGV[0] ? 1 : 0; 89 90### enable debugging? 91### pesky warnings 92$Archive::Tar::DEBUG = $Archive::Tar::DEBUG = 1 if $ARGV[1]; 93 94### tests for binary and x/x files 95my $TARBIN = $Class->new; 96my $TARX = $Class->new; 97 98### paths to a .tar and .tgz file to use for tests 99my $TAR_FILE = File::Spec->catfile( @ROOT, 'bar.tar' ); 100my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' ); 101my $TBZ_FILE = File::Spec->catfile( @ROOT, 'foo.tbz' ); 102my $TXZ_FILE = File::Spec->catfile( @ROOT, 'foo.txz' ); 103my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' ); 104my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' ); 105my $OUT_TBZ_FILE = File::Spec->catfile( @ROOT, 'out.tbz' ); 106my $OUT_TXZ_FILE = File::Spec->catfile( @ROOT, 'out.txz' ); 107 108my $COMPRESS_FILE = 'copy'; 109$^O eq 'VMS' and $COMPRESS_FILE .= '.'; 110copy( File::Basename::basename($0), $COMPRESS_FILE ); 111chmod 0644, $COMPRESS_FILE; 112 113### done setting up environment ### 114 115### check for zlib/bzip2/xz support 116{ for my $meth ( qw[has_zlib_support has_bzip2_support has_xz_support] ) { 117 can_ok( $Class, $meth ); 118 } 119} 120 121 122 123### tar error tests 124{ my $tar = $Class->new; 125 126 ok( $tar, "Object created" ); 127 isa_ok( $tar, $Class ); 128 129 local $Archive::Tar::WARN = 0; 130 131 ### should be empty to begin with 132 is( $tar->error, '', "The error string is empty" ); 133 134 ### try a read on nothing 135 my @list = $tar->read(); 136 137 ok(!(scalar @list), "Function read returns 0 files on error" ); 138 ok( $tar->error, " error string is non empty" ); 139 like( $tar->error, qr/No file to read from/, 140 " error string from create()" ); 141 unlike( $tar->error, qr/add/, " error string does not contain add" ); 142 143 ### now, add empty data 144 my $obj = $tar->add_data( '' ); 145 146 ok( !$obj, "'add_data' returns undef on error" ); 147 ok( $tar->error, " error string is non empty" ); 148 like( $tar->error, qr/add/, " error string contains add" ); 149 unlike( $tar->error, qr/create/," error string does not contain create" ); 150 151 ### check if ->error eq $error 152 is( $tar->error, $Archive::Tar::error, 153 "Error '$Archive::Tar::error' matches $Class->error method" ); 154 155 ### check that 'contains_file' doesn't warn about missing files. 156 { ### turn on warnings in general! 157 local $Archive::Tar::WARN = 1; 158 159 my $warnings = ''; 160 local $SIG{__WARN__} = sub { $warnings .= "@_" }; 161 162 my $rv = $tar->contains_file( $$ ); 163 ok( !$rv, "Does not contain file '$$'" ); 164 is( $warnings, '', " No warnings issued during lookup" ); 165 } 166} 167 168my $ebcdic_skip_msg = "File contains an alien character set"; 169 170### read tests ### 171SKIP: { 172 my @to_try; 173 174 if (ord 'A' == 65) { 175 push @to_try, $TAR_FILE; 176 push @to_try, $TGZ_FILE if $Class->has_zlib_support; 177 push @to_try, $TBZ_FILE if $Class->has_bzip2_support; 178 push @to_try, $TXZ_FILE if $Class->has_xz_support; 179 } 180 else { 181 skip $ebcdic_skip_msg, 4; 182 } 183 184 for my $type( @to_try ) { 185 186 ### normal tar + gz compressed file 187 my $tar = $Class->new; 188 189 ### check we got the object 190 ok( $tar, "Object created" ); 191 isa_ok( $tar, $Class ); 192 193 ### ->read test 194 my @list = $tar->read( $type ); 195 my $cnt = scalar @list; 196 my $expect = scalar __PACKAGE__->get_expect(); 197 198 ok( $cnt, "Reading '$type' using 'read()'" ); 199 is( $cnt, $expect, " All files accounted for" ); 200 201 for my $file ( @list ) { 202 ok( $file, " Got File object" ); 203 isa_ok( $file, $FClass ); 204 205 ### whitebox test -- make sure find_entry gets the 206 ### right files 207 for my $test ( $file->full_path, $file ) { 208 is( $tar->_find_entry( $test ), $file, 209 " Found proper object" ); 210 } 211 212 next unless $file->is_file; 213 214 my $name = $file->full_path; 215 my($expect_name, $expect_content) = 216 get_expect_name_and_contents( $name, \@EXPECT_NORMAL ); 217 218 ### ->fullname! 219 ok($expect_name, " Found expected file '$name'" ); 220 221 like($tar->get_content($name), $expect_content, 222 " Content OK" ); 223 } 224 225 226 ### list_archive test 227 { my @list = $Class->list_archive( $type ); 228 my $cnt = scalar @list; 229 my $expect = scalar __PACKAGE__->get_expect(); 230 231 ok( $cnt, "Reading '$type' using 'list_archive'"); 232 is( $cnt, $expect, " All files accounted for" ); 233 234 for my $file ( @list ) { 235 next if __PACKAGE__->is_dir( $file ); # directories 236 237 my($expect_name, $expect_content) = 238 get_expect_name_and_contents( $file, \@EXPECT_NORMAL ); 239 240 ok( $expect_name, 241 " Found expected file '$file'" ); 242 } 243 } 244 } 245} 246 247### add files tests ### 248{ my @add = map { File::Spec->catfile( @ROOT, @$_ ) } ['b']; 249 my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b']; 250 my $tar = $Class->new; 251 252 ### check we got the object 253 ok( $tar, "Object created" ); 254 isa_ok( $tar, $Class ); 255 256 ### add the files 257 { my @files = $tar->add_files( @add ); 258 259 is( scalar @files, scalar @add, 260 " Adding files"); 261 is( $files[0]->name,'b', " Proper name" ); 262 263 SKIP: { 264 skip( "You are building perl using symlinks", 1) 265 if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/); 266 267 is( $files[0]->is_file, 1, 268 " Proper type" ); 269 } 270 271 like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/, 272 " Content OK" ); 273 274 ### check if we have then in our tar object 275 for my $file ( @addunix ) { 276 ok( $tar->contains_file($file), 277 " File found in archive" ); 278 } 279 } 280 281 ### check adding files doesn't conflict with a secondary archive 282 ### old A::T bug, we should keep testing for it 283 { my $tar2 = $Class->new; 284 my @added = $tar2->add_files( $COMPRESS_FILE ); 285 my @count = $tar2->list_files; 286 287 is( scalar @added, 1, " Added files to secondary archive" ); 288 is( scalar @added, scalar @count, 289 " No conflict with first archive" ); 290 291 ### check the adding of directories 292 my @add_dirs = File::Spec->catfile( @ROOT ); 293 my @dirs = $tar2->add_files( @add_dirs ); 294 is( scalar @dirs, scalar @add_dirs, 295 " Adding dirs"); 296 ok( $dirs[0]->is_dir, " Proper type" ); 297 } 298 299 ### check if we can add a A::T::File object 300 { my $tar2 = $Class->new; 301 my($added) = $tar2->add_files( $add[0] ); 302 303 ok( $added, " Added a file '$add[0]' to new object" ); 304 isa_ok( $added, $FClass, " Object" ); 305 306 my($added2) = $tar2->add_files( $added ); 307 ok( $added2, " Added an $FClass object" ); 308 isa_ok( $added2, $FClass, " Object" ); 309 310 is_deeply( [$added, $added2], [$tar2->get_files], 311 " All files accounted for" ); 312 isnt( $added, $added2, " Different memory allocations" ); 313 } 314} 315 316### add data tests ### 317{ 318 { ### standard data ### 319 my @to_add = ( 'a', 'aaaaa' ); 320 my $tar = $Class->new; 321 322 ### check we got the object 323 ok( $tar, "Object created" ); 324 isa_ok( $tar, $Class ); 325 326 ### add a new file item as data 327 my $obj = $tar->add_data( @to_add ); 328 329 ok( $obj, " Adding data" ); 330 is( $obj->name, $to_add[0], " Proper name" ); 331 is( $obj->is_file, 1, " Proper type" ); 332 like( $obj->get_content, qr/^$to_add[1]\s*$/, 333 " Content OK" ); 334 } 335 336 { ### binary data + 337 ### dir/file structure -- x/y always went ok, x/x used to extract 338 ### in the wrong way -- this test catches that 339 for my $list ( [$TARBIN, \@EXPECTBIN], 340 [$TARX, \@EXPECTX], 341 ) { 342 ### XXX GLOBAL! changes may affect other tests! 343 my($tar,$struct) = @$list; 344 345 for my $aref ( @$struct ) { 346 my ($dirs,$file,$data) = @$aref; 347 348 my $path = File::Spec::Unix->catfile( 349 grep { length } @$dirs, $file ); 350 351 my $obj = $tar->add_data( $path, $data ); 352 353 ok( $obj, " Adding data '$file'" ); 354 is( $obj->full_path, $path, 355 " Proper name" ); 356 ok( $obj->is_file, " Proper type" ); 357 is( $obj->get_content, $data, 358 " Content OK" ); 359 } 360 } 361 } 362} 363 364### rename/replace_content tests ### 365 366SKIP: { 367 skip $ebcdic_skip_msg, 9 if ord "A" != 65; 368 369 my $tar = $Class->new; 370 my $from = 'c'; 371 my $to = 'e'; 372 373 ### read in the file, check the proper files are there 374 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" ); 375 ok( $tar->get_files($from), " Found file '$from'" ); 376 { local $Archive::Tar::WARN = 0; 377 ok(!$tar->get_files($to), " File '$to' not yet found" ); 378 } 379 380 ### rename an entry, check the rename has happened 381 ok( $tar->rename( $from, $to ), " Renamed '$from' to '$to'" ); 382 ok( $tar->get_files($to), " File '$to' now found" ); 383 { local $Archive::Tar::WARN = 0; 384 ok(!$tar->get_files($from), " File '$from' no longer found'"); 385 } 386 387 ### now, replace the content 388 my($expect_name, $expect_content) = 389 get_expect_name_and_contents( $from, \@EXPECT_NORMAL ); 390 391 like( $tar->get_content($to), $expect_content, 392 "Original content of '$from' in '$to'" ); 393 ok( $tar->replace_content( $to, $from ), 394 " Set content for '$to' to '$from'" ); 395 is( $tar->get_content($to), $from, 396 " Content for '$to' is indeed '$from'" ); 397} 398 399### remove tests ### 400SKIP: { 401 skip $ebcdic_skip_msg, 3 if ord "A" != 65; 402 403 my $remove = 'c'; 404 my $tar = $Class->new; 405 406 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" ); 407 408 ### remove returns the files left, which should be equal to list_files 409 is( scalar($tar->remove($remove)), scalar($tar->list_files), 410 " Removing file '$remove'" ); 411 412 ### so what's left should be all expected files minus 1 413 is( scalar($tar->list_files), scalar(__PACKAGE__->get_expect) - 1, 414 " Proper files remaining" ); 415} 416 417### write + read + extract tests ### 418SKIP: { ### pesky warnings 419 skip $ebcdic_skip_msg, 326 if ord "A" != 65; 420 421 skip('no IO::String', 326) if !$Archive::Tar::HAS_PERLIO && 422 !$Archive::Tar::HAS_PERLIO && 423 !$Archive::Tar::HAS_IO_STRING && 424 !$Archive::Tar::HAS_IO_STRING; 425 426 my $tar = $Class->new; 427 my $new = $Class->new; 428 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" ); 429 430 for my $aref ( [$tar, \@EXPECT_NORMAL], 431 [$TARBIN, \@EXPECTBIN], 432 [$TARX, \@EXPECTX] 433 ) { 434 my($obj,$struct) = @$aref; 435 436 ### check if we stringify it ok 437 { my $string = $obj->write; 438 ok( $string, " Stringified tar file has size" ); 439 cmp_ok( length($string) % BLOCK, '==', 0, 440 " Tar archive stringified" ); 441 } 442 443 ### write tar tests 444 { my $out = $OUT_TAR_FILE; 445 446 ### bug #41798: 'Nonempty $\ when writing a TAR file produces a 447 ### corrupt TAR file' shows that setting $\ breaks writing tar files 448 ### set it here purposely so we can verify NOTHING breaks 449 local $\ = 'FOOBAR'; 450 451 { ### write() 452 ok( $obj->write($out), 453 " Wrote tarfile using 'write'" ); 454 check_tar_file( $out ); 455 check_tar_object( $obj, $struct ); 456 457 ### now read it in again 458 ok( $new->read( $out ), 459 " Read '$out' in again" ); 460 461 check_tar_object( $new, $struct ); 462 463 ### now extract it again 464 ok( $new->extract, " Extracted '$out' with 'extract'" ); 465 check_tar_extract( $new, $struct ); 466 467 rm( $out ) unless $NO_UNLINK; 468 } 469 470 471 { ### create_archive() 472 ok( $Class->create_archive( $out, 0, $COMPRESS_FILE ), 473 " Wrote tarfile using 'create_archive'" ); 474 check_tar_file( $out ); 475 476 ### now extract it again 477 ok( $Class->extract_archive( $out ), 478 " Extracted file using 'extract_archive'"); 479 rm( $out ) unless $NO_UNLINK; 480 } 481 } 482 483 ## write tgz tests 484 { my @out; 485 push @out, [ $OUT_TGZ_FILE => 1 ] if $Class->has_zlib_support; 486 push @out, [ $OUT_TBZ_FILE => COMPRESS_BZIP ] if $Class->has_bzip2_support; 487 push @out, [ $OUT_TXZ_FILE => COMPRESS_XZ ] if $Class->has_xz_support; 488 489 for my $entry ( @out ) { 490 491 my( $out, $compression ) = @$entry; 492 493 { ### write() 494 ok($obj->write($out, $compression), 495 " Writing compressed file '$out' using 'write'" ); 496 check_compressed_file( $out ); 497 498 check_tar_object( $obj, $struct ); 499 500 ### now read it in again 501 ok( $new->read( $out ), 502 " Read '$out' in again" ); 503 check_tar_object( $new, $struct ); 504 505 ### now extract it again 506 ok( $new->extract, 507 " Extracted '$out' again" ); 508 check_tar_extract( $new, $struct ); 509 510 rm( $out ) unless $NO_UNLINK; 511 } 512 513 { ### create_archive() 514 ok( $Class->create_archive( $out, $compression, $COMPRESS_FILE ), 515 " Wrote '$out' using 'create_archive'" ); 516 check_compressed_file( $out ); 517 518 ### now extract it again 519 ok( $Class->extract_archive( $out, $compression ), 520 " Extracted file using 'extract_archive'"); 521 rm( $out ) unless $NO_UNLINK; 522 } 523 } 524 } 525 } 526} 527 528 529### limited read + extract tests ### 530SKIP: { ### pesky warnings 531 skip $ebcdic_skip_msg, 8 if ord "A" != 65; 532 533 my $tar = $Class->new; 534 my @files = $tar->read( $TAR_FILE, 0, { limit => 1 } ); 535 my $obj = $files[0]; 536 537 is( scalar @files, 1, "Limited read" ); 538 539 my ($name,$content) = get_expect_name_and_contents( 540 $obj->full_path, \@EXPECT_NORMAL ); 541 542 is( $obj->name, $name, " Expected file found" ); 543 544 545 ### extract this single file to cwd() 546 for my $meth (qw[extract extract_file]) { 547 548 ### extract it by full path and object 549 for my $arg ( $obj, $obj->full_path ) { 550 551 ok( $tar->$meth( $arg ), 552 " Extract '$name' to cwd() with $meth" ); 553 ok( -e $obj->full_path, " Extracted file exists" ); 554 rm( $obj->full_path ) unless $NO_UNLINK; 555 } 556 } 557 558 ### extract this file to @ROOT 559 ### can only do that with 'extract_file', not with 'extract' 560 for my $meth (qw[extract_file]) { 561 my $outpath = File::Spec->catdir( @ROOT ); 562 my $outfile = File::Spec->catfile( $outpath, $$ ); #$obj->full_path ); 563 564 ok( $tar->$meth( $obj->full_path, $outfile ), 565 " Extract file '$name' to $outpath with $meth" ); 566 ok( -e $outfile, " Extracted file '$outfile' exists" ); 567 rm( $outfile ) unless $NO_UNLINK; 568 } 569 570} 571 572 573### clear tests ### 574SKIP: { ### pesky warnings 575 skip $ebcdic_skip_msg, 3 if ord "A" != 65; 576 577 my $tar = $Class->new; 578 my @files = $tar->read( $TAR_FILE ); 579 580 my $cnt = $tar->list_files(); 581 ok( $cnt, "Found old data" ); 582 ok( $tar->clear, " Clearing old data" ); 583 584 my $new_cnt = $tar->list_files; 585 ok( !$new_cnt, " Old data cleared" ); 586} 587 588### $DO_NOT_USE_PREFIX tests 589{ my $tar = $Class->new; 590 591 592 ### first write a tar file without prefix 593 { my ($obj) = $tar->add_files( $COMPRESS_FILE ); 594 my $dir = ''; # dir is empty! 595 my $file = File::Basename::basename( $COMPRESS_FILE ); 596 597 ok( $obj, "File added" ); 598 isa_ok( $obj, $FClass ); 599 600 ### internal storage ### 601 is( $obj->name, $file, " Name set to '$file'" ); 602 is( $obj->prefix, $dir, " Prefix set to '$dir'" ); 603 604 ### write the tar file without a prefix in it 605 ### pesky warnings 606 local $Archive::Tar::DO_NOT_USE_PREFIX = 1; 607 local $Archive::Tar::DO_NOT_USE_PREFIX = 1; 608 609 ok( $tar->write( $OUT_TAR_FILE ), 610 " Tar file written" ); 611 612 ### and forget all about it... 613 $tar->clear; 614 } 615 616 ### now read it back in, there should be no prefix 617 { ok( $tar->read( $OUT_TAR_FILE ), 618 " Tar file read in again" ); 619 620 my ($obj) = $tar->get_files; 621 ok( $obj, " File retrieved" ); 622 isa_ok( $obj, $FClass, " Object" ); 623 624 is( $obj->name, $COMPRESS_FILE, 625 " Name now set to '$COMPRESS_FILE'" ); 626 is( $obj->prefix, '', " Prefix now empty" ); 627 628 my $re = quotemeta $COMPRESS_FILE; 629 like( $obj->raw, qr/^$re/, " Prefix + name in name slot of header" ); 630 } 631 632 rm( $OUT_TAR_FILE ) unless $NO_UNLINK; 633} 634 635### clean up stuff 636END { 637 for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) { 638 for my $aref (@$struct) { 639 640 my $dir = $aref->[0]->[0]; 641 rmtree $dir if $dir && -d $dir && not $NO_UNLINK; 642 } 643 } 644 645 my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE ); 646 rmtree $dir if $dir && -d $dir && not $NO_UNLINK; 647 1 while unlink $COMPRESS_FILE; 648} 649 650########################### 651### helper subs ### 652########################### 653sub get_expect { 654 return map { 655 split '/', $_ 656 } map { 657 File::Spec::Unix->catfile( 658 grep { defined } @{$_->[0]}, $_->[1] 659 ) 660 } @EXPECT_NORMAL; 661} 662 663sub is_dir { 664 my $file = pop(); 665 return $file =~ m|/$| ? 1 : 0; 666} 667 668sub rm { 669 my $x = shift; 670 if ( is_dir($x) ) { 671 rmtree($x); 672 } else { 673 1 while unlink $x; 674 } 675} 676 677sub check_tar_file { 678 my $file = shift; 679 my $filesize = -s $file; 680 my $contents = slurp_binfile( $file ); 681 682 ok( defined( $contents ), " File read" ); 683 ok( $filesize, " File written size=$filesize" ); 684 685 cmp_ok( $filesize % BLOCK, '==', 0, 686 " File size is a multiple of 512" ); 687 688 cmp_ok( length($contents), '==', $filesize, 689 " File contents match size" ); 690 691 is( TAR_END x 2, substr( $contents, -(BLOCK*2) ), 692 " Ends with 1024 null bytes" ); 693 694 return $contents; 695} 696 697sub check_compressed_file { 698 my $file = shift; 699 my $filesize = -s $file; 700 my $contents = slurp_compressed_file( $file ); 701 my $uncompressedsize = length $contents; 702 703 ok( defined( $contents ), " File read and uncompressed" ); 704 ok( $filesize, " File written size=$filesize uncompressed size=$uncompressedsize" ); 705 706 cmp_ok( $uncompressedsize % BLOCK, '==', 0, 707 " Uncompressed size is a multiple of 512" ); 708 709 is( TAR_END x 2, substr($contents, -(BLOCK*2)), 710 " Ends with 1024 null bytes" ); 711 712 cmp_ok( $filesize, '<', $uncompressedsize, 713 " Compressed size < uncompressed size" ); 714 715 return $contents; 716} 717 718sub check_tar_object { 719 my $obj = shift; 720 my $struct = shift or return; 721 722 ### amount of files (not dirs!) there should be in the object 723 my $expect = scalar @$struct; 724 my @files = grep { $_->is_file } $obj->get_files; 725 726 ### count how many files there are in the object 727 ok( scalar @files, " Found some files in the archive" ); 728 is( scalar @files, $expect, " Found expected number of files" ); 729 730 for my $file (@files) { 731 732 ### XXX ->fullname 733 #my $path = File::Spec::Unix->catfile( 734 # grep { length } $file->prefix, $file->name ); 735 my($ename,$econtent) = 736 get_expect_name_and_contents( $file->full_path, $struct ); 737 738 ok( $file->is_file, " It is a file" ); 739 is( $file->full_path, $ename, 740 " Name matches expected name" ); 741 like( $file->get_content, $econtent, 742 " Content as expected" ); 743 } 744} 745 746sub check_tar_extract { 747 my $tar = shift; 748 my $struct = shift; 749 750 my @dirs; 751 for my $file ($tar->get_files) { 752 push @dirs, $file && next if $file->is_dir; 753 754 755 my $path = $file->full_path; 756 my($ename,$econtent) = 757 get_expect_name_and_contents( $path, $struct ); 758 759 760 is( $ename, $path, " Expected file found" ); 761 ok( -e $path, " File '$path' exists" ); 762 763 my $fh; 764 open $fh, "$path" or warn "Error opening file '$path': $!\n"; 765 binmode $fh; 766 767 ok( $fh, " Opening file" ); 768 769 my $content = do{local $/;<$fh>}; chomp $content; 770 like( $content, qr/$econtent/, 771 " Contents OK" ); 772 773 close $fh; 774 $NO_UNLINK or 1 while unlink $path; 775 776 ### alternate extract path tests 777 ### to abs and rel paths 778 { for my $outpath ( File::Spec->catdir( @ROOT ), 779 File::Spec->rel2abs( 780 File::Spec->catdir( @ROOT ) 781 ) 782 ) { 783 784 my $outfile = File::Spec->catfile( $outpath, $$ ); 785 786 ok( $tar->extract_file( $file->full_path, $outfile ), 787 " Extracted file '$path' to $outfile" ); 788 ok( -e $outfile," Extracted file '$outfile' exists" ); 789 790 rm( $outfile ) unless $NO_UNLINK; 791 } 792 } 793 } 794 795 ### now check if list_files is returning the same info as get_files 796 is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files], 797 " Verified via list_files as well" ); 798 799 #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK } 800 # for @dirs; 801} 802 803sub slurp_binfile { 804 my $file = shift; 805 my $fh = IO::File->new; 806 807 $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef; 808 809 binmode $fh; 810 local $/; 811 return <$fh>; 812} 813 814sub slurp_compressed_file { 815 my $file = shift; 816 my $fh; 817 818 ### xz 819 if( $file =~ /.txz$/ ) { 820 require IO::Uncompress::UnXz; 821 $fh = IO::Uncompress::UnXz->new( $file ) 822 or warn( "Error opening '$file' with IO::Uncompress::UnXz" ), return 823 824 ### bzip2 825 } elsif( $file =~ /.tbz$/ ) { 826 require IO::Uncompress::Bunzip2; 827 $fh = IO::Uncompress::Bunzip2->new( $file ) 828 or warn( "Error opening '$file' with IO::Uncompress::Bunzip2" ), return 829 830 ### gzip 831 } else { 832 require IO::Zlib; 833 $fh = IO::Zlib->new(); 834 $fh->open( $file, READ_ONLY->(1) ) 835 or warn( "Error opening '$file' with IO::Zlib" ), return 836 } 837 838 my $str; 839 my $buff; 840 $str .= $buff while $fh->read( $buff, 4096 ) > 0; 841 $fh->close(); 842 843 return $str; 844} 845 846sub get_expect_name_and_contents { 847 my $find = shift; 848 my $struct = shift or return; 849 850 ### find the proper name + contents for this file from 851 ### the expect structure 852 my ($name, $content) = 853 map { 854 @$_; 855 } grep { 856 $_->[0] eq $find 857 } map { 858 [ ### full path ### 859 File::Spec::Unix->catfile( 860 grep { length } @{$_->[0]}, $_->[1] 861 ), 862 ### regex 863 $_->[2], 864 ] 865 } @$struct; 866 867 ### not a qr// yet? 868 unless( ref $content ) { 869 my $x = quotemeta ($content || ''); 870 $content = qr/$x/; 871 } 872 873 unless( $name ) { 874 warn "Could not find '$find' in " . Dumper $struct; 875 } 876 877 return ($name, $content); 878} 879 880__END__ 881