ext/Archive-Tar/t/04_resolved_issues.t

   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
  10 use Test::More      'no_plan';
  11 use File::Basename  'basename';
  12 use strict;
  13 use lib '../lib';
  14
  15 my $NO_UNLINK   = @ARGV ? 1 : 0;
  16
  17 my $Class       = 'Archive::Tar';
  18 my $FileClass   = $Class . '::File';
  19
  20 use_ok( $Class );
  21 use_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