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