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