Commit | Line | Data |
81a5970e |
1 | BEGIN { |
2 | if( $ENV{PERL_CORE} ) { |
3 | chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar'; |
4 | } |
5 | use lib '../../..'; |
6 | } |
7 | |
8 | BEGIN { chdir 't' if -d 't' } |
9 | |
178aef9a |
10 | use Test::More 'no_plan'; |
11 | use File::Basename 'basename'; |
81a5970e |
12 | use strict; |
13 | use lib '../lib'; |
14 | |
15 | my $NO_UNLINK = @ARGV ? 1 : 0; |
16 | |
17 | my $Class = 'Archive::Tar'; |
178aef9a |
18 | my $FileClass = $Class . '::File'; |
81a5970e |
19 | |
20 | use_ok( $Class ); |
178aef9a |
21 | use_ok( $FileClass ); |
81a5970e |
22 | |
23 | ### bug #13636 |
24 | ### tests for @longlink behaviour on files that have a / at the end |
25 | ### of their shortened path, making them appear to be directories |
178aef9a |
26 | { ok( 1, "Testing bug 13636" ); |
27 | |
28 | ### dont use the prefix, otherwise A::T will not use @longlink |
81a5970e |
29 | ### encoding style |
30 | local $Archive::Tar::DO_NOT_USE_PREFIX = 1; |
31 | local $Archive::Tar::DO_NOT_USE_PREFIX = 1; |
32 | |
5b213ac8 |
33 | my $dir = 'Catalyst-Helper-Controller-Scaffold-HTML-Template-0_03/' . |
81a5970e |
34 | 'lib/Catalyst/Helper/Controller/Scaffold/HTML/'; |
35 | my $file = 'Template.pm'; |
36 | my $out = $$ . '.tar'; |
37 | |
38 | ### first create the file |
39 | { my $tar = $Class->new; |
40 | |
178aef9a |
41 | isa_ok( $tar, $Class, " Object" ); |
81a5970e |
42 | ok( $tar->add_data( $dir.$file => $$ ), |
178aef9a |
43 | " Added long file" ); |
81a5970e |
44 | |
178aef9a |
45 | ok( $tar->write($out), " File written to $out" ); |
81a5970e |
46 | } |
47 | |
48 | ### then read it back in |
49 | { my $tar = $Class->new; |
178aef9a |
50 | isa_ok( $tar, $Class, " Object" ); |
51 | ok( $tar->read( $out ), " Read in $out again" ); |
81a5970e |
52 | |
53 | my @files = $tar->get_files; |
178aef9a |
54 | is( scalar(@files), 1, " Only 1 entry found" ); |
81a5970e |
55 | |
56 | my $entry = shift @files; |
178aef9a |
57 | ok( $entry->is_file, " Entry is a file" ); |
81a5970e |
58 | is( $entry->name, $dir.$file, |
178aef9a |
59 | " With the proper name" ); |
81a5970e |
60 | } |
61 | |
62 | ### remove the file |
63 | unless( $NO_UNLINK ) { 1 while unlink $out } |
64 | } |
b3200c5d |
65 | |
66 | ### bug #14922 |
67 | ### There's a bug in Archive::Tar that causes a file like: foo/foo.txt |
68 | ### to be stored in the tar file as: foo/.txt |
69 | ### XXX could not be reproduced in 1.26 -- leave test to be sure |
178aef9a |
70 | { ok( 1, "Testing bug 14922" ); |
71 | |
72 | my $dir = $$ . '/'; |
b3200c5d |
73 | my $file = $$ . '.txt'; |
74 | my $out = $$ . '.tar'; |
75 | |
76 | ### first create the file |
77 | { my $tar = $Class->new; |
78 | |
178aef9a |
79 | isa_ok( $tar, $Class, " Object" ); |
b3200c5d |
80 | ok( $tar->add_data( $dir.$file => $$ ), |
178aef9a |
81 | " Added long file" ); |
b3200c5d |
82 | |
178aef9a |
83 | ok( $tar->write($out), " File written to $out" ); |
b3200c5d |
84 | } |
85 | |
86 | ### then read it back in |
87 | { my $tar = $Class->new; |
178aef9a |
88 | isa_ok( $tar, $Class, " Object" ); |
89 | ok( $tar->read( $out ), " Read in $out again" ); |
b3200c5d |
90 | |
91 | my @files = $tar->get_files; |
178aef9a |
92 | is( scalar(@files), 1, " Only 1 entry found" ); |
b3200c5d |
93 | |
94 | my $entry = shift @files; |
178aef9a |
95 | ok( $entry->is_file, " Entry is a file" ); |
b3200c5d |
96 | is( $entry->full_path, $dir.$file, |
178aef9a |
97 | " With the proper name" ); |
b3200c5d |
98 | } |
99 | |
100 | ### remove the file |
101 | unless( $NO_UNLINK ) { 1 while unlink $out } |
102 | } |
103 | |
178aef9a |
104 | ### bug #30380: directory traversal vulnerability in Archive-Tar |
105 | ### Archive::Tar allowed files to be extracted to a dir outside |
106 | ### it's cwd(), effectively allowing you to overwrite any files |
107 | ### on the system, given the right permissions. |
108 | { ok( 1, "Testing bug 30880" ); |
109 | |
110 | my $tar = $Class->new; |
111 | isa_ok( $tar, $Class, " Object" ); |
112 | |
113 | ### absolute paths are already taken care of. Only relative paths |
114 | ### matter |
115 | my $in_file = basename($0); |
f5695358 |
116 | my $out_file = '../' . $in_file . "_$$"; |
178aef9a |
117 | |
118 | ok( $tar->add_files( $in_file ), |
119 | " Added '$in_file'" ); |
120 | ok( $tar->rename( $in_file, $out_file ), |
121 | " Renamed to '$out_file'" ); |
122 | |
123 | ### first, test with strict extract permissions on |
124 | { local $Archive::Tar::INSECURE_EXTRACT_MODE = 0; |
125 | |
126 | ### we quell the error on STDERR |
127 | local $Archive::Tar::WARN = 0; |
128 | local $Archive::Tar::WARN = 0; |
129 | |
130 | ok( 1, " Extracting in secure mode" ); |
131 | |
132 | ok( ! $tar->extract_file( $out_file ), |
133 | " File not extracted" ); |
134 | ok( ! -e $out_file, " File '$out_file' does not exist" ); |
135 | |
136 | ok( $tar->error, " Error message stored" ); |
137 | like( $tar->error, qr/attempting to leave/, |
138 | " Proper violation detected" ); |
139 | } |
b3200c5d |
140 | |
178aef9a |
141 | ### now disable those |
142 | { local $Archive::Tar::INSECURE_EXTRACT_MODE = 1; |
143 | ok( 1, " Extracting in insecure mode" ); |
b3200c5d |
144 | |
178aef9a |
145 | ok( $tar->extract_file( $out_file ), |
146 | " File extracted" ); |
147 | ok( -e $out_file, " File '$out_file' exists" ); |
148 | |
149 | ### and clean up |
150 | unless( $NO_UNLINK ) { 1 while unlink $out_file }; |
151 | } |
bef46b70 |
152 | } |
178aef9a |
153 | |
bef46b70 |
154 | ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar |
155 | ### like GNU tar does. See here for details: |
156 | ### http://www.gnu.org/software/tar/manual/tar.html#SEC139 |
157 | { ok( 1, "Testing bug 43513" ); |
158 | |
159 | my $src = File::Spec->catfile( qw[src header signed.tar] ); |
160 | my $tar = $Class->new; |
161 | |
162 | isa_ok( $tar, $Class, " Object" ); |
163 | ok( $tar->read( $src ), " Read non-Posix file with signed Checksum" ); |
164 | |
165 | for my $file ( $tar->get_files ) { |
166 | ok( $file, " File object retrieved" ); |
167 | ok( $file->validate, " File validates" ); |
168 | } |
178aef9a |
169 | } |
4feb3b72 |
170 | |
171 | ### return error properly on corrupted archives |
172 | ### Addresses RT #44680: Improve error reporting on short corrupted archives |
173 | { ok( 1, "Testing bug 44680" ); |
174 | |
175 | { ### XXX whitebox test -- resetting the error string |
176 | no warnings 'once'; |
177 | $Archive::Tar::error = ""; |
178 | } |
179 | |
180 | my $src = File::Spec->catfile( qw[src short b] ); |
181 | my $tar = $Class->new; |
182 | |
183 | isa_ok( $tar, $Class, " Object" ); |
184 | |
185 | |
186 | ### we quell the error on STDERR |
187 | local $Archive::Tar::WARN = 0; |
188 | |
189 | ok( !$tar->read( $src ), " No files in the corrupted archive" ); |
190 | like( $tar->error, qr/enough bytes/, |
191 | " Expected error reported" ); |
192 | } |
193 | |