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