"Fossies" - the Fresh Open Source Software Archive

Member "Archive-Tar-2.38/t/03_file.t" (12 May 2013, 6822 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.

    1 ### This program tests Archive::Tar::File ###
    2 use Test::More 'no_plan';
    3 use strict;
    4 
    5 use File::Spec::Unix  ();
    6 
    7 use Archive::Tar::File;
    8 use Archive::Tar::Constant;
    9 
   10 my $all_chars         = join '', "\r\n", map( chr, 0..255 ), "zzz\n\r";
   11 my $start_time        = time() - 1 - TIME_OFFSET;
   12 my $replace_contents  = $all_chars x 42;
   13 
   14 my $rename_path                 = 'x/yy/42';
   15 my ($rename_dir, $rename_file)  = dir_and_file( $rename_path );
   16 
   17 my @test_files = (
   18     ###  pathname         contents          optional hash of attributes ###
   19     [    'x/bIn1',        $all_chars                                      ],
   20     [    'bIn2',          $all_chars x 2                                  ],
   21     [    'bIn0',          ''                                              ],
   22 
   23     ### we didnt handle 'false' filenames very well across A::T as of version
   24     ### 1.32, as reported in #28687. Test for the handling of such files here.
   25     [    0,               '',                                             ],
   26 
   27     ### keep this one as the last entry
   28     [    'x/yy/z',        '',               { type  => DIR,
   29                                               mode  => 0777,
   30                                               uid   => 42,
   31                                               gid   => 43,
   32                                               uname => 'Ford',
   33                                               gname => 'Prefect',
   34                                               mtime => $start_time }      ],
   35 );
   36 
   37 ### new( data => ... ) tests ###
   38 for my $f ( @test_files ) {
   39     my $unix_path     = $f->[0];
   40     my $contents      = $f->[1];
   41     my $attr          = $f->[2] || {};
   42     my ($dir, $file)  = dir_and_file( $unix_path );
   43 
   44     my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr );
   45 
   46     isa_ok( $obj,       'Archive::Tar::File',    "Object created" );
   47     is( $obj->name,     $file,                   "   name '$file' ok" );
   48     is( $obj->prefix,   $dir,                    "   prefix '$dir' ok" );
   49     is( $obj->size,     length($contents),       "   size ok" );
   50     is( $obj->mode,     exists($attr->{mode}) ? $attr->{mode} : MODE,
   51                                                  "   mode ok" );
   52     is( $obj->uid,      exists($attr->{uid}) ? $attr->{uid} : UID,
   53                                                  "   uid ok" );
   54     is( $obj->gid,      exists($attr->{gid}) ? $attr->{gid} : GID,
   55                                                  "   gid ok" );
   56     is( $obj->uname,    exists($attr->{uname}) ? $attr->{uname} : UNAME->(UID ),
   57                                                  "   uname ok" );
   58     is( $obj->gname,    exists($attr->{gname}) ? $attr->{gname} : GNAME->( GID ),
   59                                                  "   gname ok" );
   60     is( $obj->type,     exists($attr->{type}) ? $attr->{type} : FILE,
   61                                                  "   type ok" );
   62     if (exists($attr->{mtime})) {
   63         is( $obj->mtime, $attr->{mtime},         "   mtime matches" );
   64     } else {
   65         cmp_ok( $obj->mtime, '>', $start_time,   "   mtime after start time" );
   66     }
   67     ok( $obj->chksum,                            "   chksum ok" );
   68     ok( $obj->version,                           "   version ok" );
   69     ok( ! $obj->linkname,                        "   linkname ok" );
   70     ok( ! $obj->devmajor,                        "   devmajor ok" );
   71     ok( ! $obj->devminor,                        "   devminor ok" );
   72     ok( ! $obj->raw,                             "   raw ok" );
   73 
   74     ### test type checkers
   75     SKIP: {
   76         skip "Attributes defined, may not be plainfile", 11 if keys %$attr;
   77 
   78         ok( $obj->is_file,                      "   Object is a file" );
   79 
   80         for my $name (qw[dir hardlink symlink chardev blockdev fifo
   81                          socket unknown longlink label ]
   82         ) {
   83             my $method = 'is_' . $name;
   84 
   85             ok(!$obj->$method(),               "   Object is not a '$name'");
   86         }
   87     }
   88 
   89     ### Use "ok" not "is" to avoid binary data screwing up the screen ###
   90     ok( $obj->get_content eq $contents,          "   get_content ok" );
   91     ok( ${$obj->get_content_by_ref} eq $contents,
   92                                                  "   get_content_by_ref ok" );
   93     is( $obj->has_content, length($contents) ? 1 : 0,
   94                                                  "   has_content ok" );
   95     ok( $obj->replace_content( $replace_contents ),
   96                                                  "   replace_content ok" );
   97     ok( $obj->get_content eq $replace_contents,  "   get_content ok" );
   98     ok( $obj->replace_content( $contents ),      "   replace_content ok" );
   99     ok( $obj->get_content eq $contents,          "   get_content ok" );
  100 
  101     ok( $obj->rename( $rename_path ),            "   rename ok" );
  102     ok( $obj->chown( 'root' ),                   "   chown 1 arg ok" );
  103     is( $obj->uname,    'root',                  "   chown to root ok" );
  104     ok( $obj->chown( 'rocky', 'perl'),           "   chown 2 args ok" );
  105     is( $obj->uname,    'rocky',                 "   chown to rocky ok" );
  106     is( $obj->gname,    'perl',                  "   chown to rocky:perl ok" );
  107     is( $obj->name,     $rename_file,            "   name '$file' ok" );
  108     is( $obj->prefix,   $rename_dir,             "   prefix '$dir' ok" );
  109     ok( $obj->rename( $unix_path ),              "   rename ok" );
  110     is( $obj->name,     $file,                   "   name '$file' ok" );
  111     is( $obj->prefix,   $dir,                    "   prefix '$dir' ok" );
  112 
  113     ### clone tests ###
  114     my $clone = $obj->clone;
  115     isnt( $obj, $clone,                         "Clone is different object" );
  116     is_deeply( $obj, $clone,                    "   Clone holds same data" );
  117 }
  118 
  119 ### _downgrade_to_plainfile
  120 {   my $aref        = $test_files[-1];
  121     my $unix_path   = $aref->[0];
  122     my $contents    = $aref->[1];
  123     my $attr        = $aref->[2];
  124 
  125     my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr );
  126 
  127     ### check if the object is as expected
  128     isa_ok( $obj,                           'Archive::Tar::File' );
  129     ok( $obj->is_dir,                       "   Is a directory" );
  130 
  131     ### do the downgrade
  132     ok( $obj->_downgrade_to_plainfile,      "   Downgraded to plain file" );
  133 
  134     ### now check if it's downgraded
  135     ok( $obj->is_file,                      "   Is now a file" );
  136     is( $obj->linkname, '',                 "   No link entered" );
  137     is( $obj->mode, MODE,                   "   Mode as expected" );
  138 }
  139 
  140 ### helper subs ###
  141 sub dir_and_file {
  142     my $unix_path = shift;
  143     my ($vol, $dirs, $file) = File::Spec::Unix->splitpath( $unix_path );
  144     my $dir = File::Spec::Unix->catdir( grep { length } $vol,
  145                                         File::Spec::Unix->splitdir( $dirs ) );
  146     return ( $dir, $file );
  147 }