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
160{   ok( 1,                      "Testing bug 43513" );
161
162    my $src = File::Spec->catfile( qw[src header signed.tar] );
163    my $tar = $Class->new;
164
165    isa_ok( $tar, $Class,       "   Object" );
166    ok( $tar->read( $src ),     "   Read non-Posix file with signed Checksum" );
167
168    for my $file ( $tar->get_files ) {
169        ok( $file,              "       File object retrieved" );
170        ok( $file->validate,    "           File validates" );
171    }
172}
173
174### return error properly on corrupted archives
175### Addresses RT #44680: Improve error reporting on short corrupted archives
176{   ok( 1,                      "Testing bug 44680" );
177
178    {   ### XXX whitebox test -- resetting the error string
179        no warnings 'once';
180        $Archive::Tar::error = "";
181    }
182
183    my $src = File::Spec->catfile( qw[src short b] );
184    my $tar = $Class->new;
185
186    isa_ok( $tar, $Class,       "   Object" );
187
188
189    ### we quell the error on STDERR
190    local $Archive::Tar::WARN = 0;
191
192    ok( !$tar->read( $src ),    "   No files in the corrupted archive" );
193    like( $tar->error, qr/enough bytes/,
194                                "       Expected error reported" );
195}
196
197### bug #78030
198### tests for symlinks with relative paths
199### seen on MSWin32
200{   ok( 1,                      "Testing bug 78030" );
201		my $archname = 'tmp-symlink.tar.gz';
202		{	#build archive
203			unlink $archname if -e $archname;
204			local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
205			my $t=Archive::Tar->new;
206			my $f = $t->add_data( 'tmp/a/b/link.txt', '',
207				{
208					linkname => '../c/ori.txt',
209					type     => 2,
210				} );
211			#why doesn't it keep my wish?
212			$f->{name}   = 'tmp/a/b/link.txt';
213			$f->{prefix} = '';
214			$t->add_data( 'tmp/a/c/ori.txt', 'test case' );
215			$t->write( $archname, 1 );
216		}
217
218    { #use case 1 - in memory extraction
219			my $t=Archive::Tar->new;
220			$t->read( $archname );
221			my $r = eval{ $t->extract };
222			ok( $r && !$@,            "   In memory extraction/symlinks" );
223			ok((stat 'tmp/a/b/link.txt')[7] == 9,
224			                          "       Linked content" ) unless $r;
225			clean_78030();
226		}
227
228		{ #use case 2 - iter extraction
229		  #$DB::single = 2;
230			my $next=Archive::Tar->iter( $archname, 1 );
231			my $failed = 0;
232			#use Data::Dumper;
233			while(my $f = $next->() ){
234			#  print "\$f = ", Dumper( $f ), $/;
235				eval{ $f->extract } or $failed++;
236			}
237			ok( !$failed,             "   From disk extraction/symlinks" );
238			ok((stat 'tmp/a/b/link.txt')[7] == 9,
239			                          "       Linked content" ) unless $failed;
240		}
241
242    #remove tmp files
243		sub clean_78030{
244			unlink for ('tmp/a/c/ori.txt', 'tmp/a/b/link.txt');
245			rmdir for ('tmp/a/c', 'tmp/a/b', 'tmp/a', 'tmp');
246		}
247		clean_78030();
248		unlink $archname;
249}
250