1### This program tests Archive::Tar::File ###
2use Test::More 'no_plan';
3use strict;
4
5use File::Spec::Unix  ();
6
7use Archive::Tar::File;
8use Archive::Tar::Constant;
9
10my $all_chars         = join '', "\r\n", map( chr, 0..255 ), "zzz\n\r";
11my $start_time        = time() - 1 - TIME_OFFSET;
12my $replace_contents  = $all_chars x 42;
13
14my $rename_path                 = 'x/yy/42';
15my ($rename_dir, $rename_file)  = dir_and_file( $rename_path );
16
17my @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 ###
38for 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 ###
141sub 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}
148