02_methods.t

source of perl for linux application,

BEGIN {
    if( $ENV{PERL_CORE} ) {
        chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
    }       
    use lib '../../..';
}

BEGIN { chdir 't' if -d 't' }

use Test::More 'no_plan';
use strict;
use lib '../lib';

use Cwd;
use Config;
use IO::File;
use File::Copy;
use File::Path;
use File::Spec          ();
use File::Spec::Unix    ();
use File::Basename      ();
use Data::Dumper;

use Archive::Tar;
use Archive::Tar::Constant;

### XXX TODO:
### * change to fullname
### * add tests for global variables

### set up the environment ###
my @EXPECT_NORMAL = (
    ### dirs        filename    contents
    [   [],         'c',        qr/^iiiiiiiiiiii\s*$/ ],
    [   [],         'd',        qr/^uuuuuuuu\s*$/ ],
);

### includes binary data
my $ALL_CHARS = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";

### @EXPECTBIN is used to ensure that $tarbin is written in the right
### order and that the contents and order match exactly when extracted
my @EXPECTBIN = (
    ###  dirs   filename      contents       ###
    [    [],    'bIn11',      $ALL_CHARS x 11 ],
    [    [],    'bIn3',       $ALL_CHARS x  3 ],
    [    [],    'bIn4',       $ALL_CHARS x  4 ],
    [    [],    'bIn1',       $ALL_CHARS      ],
    [    [],    'bIn2',       $ALL_CHARS x  2 ],
);

### @EXPECTX is used to ensure that $tarx is written in the right
### order and that the contents and order match exactly when extracted
### the 'x/x' extraction used to fail before A::T 1.08
my @EXPECTX = (
    ###  dirs       filename    contents
    [    [ 'x' ],   'k',        '',     ],
    [    [ 'x' ],   'x',        'j',    ],   # failed before A::T 1.08
);

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];

### wintendo can't deal with too long paths, so we might have to skip tests ###
my $TOO_LONG    =   ($^O eq 'MSWin32' or $^O eq 'cygwin' or $^O eq 'VMS')
                    && length( cwd(). $LONG_FILE ) > 247;

### warn if we are going to skip long file names
if ($TOO_LONG) {
    diag("No long filename support - long filename extraction disabled") if ! $ENV{PERL_CORE};
} else {
    push @EXPECT_NORMAL, [ [], $LONG_FILE, qr/^hello\s*$/];
}

my @ROOT        = grep { length }   'src', $TOO_LONG ? 'short' : 'long';

my $ZLIB        = eval { require IO::Zlib; 1 } ? 1 : 0;
my $NO_UNLINK   = $ARGV[0] ? 1 : 0;

### enable debugging?
$Archive::Tar::DEBUG = 1 if $ARGV[1];

### tests for binary and x/x files
my $TARBIN      = Archive::Tar->new;
my $TARX        = Archive::Tar->new;

### paths to a .tar and .tgz file to use for tests
my $TAR_FILE        = File::Spec->catfile( @ROOT, 'bar.tar' );
my $TGZ_FILE        = File::Spec->catfile( @ROOT, 'foo.tgz' );
my $OUT_TAR_FILE    = File::Spec->catfile( @ROOT, 'out.tar' );
my $OUT_TGZ_FILE    = File::Spec->catfile( @ROOT, 'out.tgz' );

my $COMPRESS_FILE = 'copy';
$^O eq 'VMS' and $COMPRESS_FILE .= '.';
copy( File::Basename::basename($0), $COMPRESS_FILE );
chmod 0644, $COMPRESS_FILE;

### done setting up environment ###


### did we probe IO::Zlib support ok? ###
{   is( Archive::Tar->can_handle_compressed_files, $ZLIB,
                                    "Proper IO::Zlib support detected" );
}


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

    ok( $tar,                       "Object created" );
    isa_ok( $tar,                   'Archive::Tar');

    local $Archive::Tar::WARN  = 0;

    ### should be empty to begin with
    is( $tar->error, '',            "The error string is empty" );

    ### try a read on nothing
    my @list = $tar->read();

    ok(!(scalar @list),             "Function read returns 0 files on error" );
    ok( $tar->error,                "   error string is non empty" );
    like( $tar->error, qr/No file to read from/,
                                    "   error string from create()" );
    unlike( $tar->error, qr/add/,   "   error string does not contain add" );

    ### now, add empty data
    my $obj = $tar->add_data( '' );

    ok( !$obj,                      "'add_data' returns undef on error" );
    ok( $tar->error,                "   error string is non empty" );
    like( $tar->error, qr/add/,     "   error string contains add" );
    unlike( $tar->error, qr/create/,"   error string does not contain create" );

    ### check if ->error eq $error
    is( $tar->error, $Archive::Tar::error,
                                    '$error matches error() method' );
                     
    ### check that 'contains_file' doesn't warn about missing files.                     
    {   ### turn on warnings in general!
        local $Archive::Tar::WARN  = 1;

        my $warnings = '';
        local $SIG{__WARN__} = sub { $warnings .= "@_" };
        
        my $rv = $tar->contains_file( $$ );
        ok( !$rv,                   "Does not contain file '$$'" );
        is( $warnings, '',          "   No warnings issued during lookup" );
    }        
}

### read tests ###
{   ### normal tar + gz compressed file
    my $archive         = $TAR_FILE;
    my $compressed      = $TGZ_FILE;
    my $tar             = Archive::Tar->new;
    my $gzip            = 0;

    ### check we got the object
    ok( $tar,                       "Object created" );
    isa_ok( $tar,                   'Archive::Tar');

    for my $type( $archive, $compressed ) {
        my $state = $gzip ? 'compressed' : 'uncompressed';

        SKIP: {

            ### skip gz compressed archives wihtout IO::Zlib
            skip(   "No IO::Zlib - cannot read compressed archives",
                    4 + 2 * (scalar @EXPECT_NORMAL)
            ) if( $gzip and !$ZLIB);

            ### ->read test
            {   my @list    = $tar->read( $type );
                my $cnt     = scalar @list;
                my $expect  = scalar __PACKAGE__->get_expect();

                ok( $cnt,           "Reading $state file using 'read()'" );
                is( $cnt, $expect,  "   All files accounted for" );

                for my $file ( @list ) {
                    ok( $file,      "Got File object" );
                    isa_ok( $file,  "Archive::Tar::File" );

                    ### whitebox test -- make sure find_entry gets the
                    ### right files
                    for my $test ( $file->full_path, $file ) {
                        is( $tar->_find_entry( $test ), $file,
                                    "   Found proper object" );
                    }
                    
                    next unless $file->is_file;

                    my $name = $file->full_path;
                    my($expect_name, $expect_content) =
                        get_expect_name_and_contents( $name, \@EXPECT_NORMAL );

                    ### ->fullname!
                    ok($expect_name,"   Found expected file '$name'" );

                    like($tar->get_content($name), $expect_content,
                                    "   Content OK" );
                }
            }


            ### list_archive test
            {   my @list    = Archive::Tar->list_archive( $archive );
                my $cnt     = scalar @list;
                my $expect  = scalar __PACKAGE__->get_expect();

                ok( $cnt,           "Reading $state file using 'list_archive'");
                is( $cnt, $expect,  "   All files accounted for" );

                for my $file ( @list ) {
                    next if __PACKAGE__->is_dir( $file ); # directories

                    my($expect_name, $expect_content) =
                        get_expect_name_and_contents( $file, \@EXPECT_NORMAL );

                    ok( $expect_name,
                                    "   Found expected file '$file'" );
                }
            }
        }

        ### now we try gz compressed archives
        $gzip++;
    }
}

### add files tests ###
{   my @add     = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
    my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
    my $tar     = Archive::Tar->new;

    ### check we got the object
    ok( $tar,                       "Object created" );
    isa_ok( $tar,                   'Archive::Tar');

    ### add the files
    {   my @files = $tar->add_files( @add );

        is( scalar @files, scalar @add,
                                    "Adding files");
        is( $files[0]->name, 'b',   "   Proper name" );

        SKIP: {
            skip( "You are building perl using symlinks", 1)
                if ($ENV{PERL_CORE} and $Config{config_args} =~/Dmksymlinks/);

            is( $files[0]->is_file, 1,  
                                    "   Proper type" );
        }

        like( $files[0]->get_content, qr/^bbbbbbbbbbb\s*$/,
                                    "   Content OK" );

        ### check if we have then in our tar object
        for my $file ( @addunix ) {
            ok( $tar->contains_file($file),
                                    "   File found in archive" );
        }
    }

    ### check adding files doesn't conflict with a secondary archive
    ### old A::T bug, we should keep testing for it
    {   my $tar2    = Archive::Tar->new;
        my @added   = $tar2->add_files( $COMPRESS_FILE );
        my @count   = $tar2->list_files;

        is( scalar @added, 1,       "Added files to secondary archive" );
        is( scalar @added, scalar @count,
                                    "   Does not conflict with first archive" );

        ### check the adding of directories
        my @add_dirs  = File::Spec->catfile( @ROOT );
        my @dirs      = $tar2->add_files( @add_dirs );
        is( scalar @dirs, scalar @add_dirs,
                                    "Adding dirs");
        ok( $dirs[0]->is_dir,       "   Proper type" );
    }
}

### add data tests ###
{
    {   ### standard data ###
        my @to_add  = ( 'a', 'aaaaa' );
        my $tar     = Archive::Tar->new;

        ### check we got the object
        ok( $tar,                   "Object created" );
        isa_ok( $tar,               'Archive::Tar');

        ### add a new file item as data
        my $obj = $tar->add_data( @to_add );

        ok( $obj,                   "Adding data" );
        is( $obj->name, $to_add[0], "   Proper name" );
        is( $obj->is_file, 1,       "   Proper type" );
        like( $obj->get_content, qr/^$to_add[1]\s*$/,
                                    "   Content OK" );
    }

    {   ### binary data +
        ### dir/file structure -- x/y always went ok, x/x used to extract
        ### in the wrong way -- this test catches that
        for my $list (  [$TARBIN,   \@EXPECTBIN],
                        [$TARX,     \@EXPECTX],
        ) {
            ### XXX GLOBAL! changes may affect other tests!
            my($tar,$struct) = @$list;

            for my $aref ( @$struct ) {
                my ($dirs,$file,$data) = @$aref;

                my $path = File::Spec::Unix->catfile(
                                grep { length } @$dirs, $file );

                my $obj = $tar->add_data( $path, $data );

                ok( $obj,               "Adding data '$file'" );
                is( $obj->full_path, $path,
                                        "   Proper name" );
                ok( $obj->is_file,      "   Proper type" );
                is( $obj->get_content, $data,
                                        "   Content OK" );
            }
        }
    }
}

### rename/replace_content tests ###
{   my $tar     = Archive::Tar->new;
    my $from    = 'c';
    my $to      = 'e';

    ### read in the file, check the proper files are there
    ok( $tar->read( $TAR_FILE ),    "Read in '$TAR_FILE'" );
    ok( $tar->get_files($from),     "   Found file '$from'" );
    {   local $Archive::Tar::WARN = 0;
        ok(!$tar->get_files($to),   "   File '$to' not yet found" );
    }

    ### rename an entry, check the rename has happened
    ok( $tar->rename( $from, $to ), "   Renamed '$from' to '$to'" );
    ok( $tar->get_files($to),       "   File '$to' now found" );
    {   local $Archive::Tar::WARN = 0;
        ok(!$tar->get_files($from), "   File '$from' no longer found'");
    }

    ### now, replace the content
    my($expect_name, $expect_content) =
                        get_expect_name_and_contents( $from, \@EXPECT_NORMAL );

    like( $tar->get_content($to), $expect_content,
                                    "Original content of '$from' in '$to'" );
    ok( $tar->replace_content( $to, $from ),
                                    "   Set content for '$to' to '$from'" );
    is( $tar->get_content($to), $from,
                                    "   Content for '$to' is indeed '$from'" );
}

### remove tests ###
{   my $remove  = 'c';
    my $tar     = Archive::Tar->new;

    ok( $tar->read( $TAR_FILE ),    "Read in '$TAR_FILE'" );

    ### remove returns the files left, which should be equal to list_files
    is( scalar($tar->remove($remove)), scalar($tar->list_files),
                                    "Removing file '$remove'" );

    ### so what's left should be all expected files minus 1
    is( scalar($tar->list_files), scalar(__PACKAGE__->get_expect) - 1,
                                    "   Proper files remaining" );
}

### write + read + extract tests ###
SKIP: {
    skip('no IO::String', 326) if   !$Archive::Tar::HAS_PERLIO && 
                                    !$Archive::Tar::HAS_IO_STRING;
                                    
    my $tar = Archive::Tar->new;
    my $new = Archive::Tar->new;
    ok( $tar->read( $TAR_FILE ),    "Read in '$TAR_FILE'" );

    for my $aref (  [$tar,    \@EXPECT_NORMAL],
                    [$TARBIN, \@EXPECTBIN],
                    [$TARX,   \@EXPECTX]
    ) {
        my($obj,$struct) = @$aref;

        ### check if we stringify it ok
        {   my $string = $obj->write;
            ok( $string,           "Stringified tar file has size" );
            cmp_ok( length($string) % BLOCK, '==', 0,
                                    "Tar archive stringified" );
        }

        ### write tar tests
        {   my $out = $OUT_TAR_FILE;

            {   ### write()
                ok( $obj->write($out),
                                    "Wrote tarfile using 'write'" );
                check_tar_file( $out );
                check_tar_object( $obj, $struct );