"Fossies" - the Fresh Open Source Software Archive

Member "Archive-Tar-2.38/t/02_methods.t" (25 Jun 2020, 28300 Bytes) of package /linux/privat/Archive-Tar-2.38.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "02_methods.t": 2.36_vs_2.38.

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