lib/Archive/Tar/t/03_file.t

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