2 if( $ENV{PERL_CORE} ) {
3 chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
8 BEGIN { chdir 't' if -d 't' }
10 use Test::More 'no_plan';
11 use File::Basename 'basename';
15 my $NO_UNLINK = @ARGV ? 1 : 0;
17 my $Class = 'Archive::Tar';
18 my $FileClass = $Class . '::File';
24 ### tests for @longlink behaviour on files that have a / at the end
25 ### of their shortened path, making them appear to be directories
26 { ok( 1, "Testing bug 13636" );
28 ### dont use the prefix, otherwise A::T will not use @longlink
30 local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
31 local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
33 my $dir = 'Catalyst-Helper-Controller-Scaffold-HTML-Template-0_03/' .
34 'lib/Catalyst/Helper/Controller/Scaffold/HTML/';
35 my $file = 'Template.pm';
36 my $out = $$ . '.tar';
38 ### first create the file
39 { my $tar = $Class->new;
41 isa_ok( $tar, $Class, " Object" );
42 ok( $tar->add_data( $dir.$file => $$ ),
45 ok( $tar->write($out), " File written to $out" );
48 ### then read it back in
49 { my $tar = $Class->new;
50 isa_ok( $tar, $Class, " Object" );
51 ok( $tar->read( $out ), " Read in $out again" );
53 my @files = $tar->get_files;
54 is( scalar(@files), 1, " Only 1 entry found" );
56 my $entry = shift @files;
57 ok( $entry->is_file, " Entry is a file" );
58 is( $entry->name, $dir.$file,
59 " With the proper name" );
63 unless( $NO_UNLINK ) { 1 while unlink $out }
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
70 { ok( 1, "Testing bug 14922" );
73 my $file = $$ . '.txt';
74 my $out = $$ . '.tar';
76 ### first create the file
77 { my $tar = $Class->new;
79 isa_ok( $tar, $Class, " Object" );
80 ok( $tar->add_data( $dir.$file => $$ ),
83 ok( $tar->write($out), " File written to $out" );
86 ### then read it back in
87 { my $tar = $Class->new;
88 isa_ok( $tar, $Class, " Object" );
89 ok( $tar->read( $out ), " Read in $out again" );
91 my @files = $tar->get_files;
92 is( scalar(@files), 1, " Only 1 entry found" );
94 my $entry = shift @files;
95 ok( $entry->is_file, " Entry is a file" );
96 is( $entry->full_path, $dir.$file,
97 " With the proper name" );
101 unless( $NO_UNLINK ) { 1 while unlink $out }
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" );
110 my $tar = $Class->new;
111 isa_ok( $tar, $Class, " Object" );
113 ### absolute paths are already taken care of. Only relative paths
115 my $in_file = basename($0);
116 my $out_file = '../' . $in_file . "_$$";
118 ok( $tar->add_files( $in_file ),
119 " Added '$in_file'" );
120 ok( $tar->rename( $in_file, $out_file ),
121 " Renamed to '$out_file'" );
123 ### first, test with strict extract permissions on
124 { local $Archive::Tar::INSECURE_EXTRACT_MODE = 0;
126 ### we quell the error on STDERR
127 local $Archive::Tar::WARN = 0;
128 local $Archive::Tar::WARN = 0;
130 ok( 1, " Extracting in secure mode" );
132 ok( ! $tar->extract_file( $out_file ),
133 " File not extracted" );
134 ok( ! -e $out_file, " File '$out_file' does not exist" );
136 ok( $tar->error, " Error message stored" );
137 like( $tar->error, qr/attempting to leave/,
138 " Proper violation detected" );
141 ### now disable those
142 { local $Archive::Tar::INSECURE_EXTRACT_MODE = 1;
143 ok( 1, " Extracting in insecure mode" );
145 ok( $tar->extract_file( $out_file ),
147 ok( -e $out_file, " File '$out_file' exists" );
150 unless( $NO_UNLINK ) { 1 while unlink $out_file };
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" );
159 my $src = File::Spec->catfile( qw[src header signed.tar] );
160 my $tar = $Class->new;
162 isa_ok( $tar, $Class, " Object" );
163 ok( $tar->read( $src ), " Read non-Posix file with signed Checksum" );
165 for my $file ( $tar->get_files ) {
166 ok( $file, " File object retrieved" );
167 ok( $file->validate, " File validates" );
171 ### return error properly on corrupted archives
172 ### Addresses RT #44680: Improve error reporting on short corrupted archives
173 { ok( 1, "Testing bug 44680" );
175 { ### XXX whitebox test -- resetting the error string
177 $Archive::Tar::error = "";
180 my $src = File::Spec->catfile( qw[src short b] );
181 my $tar = $Class->new;
183 isa_ok( $tar, $Class, " Object" );
186 ### we quell the error on STDERR
187 local $Archive::Tar::WARN = 0;
189 ok( !$tar->read( $src ), " No files in the corrupted archive" );
190 like( $tar->error, qr/enough bytes/,
191 " Expected error reported" );