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