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### extract tests with different $EXTRACT_BLOCK_SIZE values ### 574SKIP: { ### pesky warnings 575 skip $ebcdic_skip_msg, 431 if ord "A" != 65; 576 577 skip('no IO::String', 431) if !$Archive::Tar::HAS_PERLIO && 578 !$Archive::Tar::HAS_PERLIO && 579 !$Archive::Tar::HAS_IO_STRING && 580 !$Archive::Tar::HAS_IO_STRING; 581 582 my $tar = $Class->new; 583 ok( $tar->read( $TAR_FILE ), "Read in '$TAR_FILE'" ); 584 585 for my $aref ( [$tar, \@EXPECT_NORMAL], 586 [$TARBIN, \@EXPECTBIN], 587 [$TARX, \@EXPECTX] 588 ) { 589 my($obj, $struct) = @$aref; 590 591 for my $block_size ((1, BLOCK, 1024 * 1024, 2**31 - 4096, 2**31 - 1)) { 592 local $Archive::Tar::EXTRACT_BLOCK_SIZE = $block_size; 593 594 ok( $obj->extract, " Extracted with 'extract'" ); 595 check_tar_extract( $obj, $struct ); 596 } 597 } 598} 599 600 601### clear tests ### 602SKIP: { ### pesky warnings 603 skip $ebcdic_skip_msg, 3 if ord "A" != 65; 604 605 my $tar = $Class->new; 606 my @files = $tar->read( $TAR_FILE ); 607 608 my $cnt = $tar->list_files(); 609 ok( $cnt, "Found old data" ); 610 ok( $tar->clear, " Clearing old data" ); 611 612 my $new_cnt = $tar->list_files; 613 ok( !$new_cnt, " Old data cleared" ); 614} 615 616### $DO_NOT_USE_PREFIX tests 617{ my $tar = $Class->new; 618 619 620 ### first write a tar file without prefix 621 { my ($obj) = $tar->add_files( $COMPRESS_FILE ); 622 my $dir = ''; # dir is empty! 623 my $file = File::Basename::basename( $COMPRESS_FILE ); 624 625 ok( $obj, "File added" ); 626 isa_ok( $obj, $FClass ); 627 628 ### internal storage ### 629 is( $obj->name, $file, " Name set to '$file'" ); 630 is( $obj->prefix, $dir, " Prefix set to '$dir'" ); 631 632 ### write the tar file without a prefix in it 633 ### pesky warnings 634 local $Archive::Tar::DO_NOT_USE_PREFIX = 1; 635 local $Archive::Tar::DO_NOT_USE_PREFIX = 1; 636 637 ok( $tar->write( $OUT_TAR_FILE ), 638 " Tar file written" ); 639 640 ### and forget all about it... 641 $tar->clear; 642 } 643 644 ### now read it back in, there should be no prefix 645 { ok( $tar->read( $OUT_TAR_FILE ), 646 " Tar file read in again" ); 647 648 my ($obj) = $tar->get_files; 649 ok( $obj, " File retrieved" ); 650 isa_ok( $obj, $FClass, " Object" ); 651 652 is( $obj->name, $COMPRESS_FILE, 653 " Name now set to '$COMPRESS_FILE'" ); 654 is( $obj->prefix, '', " Prefix now empty" ); 655 656 my $re = quotemeta $COMPRESS_FILE; 657 like( $obj->raw, qr/^$re/, " Prefix + name in name slot of header" ); 658 } 659 660 rm( $OUT_TAR_FILE ) unless $NO_UNLINK; 661} 662 663### clean up stuff 664END { 665 for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) { 666 for my $aref (@$struct) { 667 668 my $dir = $aref->[0]->[0]; 669 rmtree $dir if $dir && -d $dir && not $NO_UNLINK; 670 } 671 } 672 673 my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE ); 674 rmtree $dir if $dir && -d $dir && not $NO_UNLINK; 675 1 while unlink $COMPRESS_FILE; 676} 677 678########################### 679### helper subs ### 680########################### 681sub get_expect { 682 return map { 683 split '/', $_ 684 } map { 685 File::Spec::Unix->catfile( 686 grep { defined } @{$_->[0]}, $_->[1] 687 ) 688 } @EXPECT_NORMAL; 689} 690 691sub is_dir { 692 my $file = pop(); 693 return $file =~ m|/$| ? 1 : 0; 694} 695 696sub rm { 697 my $x = shift; 698 if ( is_dir($x) ) { 699 rmtree($x); 700 } else { 701 1 while unlink $x; 702 } 703} 704 705sub check_tar_file { 706 my $file = shift; 707 my $filesize = -s $file; 708 my $contents = slurp_binfile( $file ); 709 710 ok( defined( $contents ), " File read" ); 711 ok( $filesize, " File written size=$filesize" ); 712 713 cmp_ok( $filesize % BLOCK, '==', 0, 714 " File size is a multiple of 512" ); 715 716 cmp_ok( length($contents), '==', $filesize, 717 " File contents match size" ); 718 719 is( TAR_END x 2, substr( $contents, -(BLOCK*2) ), 720 " Ends with 1024 null bytes" ); 721 722 return $contents; 723} 724 725sub check_compressed_file { 726 my $file = shift; 727 my $filesize = -s $file; 728 my $contents = slurp_compressed_file( $file ); 729 my $uncompressedsize = length $contents; 730 731 ok( defined( $contents ), " File read and uncompressed" ); 732 ok( $filesize, " File written size=$filesize uncompressed size=$uncompressedsize" ); 733 734 cmp_ok( $uncompressedsize % BLOCK, '==', 0, 735 " Uncompressed size is a multiple of 512" ); 736 737 is( TAR_END x 2, substr($contents, -(BLOCK*2)), 738 " Ends with 1024 null bytes" ); 739 740 cmp_ok( $filesize, '<', $uncompressedsize, 741 " Compressed size < uncompressed size" ); 742 743 return $contents; 744} 745 746sub check_tar_object { 747 my $obj = shift; 748 my $struct = shift or return; 749 750 ### amount of files (not dirs!) there should be in the object 751 my $expect = scalar @$struct; 752 my @files = grep { $_->is_file } $obj->get_files; 753 754 ### count how many files there are in the object 755 ok( scalar @files, " Found some files in the archive" ); 756 is( scalar @files, $expect, " Found expected number of files" ); 757 758 for my $file (@files) { 759 760 ### XXX ->fullname 761 #my $path = File::Spec::Unix->catfile( 762 # grep { length } $file->prefix, $file->name ); 763 my($ename,$econtent) = 764 get_expect_name_and_contents( $file->full_path, $struct ); 765 766 ok( $file->is_file, " It is a file" ); 767 is( $file->full_path, $ename, 768 " Name matches expected name" ); 769 like( $file->get_content, $econtent, 770 " Content as expected" ); 771 } 772} 773 774sub check_tar_extract { 775 my $tar = shift; 776 my $struct = shift; 777 778 my @dirs; 779 for my $file ($tar->get_files) { 780 push @dirs, $file && next if $file->is_dir; 781 782 783 my $path = $file->full_path; 784 my($ename,$econtent) = 785 get_expect_name_and_contents( $path, $struct ); 786 787 788 is( $ename, $path, " Expected file found" ); 789 ok( -e $path, " File '$path' exists" ); 790 791 my $fh; 792 open $fh, "$path" or warn "Error opening file '$path': $!\n"; 793 binmode $fh; 794 795 ok( $fh, " Opening file" ); 796 797 my $content = do{local $/;<$fh>}; chomp $content; 798 like( $content, qr/$econtent/, 799 " Contents OK" ); 800 801 close $fh; 802 $NO_UNLINK or 1 while unlink $path; 803 804 ### alternate extract path tests 805 ### to abs and rel paths 806 { for my $outpath ( File::Spec->catdir( @ROOT ), 807 File::Spec->rel2abs( 808 File::Spec->catdir( @ROOT ) 809 ) 810 ) { 811 812 my $outfile = File::Spec->catfile( $outpath, $$ ); 813 814 ok( $tar->extract_file( $file->full_path, $outfile ), 815 " Extracted file '$path' to $outfile" ); 816 ok( -e $outfile," Extracted file '$outfile' exists" ); 817 818 rm( $outfile ) unless $NO_UNLINK; 819 } 820 } 821 } 822 823 ### now check if list_files is returning the same info as get_files 824 is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files], 825 " Verified via list_files as well" ); 826 827 #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK } 828 # for @dirs; 829} 830 831sub slurp_binfile { 832 my $file = shift; 833 my $fh = IO::File->new; 834 835 $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef; 836 837 binmode $fh; 838 local $/; 839 return <$fh>; 840} 841 842sub slurp_compressed_file { 843 my $file = shift; 844 my $fh; 845 846 ### xz 847 if( $file =~ /.txz$/ ) { 848 require IO::Uncompress::UnXz; 849 $fh = IO::Uncompress::UnXz->new( $file ) 850 or warn( "Error opening '$file' with IO::Uncompress::UnXz" ), return 851 852 ### bzip2 853 } elsif( $file =~ /.tbz$/ ) { 854 require IO::Uncompress::Bunzip2; 855 $fh = IO::Uncompress::Bunzip2->new( $file ) 856 or warn( "Error opening '$file' with IO::Uncompress::Bunzip2" ), return 857 858 ### gzip 859 } else { 860 require IO::Zlib; 861 $fh = IO::Zlib->new(); 862 $fh->open( $file, READ_ONLY->(1) ) 863 or warn( "Error opening '$file' with IO::Zlib" ), return 864 } 865 866 my $str; 867 my $buff; 868 $str .= $buff while $fh->read( $buff, 4096 ) > 0; 869 $fh->close(); 870 871 return $str; 872} 873 874sub get_expect_name_and_contents { 875 my $find = shift; 876 my $struct = shift or return; 877 878 ### find the proper name + contents for this file from 879 ### the expect structure 880 my ($name, $content) = 881 map { 882 @$_; 883 } grep { 884 $_->[0] eq $find 885 } map { 886 [ ### full path ### 887 File::Spec::Unix->catfile( 888 grep { length } @{$_->[0]}, $_->[1] 889 ), 890 ### regex 891 $_->[2], 892 ] 893 } @$struct; 894 895 ### not a qr// yet? 896 unless( ref $content ) { 897 my $x = quotemeta ($content || ''); 898 $content = qr/$x/; 899 } 900 901 unless( $name ) { 902 warn "Could not find '$find' in " . Dumper $struct; 903 } 904 905 return ($name, $content); 906} 907 908__END__ 909