Commit | Line | Data |
39713df4 |
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', '' ], |
01d11a1c |
23 | |
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. |
26 | [ 0, '', ], |
39713df4 |
27 | |
28 | ### keep this one as the last entry |
29 | [ 'x/yy/z', '', { type => DIR, |
30 | mode => 0777, |
31 | uid => 42, |
32 | gid => 43, |
33 | uname => 'Ford', |
34 | gname => 'Prefect', |
35 | mtime => $start_time } ], |
36 | ); |
37 | |
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 ); |
44 | |
45 | my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr ); |
46 | |
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, |
52 | " mode ok" ); |
53 | is( $obj->uid, exists($attr->{uid}) ? $attr->{uid} : UID, |
54 | " uid ok" ); |
55 | is( $obj->gid, exists($attr->{gid}) ? $attr->{gid} : GID, |
56 | " gid ok" ); |
57 | is( $obj->uname, exists($attr->{uname}) ? $attr->{uname} : UNAME->(UID ), |
58 | " uname ok" ); |
59 | is( $obj->gname, exists($attr->{gname}) ? $attr->{gname} : GNAME->( GID ), |
60 | " gname ok" ); |
61 | is( $obj->type, exists($attr->{type}) ? $attr->{type} : FILE, |
62 | " type ok" ); |
63 | if (exists($attr->{mtime})) { |
64 | is( $obj->mtime, $attr->{mtime}, " mtime matches" ); |
65 | } else { |
66 | cmp_ok( $obj->mtime, '>', $start_time, " mtime after start time" ); |
67 | } |
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" ); |
74 | |
75 | ### test type checkers |
76 | SKIP: { |
77 | skip "Attributes defined, may not be plainfile", 11 if keys %$attr; |
78 | |
79 | ok( $obj->is_file, " Object is a file" ); |
80 | |
81 | for my $name (qw[dir hardlink symlink chardev blockdev fifo |
82 | socket unknown longlink label ] |
83 | ) { |
84 | my $method = 'is_' . $name; |
85 | |
86 | ok(!$obj->$method(), " Object is not a '$name'"); |
87 | } |
88 | } |
89 | |
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, |
95 | " has_content ok" ); |
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" ); |
101 | |
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" ); |
108 | |
109 | ### clone tests ### |
110 | my $clone = $obj->clone; |
111 | isnt( $obj, $clone, "Clone is different object" ); |
112 | is_deeply( $obj, $clone, " Clone holds same data" ); |
113 | } |
114 | |
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]; |
120 | |
121 | my $obj = Archive::Tar::File->new( data => $unix_path, $contents, $attr ); |
122 | |
123 | ### check if the object is as expected |
124 | isa_ok( $obj, 'Archive::Tar::File' ); |
125 | ok( $obj->is_dir, " Is a directory" ); |
126 | |
127 | ### do the downgrade |
128 | ok( $obj->_downgrade_to_plainfile, " Downgraded to plain file" ); |
129 | |
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" ); |
134 | } |
135 | |
136 | ### helper subs ### |
137 | sub dir_and_file { |
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 ); |
143 | } |