Move Archive::Tar from ext/ to cpan/

1 files changed, 193 insertions, 0 deletions

diff --git a/cpan/Archive-Tar/t/04_resolved_issues.t b/cpan/Archive-Tar/t/04_resolved_issues.t
new file mode 100644
index 0000000000..9bb3d33f03
--- /dev/null
+++ b/cpan/Archive-Tar/t/04_resolved_issues.t
@@ -0,0 +1,193 @@
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
+    }       
+    use lib '../../..';
+}
+
+BEGIN { chdir 't' if -d 't' }
+
+use Test::More      'no_plan';
+use File::Basename  'basename';
+use strict;
+use lib '../lib';
+
+my $NO_UNLINK   = @ARGV ? 1 : 0;
+
+my $Class       = 'Archive::Tar';
+my $FileClass   = $Class . '::File';
+
+use_ok( $Class );
+use_ok( $FileClass );
+
+### bug #13636
+### tests for @longlink behaviour on files that have a / at the end
+### of their shortened path, making them appear to be directories
+{   ok( 1,                      "Testing bug 13636" );
+
+    ### dont use the prefix, otherwise A::T will not use @longlink
+    ### encoding style
+    local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
+    local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
+    
+    my $dir =   'Catalyst-Helper-Controller-Scaffold-HTML-Template-0_03/' . 
+                'lib/Catalyst/Helper/Controller/Scaffold/HTML/';
+    my $file =  'Template.pm';
+    my $out =   $$ . '.tar';
+    
+    ### first create the file
+    {   my $tar = $Class->new;
+        
+        isa_ok( $tar, $Class,   "   Object" );
+        ok( $tar->add_data( $dir.$file => $$ ),
+                                "       Added long file" );
+        
+        ok( $tar->write($out),  "       File written to $out" );
+    }
+    
+    ### then read it back in
+    {   my $tar = $Class->new;
+        isa_ok( $tar, $Class,   "   Object" );
+        ok( $tar->read( $out ), "       Read in $out again" );
+        
+        my @files = $tar->get_files;
+        is( scalar(@files), 1,  "       Only 1 entry found" );
+        
+        my $entry = shift @files;
+        ok( $entry->is_file,    "       Entry is a file" );
+        is( $entry->name, $dir.$file,
+                                "       With the proper name" );
+    }                                
+    
+    ### remove the file
+    unless( $NO_UNLINK ) { 1 while unlink $out }
+}    
+
+### bug #14922
+### There's a bug in Archive::Tar that causes a file like: foo/foo.txt 
+### to be stored in the tar file as: foo/.txt
+### XXX could not be reproduced in 1.26 -- leave test to be sure
+{   ok( 1,                      "Testing bug 14922" );
+
+    my $dir     = $$ . '/';
+    my $file    = $$ . '.txt';
+    my $out     = $$ . '.tar';
+    
+    ### first create the file
+    {   my $tar = $Class->new;
+        
+        isa_ok( $tar, $Class,   "   Object" );
+        ok( $tar->add_data( $dir.$file => $$ ),
+                                "       Added long file" );
+        
+        ok( $tar->write($out),  "       File written to $out" );
+    }
+
+    ### then read it back in
+    {   my $tar = $Class->new;
+        isa_ok( $tar, $Class,   "   Object" );
+        ok( $tar->read( $out ), "       Read in $out again" );
+        
+        my @files = $tar->get_files;
+        is( scalar(@files), 1,  "       Only 1 entry found" );
+        
+        my $entry = shift @files;
+        ok( $entry->is_file,    "       Entry is a file" );
+        is( $entry->full_path, $dir.$file,
+                                "       With the proper name" );
+    }                                
+    
+    ### remove the file
+    unless( $NO_UNLINK ) { 1 while unlink $out }
+}    
+    
+### bug #30380: directory traversal vulnerability in Archive-Tar    
+### Archive::Tar allowed files to be extracted to a dir outside
+### it's cwd(), effectively allowing you to overwrite any files
+### on the system, given the right permissions.
+{   ok( 1,                      "Testing bug 30880" );
+
+    my $tar = $Class->new;
+    isa_ok( $tar, $Class,       "   Object" );    
+    
+    ### absolute paths are already taken care of. Only relative paths
+    ### matter
+    my $in_file     = basename($0);
+    my $out_file    = '../' . $in_file . "_$$";
+    
+    ok( $tar->add_files( $in_file ), 
+                                "       Added '$in_file'" );
+    ok( $tar->rename( $in_file, $out_file ),
+                                "       Renamed to '$out_file'" );
+    
+    ### first, test with strict extract permissions on
+    {   local $Archive::Tar::INSECURE_EXTRACT_MODE = 0;
+
+        ### we quell the error on STDERR
+        local $Archive::Tar::WARN = 0;
+        local $Archive::Tar::WARN = 0;
+
+        ok( 1,                  "   Extracting in secure mode" );
+
+        ok( ! $tar->extract_file( $out_file ),
+                                "       File not extracted" );
+        ok( ! -e $out_file,     "       File '$out_file' does not exist" );
+    
+        ok( $tar->error,        "       Error message stored" );
+        like( $tar->error, qr/attempting to leave/,
+                                "           Proper violation detected" );
+    }
+    
+    ### now disable those
+    {   local $Archive::Tar::INSECURE_EXTRACT_MODE = 1;
+        ok( 1,                  "   Extracting in insecure mode" );
+    
+        ok( $tar->extract_file( $out_file ),
+                                "       File extracted" );
+        ok( -e $out_file,       "       File '$out_file' exists" );
+        
+        ### and clean up
+        unless( $NO_UNLINK ) { 1 while unlink $out_file };
+    }    
+}
+
+### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
+### like GNU tar does. See here for details:
+### http://www.gnu.org/software/tar/manual/tar.html#SEC139
+{   ok( 1,                      "Testing bug 43513" );
+    
+    my $src = File::Spec->catfile( qw[src header signed.tar] );
+    my $tar = $Class->new;
+    
+    isa_ok( $tar, $Class,       "   Object" );
+    ok( $tar->read( $src ),     "   Read non-Posix file with signed Checksum" );
+        
+    for my $file ( $tar->get_files ) {
+        ok( $file,              "       File object retrieved" );
+        ok( $file->validate,    "           File validates" );
+    }        
+}
+
+### return error properly on corrupted archives
+### Addresses RT #44680: Improve error reporting on short corrupted archives
+{   ok( 1,                      "Testing bug 44680" );
+
+    {   ### XXX whitebox test -- resetting the error string
+        no warnings 'once'; 
+        $Archive::Tar::error = "";
+    }
+
+    my $src = File::Spec->catfile( qw[src short b] );
+    my $tar = $Class->new;
+    
+    isa_ok( $tar, $Class,       "   Object" );
+    
+    
+    ### we quell the error on STDERR
+    local $Archive::Tar::WARN = 0;
+
+    ok( !$tar->read( $src ),    "   No files in the corrupted archive" );
+    like( $tar->error, qr/enough bytes/,
+                                "       Expected error reported" );
+}
+