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