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