1BEGIN { 2 if( $ENV{PERL_CORE} ) { 3 chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar'; 4 } 5 use lib '../../..'; 6} 7 8BEGIN { chdir 't' if -d 't' } 9 10use Test::More 'no_plan'; 11use File::Basename 'basename'; 12use strict; 13use lib '../lib'; 14 15my $NO_UNLINK = @ARGV ? 1 : 0; 16 17my $Class = 'Archive::Tar'; 18my $FileClass = $Class . '::File'; 19 20use_ok( $Class ); 21use_ok( $FileClass ); 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 26{ ok( 1, "Testing bug 13636" ); 27 28 ### dont use the prefix, otherwise A::T will not use @longlink 29 ### encoding style 30 local $Archive::Tar::DO_NOT_USE_PREFIX = 1; 31 local $Archive::Tar::DO_NOT_USE_PREFIX = 1; 32 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'; 37 38 ### first create the file 39 { my $tar = $Class->new; 40 41 isa_ok( $tar, $Class, " Object" ); 42 ok( $tar->add_data( $dir.$file => $$ ), 43 " Added long file" ); 44 45 ok( $tar->write($out), " File written to $out" ); 46 } 47 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" ); 52 53 my @files = $tar->get_files; 54 is( scalar(@files), 1, " Only 1 entry found" ); 55 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" ); 60 } 61 62 ### remove the file 63 unless( $NO_UNLINK ) { 1 while unlink $out } 64} 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 70{ ok( 1, "Testing bug 14922" ); 71 72 my $dir = $$ . '/'; 73 my $file = $$ . '.txt'; 74 my $out = $$ . '.tar'; 75 76 ### first create the file 77 { my $tar = $Class->new; 78 79 isa_ok( $tar, $Class, " Object" ); 80 ok( $tar->add_data( $dir.$file => $$ ), 81 " Added long file" ); 82 83 ok( $tar->write($out), " File written to $out" ); 84 } 85 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" ); 90 91 my @files = $tar->get_files; 92 is( scalar(@files), 1, " Only 1 entry found" ); 93 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" ); 98 } 99 100 ### remove the file 101 unless( $NO_UNLINK ) { 1 while unlink $out } 102} 103 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); 116 my $out_file = '../' . $in_file . "_$$"; 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 } 140 141 ### now disable those 142 { local $Archive::Tar::INSECURE_EXTRACT_MODE = 1; 143 ok( 1, " Extracting in insecure mode" ); 144 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 } 152} 153 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 } 169} 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 194