02_methods.t

source of perl for linux application,

                ### now read it in again
                ok( $new->read( $out ),
                                    "Read '$out' in again" );

                check_tar_object( $new, $struct );

                ### now extract it again
                ok( $new->extract,  "Extracted '$out' with 'extract'" );
                check_tar_extract( $new, $struct );

                rm( $out ) unless $NO_UNLINK;
            }


            {   ### create_archive()
                ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
                                    "Wrote tarfile using 'create_archive'" );
                check_tar_file( $out );

                ### now extract it again
                ok( Archive::Tar->extract_archive( $out ),
                                    "Extracted file using 'extract_archive'");
                rm( $out ) unless $NO_UNLINK;
            }
        }

        ## write tgz tests
        {   my $out = $OUT_TGZ_FILE;

            SKIP: {

                ### weird errors from scalar(@x,@y,@z), dot it this way...
                my $file_cnt;
                map { $file_cnt += scalar @$_ } \@EXPECT_NORMAL, \@EXPECTBIN,
                                                \@EXPECTX;

                my $cnt =   5 +                 # the tests below
                            (5*3*2) +           # check_tgz_file
                                                # check_tar_object fixed tests
                            (3 * 2 * (2 + $file_cnt)) +
                            ((4*$file_cnt) + 1);# check_tar_extract tests

                skip( "No IO::Zlib - cannot write compressed archives", $cnt )
                    unless $ZLIB;

                {   ### write()
                    ok($obj->write($out, 1),
                                    "Writing compressed file using 'write'" );
                    check_tgz_file( $out );
                    check_tar_object( $obj, $struct );

                    ### now read it in again
                    ok( $new->read( $out ),
                                    "Read '$out' in again" );
                    check_tar_object( $new, $struct );

                    ### now extract it again
                    ok( $new->extract,
                                    "Extracted '$out' again" );
                    check_tar_extract( $new, $struct );

                    rm( $out ) unless $NO_UNLINK;
                }

                {   ### create_archive()
                    ok( Archive::Tar->create_archive( $out, 1, $COMPRESS_FILE ),
                                    "Wrote gzip file using 'create_archive'" );
                    check_tgz_file( $out );

                    ### now extract it again
                    ok( Archive::Tar->extract_archive( $out, 1 ),
                                    "Extracted file using 'extract_archive'");
                    rm( $out ) unless $NO_UNLINK;
                }
            }
        }
    }
}


### limited read + extract tests ###
{   my $tar     = Archive::Tar->new;
    my @files   = $tar->read( $TAR_FILE, 0, { limit => 1 } );
    my $obj     = $files[0];

    is( scalar @files, 1,           "Limited read" );

    my ($name,$content) = get_expect_name_and_contents(
                                $obj->full_path, \@EXPECT_NORMAL );

    is( $obj->name, $name,          "   Expected file found" );


    ### extract this single file to cwd()
    for my $meth (qw[extract extract_file]) {

        ### extract it by full path and object
        for my $arg ( $obj, $obj->full_path ) {

            ok( $tar->$meth( $arg ),
                                    "Extracted '$name' to cwd() with $meth" );
            ok( -e $obj->full_path, "   Extracted file exists" );
            rm( $obj->full_path ) unless $NO_UNLINK;
        }
    }

    ### extract this file to @ROOT
    ### can only do that with 'extract_file', not with 'extract'
    for my $meth (qw[extract_file]) {
        my $outpath = File::Spec->catdir( @ROOT );
        my $outfile = File::Spec->catfile( $outpath, $$ ); #$obj->full_path );

        ok( $tar->$meth( $obj->full_path, $outfile ),
                                    "Extracted file '$name' to $outpath with $meth" );
        ok( -e $outfile,            "   Extracted file '$outfile' exists" );
        rm( $outfile ) unless $NO_UNLINK;
    }

}


### clear tests ###
{   my $tar     = Archive::Tar->new;
    my @files   = $tar->read( $TAR_FILE );

    my $cnt = $tar->list_files();
    ok( $cnt,                       "Found old data" );
    ok( $tar->clear,                "   Clearing old data" );

    my $new_cnt = $tar->list_files;
    ok( !$new_cnt,                  "   Old data cleared" );
}

### $DO_NOT_USE_PREFIX tests
{   my $tar     = Archive::Tar->new;


    ### first write a tar file without prefix
    {   my ($obj)   = $tar->add_files( $COMPRESS_FILE );
        my $dir     = '';   # dir is empty!
        my $file    = File::Basename::basename( $COMPRESS_FILE );

        ok( $obj,                   "File added" );
        isa_ok( $obj,               "Archive::Tar::File" );

        ### internal storage ###
        is( $obj->name, $file,      "   Name set to '$file'" );
        is( $obj->prefix, $dir,     "   Prefix set to '$dir'" );

        ### write the tar file without a prefix in it
        local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
        ok( $tar->write( $OUT_TAR_FILE ),
                                    "   Tar file written" );

        ### and forget all about it...
        $tar->clear;
    }

    ### now read it back in, there should be no prefix
    {   ok( $tar->read( $OUT_TAR_FILE ),
                                    "Tar file read in again" );

        my ($obj) = $tar->get_files;
        ok( $obj,                   "   File retrieved" );
        isa_ok( $obj,               "Archive::Tar::File" );

        is( $obj->name, $COMPRESS_FILE,
                                    "   Name now set to '$COMPRESS_FILE'" );
        is( $obj->prefix, '',       "   Prefix now empty" );

        my $re = quotemeta $COMPRESS_FILE;
        like( $obj->raw, qr/^$re/,  "   Prefix + name in name slot of header" );
    }

    rm( $OUT_TAR_FILE ) unless $NO_UNLINK;
}

### clean up stuff
END {
    for my $struct ( \@EXPECT_NORMAL, \@EXPECTBIN, \@EXPECTX ) {
        for my $aref (@$struct) {

            my $dir = $aref->[0]->[0];
            rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
        }
    }

    my ($dir) = File::Spec::Unix->splitdir( $LONG_FILE );
    rmtree $dir if $dir && -d $dir && not $NO_UNLINK;
    1 while unlink $COMPRESS_FILE;
}

###########################
###     helper subs     ###
###########################
sub get_expect {
    return  map {
                split '/', $_
            } map {
                File::Spec::Unix->catfile(
                    grep { defined } @{$_->[0]}, $_->[1]
                )
            } @EXPECT_NORMAL;
}

sub is_dir {
    my $file = pop();
    return $file =~ m|/$| ? 1 : 0;
}

sub rm {
    my $x = shift;
    if  ( is_dir($x) ) {
         rmtree($x);
    } else {
         1 while unlink $x;
    }
}

sub check_tar_file {
    my $file        = shift;
    my $filesize    = -s $file;
    my $contents    = slurp_binfile( $file );

    ok( defined( $contents ),   "   File read" );
    ok( $filesize,              "   File written size=$filesize" );

    cmp_ok( $filesize % BLOCK,     '==', 0,
                        "   File size is a multiple of 512" );

    cmp_ok( length($contents), '==', $filesize,
                        "   File contents match size" );

    is( TAR_END x 2, substr( $contents, -(BLOCK*2) ),
                        "   Ends with 1024 null bytes" );

    return $contents;
}

sub check_tgz_file {
    my $file                = shift;
    my $filesize            = -s $file;
    my $contents            = slurp_gzfile( $file );
    my $uncompressedsize    = length $contents;

    ok( defined( $contents ),   "   File read and uncompressed" );
    ok( $filesize,              "   File written size=$filesize uncompressed size=$uncompressedsize" );

    cmp_ok( $uncompressedsize % BLOCK, '==', 0,
                                "   Uncompressed size is a multiple of 512" );

    is( TAR_END x 2, substr($contents, -(BLOCK*2)),
                                "   Ends with 1024 null bytes" );

    cmp_ok( $filesize, '<',  $uncompressedsize,
                                "   Compressed size < uncompressed size" );

    return $contents;
}

sub check_tar_object {
    my $obj     = shift;
    my $struct  = shift or return;

    ### amount of files (not dirs!) there should be in the object
    my $expect  = scalar @$struct;
    my @files   = grep { $_->is_file } $obj->get_files;

    ### count how many files there are in the object
    ok( scalar @files,          "   Found some files in the archive" );
    is( scalar @files, $expect, "   Found expected number of files" );

    for my $file (@files) {

        ### XXX ->fullname
        #my $path = File::Spec::Unix->catfile(
        #            grep { length } $file->prefix, $file->name );
        my($ename,$econtent) =
            get_expect_name_and_contents( $file->full_path, $struct );

        ok( $file->is_file,     "   It is a file" );
        is( $file->full_path, $ename,
                                "   Name matches expected name" );
        like( $file->get_content, $econtent,
                                "   Content as expected" );
    }
}

sub check_tar_extract {
    my $tar     = shift;
    my $struct  = shift;

    my @dirs;
    for my $file ($tar->get_files) {
        push @dirs, $file && next if $file->is_dir;


        my $path = $file->full_path;
        my($ename,$econtent) =
            get_expect_name_and_contents( $path, $struct );


        is( $ename, $path,          "   Expected file found" );
        ok( -e $path,               "   File '$path' exists" );

        my $fh;
        open $fh, "$path" or warn "Error opening file '$path': $!\n";
        binmode $fh;

        ok( $fh,                    "   Opening file" );

        my $content = do{local $/;<$fh>}; chomp $content;
        like( $content, qr/$econtent/,
                                    "   Contents OK" );

        close $fh;
        $NO_UNLINK or 1 while unlink $path;

        ### alternate extract path tests 
        ### to abs and rel paths
        {   for my $outpath (   File::Spec->catdir( @ROOT ),
                                File::Spec->rel2abs( 
                                    File::Spec->catdir( @ROOT )
                                )
            ) {

                my $outfile = File::Spec->catfile( $outpath, $$ );
    
                ok( $tar->extract_file( $file->full_path, $outfile ),
                                "   Extracted file '$path' to $outfile" );
                ok( -e $outfile,"   Extracted file '$outfile' exists" );
    
                rm( $outfile ) unless $NO_UNLINK;
            }            
        }
    }

    ### now check if list_files is returning the same info as get_files
    is_deeply( [$tar->list_files], [ map { $_->full_path } $tar->get_files],
                                    "   Verified via list_files as well" );

    #do { rmtree $_->full_path if -d $_->full_path && not $NO_UNLINK }
    #    for @dirs;
}

sub slurp_binfile {
    my $file    = shift;
    my $fh      = IO::File->new;

    $fh->open( $file ) or warn( "Error opening '$file': $!" ), return undef;

    binmode $fh;
    local $/;
    return <$fh>;
}

sub slurp_gzfile {
    my $file = shift;
    my $str;
    my $buff;

    require IO::Zlib;
    my $fh = new IO::Zlib;
    $fh->open( $file, READ_ONLY->(1) )
        or warn( "Error opening '$file' with IO::Zlib" ), return undef;

    $str .= $buff while $fh->read( $buff, 4096 ) > 0;
    $fh->close();
    return $str;
}

sub get_expect_name_and_contents {
    my $find    = shift;
    my $struct  = shift or return;

    ### find the proper name + contents for this file from
    ### the expect structure
    my ($name, $content) =
        map {
            @$_;
        } grep {
            $_->[0] eq $find
        } map {
            [   ### full path ###
                File::Spec::Unix->catfile(
                    grep { length } @{$_->[0]}, $_->[1]
                ),
                ### regex
                $_->[2],
            ]
        } @$struct;

    ### not a qr// yet?
    unless( ref $content ) {
        my $x     = quotemeta ($content || '');
        $content = qr/$x/;
    }

    unless( $name ) {
        warn "Could not find '$find' in " . Dumper $struct;
    }

    return ($name, $content);
}

__END__