1 ### This program tests Archive::Tar::File ###
3 use Test::More 'no_plan';
6 use File::Spec::Unix ();
8 use Archive::Tar::File;
9 use Archive::Tar::Constant;
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;
15 my $rename_path = 'x/yy/42';
16 my ($rename_dir, $rename_file) = dir_and_file( $rename_path );
19 ### pathname contents optional hash of attributes ###
20 [ 'x/bIn1', $all_chars ],
21 [ 'bIn2', $all_chars x 2 ],
24 ### we didnt handle 'false' filenames very well across A::T as of version
25 ### 1.32, as reported in #28687. Test for the handling of such files here.
28 ### keep this one as the last entry
29 [ 'x/yy/z', '', { type => DIR,
35 mtime => $start_time } ],
38 ### new( data => ... ) tests ###
39 for my $f ( @test_files ) {
40 my $unix_path = $f->[0];
41 my $contents = $f->[1];
42 my $attr = $f->[2] || {};
43 my ($dir, $file) = dir_and_file( $unix_path );
45 my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr );
47 isa_ok( $obj, 'Archive::Tar::File', "Object created" );
48 is( $obj->name, $file, " name '$file' ok" );
49 is( $obj->prefix, $dir, " prefix '$dir' ok" );
50 is( $obj->size, length($contents), " size ok" );
51 is( $obj->mode, exists($attr->{mode}) ? $attr->{mode} : MODE,
53 is( $obj->uid, exists($attr->{uid}) ? $attr->{uid} : UID,
55 is( $obj->gid, exists($attr->{gid}) ? $attr->{gid} : GID,
57 is( $obj->uname, exists($attr->{uname}) ? $attr->{uname} : UNAME->(UID ),
59 is( $obj->gname, exists($attr->{gname}) ? $attr->{gname} : GNAME->( GID ),
61 is( $obj->type, exists($attr->{type}) ? $attr->{type} : FILE,
63 if (exists($attr->{mtime})) {
64 is( $obj->mtime, $attr->{mtime}, " mtime matches" );
66 cmp_ok( $obj->mtime, '>', $start_time, " mtime after start time" );
68 ok( $obj->chksum, " chksum ok" );
69 ok( $obj->version, " version ok" );
70 ok( ! $obj->linkname, " linkname ok" );
71 ok( ! $obj->devmajor, " devmajor ok" );
72 ok( ! $obj->devminor, " devminor ok" );
73 ok( ! $obj->raw, " raw ok" );
75 ### test type checkers
77 skip "Attributes defined, may not be plainfile", 11 if keys %$attr;
79 ok( $obj->is_file, " Object is a file" );
81 for my $name (qw[dir hardlink symlink chardev blockdev fifo
82 socket unknown longlink label ]
84 my $method = 'is_' . $name;
86 ok(!$obj->$method(), " Object is not a '$name'");
90 ### Use "ok" not "is" to avoid binary data screwing up the screen ###
91 ok( $obj->get_content eq $contents, " get_content ok" );
92 ok( ${$obj->get_content_by_ref} eq $contents,
93 " get_content_by_ref ok" );
94 is( $obj->has_content, length($contents) ? 1 : 0,
96 ok( $obj->replace_content( $replace_contents ),
97 " replace_content ok" );
98 ok( $obj->get_content eq $replace_contents, " get_content ok" );
99 ok( $obj->replace_content( $contents ), " replace_content ok" );
100 ok( $obj->get_content eq $contents, " get_content ok" );
102 ok( $obj->rename( $rename_path ), " rename ok" );
103 is( $obj->name, $rename_file, " name '$file' ok" );
104 is( $obj->prefix, $rename_dir, " prefix '$dir' ok" );
105 ok( $obj->rename( $unix_path ), " rename ok" );
106 is( $obj->name, $file, " name '$file' ok" );
107 is( $obj->prefix, $dir, " prefix '$dir' ok" );
110 my $clone = $obj->clone;
111 isnt( $obj, $clone, "Clone is different object" );
112 is_deeply( $obj, $clone, " Clone holds same data" );
115 ### _downgrade_to_plainfile
116 { my $aref = $test_files[-1];
117 my $unix_path = $aref->[0];
118 my $contents = $aref->[1];
119 my $attr = $aref->[2];
121 my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr );
123 ### check if the object is as expected
124 isa_ok( $obj, 'Archive::Tar::File' );
125 ok( $obj->is_dir, " Is a directory" );
128 ok( $obj->_downgrade_to_plainfile, " Downgraded to plain file" );
130 ### now check if it's downgraded
131 ok( $obj->is_file, " Is now a file" );
132 is( $obj->linkname, '', " No link entered" );
133 is( $obj->mode, MODE, " Mode as expected" );
138 my $unix_path = shift;
139 my ($vol, $dirs, $file) = File::Spec::Unix->splitpath( $unix_path );
140 my $dir = File::Spec::Unix->catdir( grep { length } $vol,
141 File::Spec::Unix->splitdir( $dirs ) );
142 return ( $dir, $file );