1BEGIN { chdir 't' if -d 't' }
2
3use Test::More      'no_plan';
4use File::Basename  'basename';
5use strict;
6use lib '../lib';
7
8my $NO_UNLINK   = @ARGV ? 1 : 0;
9
10my $Class       = 'Archive::Tar';
11my $FileClass   = $Class . '::File';
12
13use_ok( $Class );
14use_ok( $FileClass );
15
16### bug #13636
17### tests for @longlink behaviour on files that have a / at the end
18### of their shortened path, making them appear to be directories
19{   ok( 1,                      "Testing bug 13636" );
20
21    ### dont use the prefix, otherwise A::T will not use @longlink
22    ### encoding style
23    local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
24    local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
25
26    my $dir =   'Catalyst-Helper-Controller-Scaffold-HTML-Template-0_03/' .
27                'lib/Catalyst/Helper/Controller/Scaffold/HTML/';
28    my $file =  'Template.pm';
29    my $out =   $$ . '.tar';
30
31    ### first create the file
32    {   my $tar = $Class->new;
33
34        isa_ok( $tar, $Class,   "   Object" );
35        ok( $tar->add_data( $dir.$file => $$ ),
36                                "       Added long file" );
37
38        ok( $tar->write($out),  "       File written to $out" );
39    }
40
41    ### then read it back in
42    {   my $tar = $Class->new;
43        isa_ok( $tar, $Class,   "   Object" );
44        ok( $tar->read( $out ), "       Read in $out again" );
45
46        my @files = $tar->get_files;
47        is( scalar(@files), 1,  "       Only 1 entry found" );
48
49        my $entry = shift @files;
50        ok( $entry->is_file,    "       Entry is a file" );
51        is( $entry->name, $dir.$file,
52                                "       With the proper name" );
53    }
54
55    ### remove the file
56    unless( $NO_UNLINK ) { 1 while unlink $out }
57}
58
59### bug #14922
60### There's a bug in Archive::Tar that causes a file like: foo/foo.txt
61### to be stored in the tar file as: foo/.txt
62### XXX could not be reproduced in 1.26 -- leave test to be sure
63{   ok( 1,                      "Testing bug 14922" );
64
65    my $dir     = $$ . '/';
66    my $file    = $$ . '.txt';
67    my $out     = $$ . '.tar';
68
69    ### first create the file
70    {   my $tar = $Class->new;
71
72        isa_ok( $tar, $Class,   "   Object" );
73        ok( $tar->add_data( $dir.$file => $$ ),
74                                "       Added long file" );
75
76        ok( $tar->write($out),  "       File written to $out" );
77    }
78
79    ### then read it back in
80    {   my $tar = $Class->new;
81        isa_ok( $tar, $Class,   "   Object" );
82        ok( $tar->read( $out ), "       Read in $out again" );
83
84        my @files = $tar->get_files;
85        is( scalar(@files), 1,  "       Only 1 entry found" );
86
87        my $entry = shift @files;
88        ok( $entry->is_file,    "       Entry is a file" );
89        is( $entry->full_path, $dir.$file,
90                                "       With the proper name" );
91    }
92
93    ### remove the file
94    unless( $NO_UNLINK ) { 1 while unlink $out }
95}
96
97### bug #30380: directory traversal vulnerability in Archive-Tar
98### Archive::Tar allowed files to be extracted to a dir outside
99### it's cwd(), effectively allowing you to overwrite any files
100### on the system, given the right permissions.
101{   ok( 1,                      "Testing bug 30880" );
102
103    my $tar = $Class->new;
104    isa_ok( $tar, $Class,       "   Object" );
105
106    ### absolute paths are already taken care of. Only relative paths
107    ### matter
108    my $in_file     = basename($0);
109    my $out_file    = '../' . $in_file . "_$$";
110
111    ok( $tar->add_files( $in_file ),
112                                "       Added '$in_file'" );
113
114    ok( $tar->chmod( $in_file, '1777'),
115                                "       chmod 177 $in_file" );
116
117    ok( $tar->chown( $in_file, 'root' ),
118                                "       chown to root" );
119
120    ok( $tar->chown( $in_file, 'root', 'root' ),
121                                "       chown to root:root" );
122
123    ok( $tar->rename( $in_file, $out_file ),
124                                "       Renamed to '$out_file'" );
125
126    ### first, test with strict extract permissions on
127    {   local $Archive::Tar::INSECURE_EXTRACT_MODE = 0;
128
129        ### we quell the error on STDERR
130        local $Archive::Tar::WARN = 0;
131        local $Archive::Tar::WARN = 0;
132
133        ok( 1,                  "   Extracting in secure mode" );
134
135        ok( ! $tar->extract_file( $out_file ),
136                                "       File not extracted" );
137        ok( ! -e $out_file,     "       File '$out_file' does not exist" );
138
139        ok( $tar->error,        "       Error message stored" );
140        like( $tar->error, qr/attempting to leave/,
141                                "           Proper violation detected" );
142    }
143
144    ### now disable those
145    {   local $Archive::Tar::INSECURE_EXTRACT_MODE = 1;
146        ok( 1,                  "   Extracting in insecure mode" );
147
148        ok( $tar->extract_file( $out_file ),
149                                "       File extracted" );
150        ok( -e $out_file,       "       File '$out_file' exists" );
151
152        ### and clean up
153        unless( $NO_UNLINK ) { 1 while unlink $out_file };
154    }
155}
156
157### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
158### like GNU tar does. See here for details:
159### http://www.gnu.org/software/tar/manual/tar.html#SEC139
160SKIP: {
161    skip "File contains an alien character set", 5 if ord "A" != 65;
162
163    ok( 1,                      "Testing bug 43513" );
164
165    my $src = File::Spec->catfile( qw[src header signed.tar] );
166    my $tar = $Class->new;
167
168    isa_ok( $tar, $Class,       "   Object" );
169    ok( $tar->read( $src ),     "   Read non-Posix file with signed Checksum" );
170
171    for my $file ( $tar->get_files ) {
172        ok( $file,              "       File object retrieved" );
173        ok( $file->validate,    "           File validates" );
174    }
175}
176
177### return error properly on corrupted archives
178### Addresses RT #44680: Improve error reporting on short corrupted archives
179{   ok( 1,                      "Testing bug 44680" );
180
181    {   ### XXX whitebox test -- resetting the error string
182        no warnings 'once';
183        $Archive::Tar::error = "";
184    }
185
186    my $src = File::Spec->catfile( qw[src short b] );
187    my $tar = $Class->new;
188
189    isa_ok( $tar, $Class,       "   Object" );
190
191
192    ### we quell the error on STDERR
193    local $Archive::Tar::WARN = 0;
194
195    ok( !$tar->read( $src ),    "   No files in the corrupted archive" );
196    like( $tar->error, qr/enough bytes/,
197                                "       Expected error reported" );
198}
199
200### bug #78030
201### tests for symlinks with relative paths
202### seen on MSWin32
203{   ok( 1,                      "Testing bug 78030" );
204		my $archname = 'tmp-symlink.tar.gz';
205		{	#build archive
206			unlink $archname if -e $archname;
207			local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
208			my $t=Archive::Tar->new;
209			my $f = $t->add_data( 'tmp/a/b/link.txt', '',
210				{
211					linkname => '../c/ori.txt',
212					type     => 2,
213				} );
214			#why doesn't it keep my wish?
215			$f->{name}   = 'tmp/a/b/link.txt';
216			$f->{prefix} = '';
217			$t->add_data( 'tmp/a/c/ori.txt', 'test case' );
218			$t->write( $archname, 1 );
219		}
220
221    { #use case 1 - in memory extraction
222			my $t=Archive::Tar->new;
223			$t->read( $archname );
224			my $r = eval{ $t->extract };
225			ok( $r && !$@,            "   In memory extraction/symlinks" );
226			ok((stat 'tmp/a/b/link.txt')[7] == 9,
227			                          "       Linked content" ) unless $r;
228			clean_78030();
229		}
230
231		{ #use case 2 - iter extraction
232		  #$DB::single = 2;
233			my $next=Archive::Tar->iter( $archname, 1 );
234			my $failed = 0;
235			#use Data::Dumper;
236			while(my $f = $next->() ){
237			#  print "\$f = ", Dumper( $f ), $/;
238				eval{ $f->extract } or $failed++;
239			}
240			ok( !$failed,             "   From disk extraction/symlinks" );
241			ok((stat 'tmp/a/b/link.txt')[7] == 9,
242			                          "       Linked content" ) unless $failed;
243		}
244
245    #remove tmp files
246		sub clean_78030{
247			unlink for ('tmp/a/c/ori.txt', 'tmp/a/b/link.txt');
248			rmdir for ('tmp/a/c', 'tmp/a/b', 'tmp/a', 'tmp');
249		}
250		clean_78030();
251		unlink $archname;
252}
253
254### bug 97748
255### retain leading '/' for absolute pathnames.
256{   ok( 1,                      "Testing bug 97748" );
257	my $path= '/absolute/path';
258	my $tar = $Class->new;
259	isa_ok( $tar, $Class,       "   Object" );
260	my $file;
261
262	ok( $file = $tar->add_data( $path, '' ),
263		"       Added $path" );
264
265	ok( $file->full_path eq $path,
266		"	Paths mismatch <" . $file->full_path . "> ne <$path>" );
267}
268
269### bug 103279
270### retain trailing whitespace on filename
271{
272  ok( 1,                      "Testing bug 103279" );
273	my $tar = $Class->new;
274	isa_ok( $tar, $Class,       "   Object" );
275	ok( $tar->add_data( 'white_space   ', '' ),
276				    "   Add file <white_space   > containing filename with trailing whitespace");
277	ok( $tar->extract(),        "	Extract filename with trailing whitespace" );
278  SKIP: {
279    skip "Windows tries to be clever", 1 if $^O eq 'MSWin32';
280	  ok( ! -e 'white_space',     "	<white_space> should not exist" );
281  }
282	ok( -e 'white_space   ',    "	<white_space   > should exist" );
283	unlink foreach ('white_space   ', 'white_space');
284}
285