lib/Archive/Tar/t/02_methods.t

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