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