From: Jos I. Boumans <kane@dwim.org>
Date: Mon, 13 Oct 2008 15:40:22 +0000 (+0200)
Subject: Update Archive::Tar to 1.40
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f56953582ae4af437649f099e3968dfe2c4718c9;p=p5sagit%2Fp5-mst-13.2.git

Update Archive::Tar to 1.40
From: "Jos I. Boumans" <jos@dwim.org>
Message-Id: <D694D518-2404-4476-B578-A5B95F89660A@dwim.org>

...minus the Pod tests that we've been regularly removing.

p4raw-id: //depot/perl@34486
---

diff --git a/lib/Archive/Tar.pm b/lib/Archive/Tar.pm
index 1590ec7..ff04a27 100644
--- a/lib/Archive/Tar.pm
+++ b/lib/Archive/Tar.pm
@@ -31,7 +31,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
 $DEBUG                  = 0;
 $WARN                   = 1;
 $FOLLOW_SYMLINK         = 0;
-$VERSION                = "1.39_04";
+$VERSION                = "1.40";
 $CHOWN                  = 1;
 $CHMOD                  = 1;
 $DO_NOT_USE_PREFIX      = 0;
@@ -1471,37 +1471,6 @@ sub setcwd {
     $self->{cwd} = $cwd;
 }
 
-=head2 $bool = $tar->has_io_string
-
-Returns true if we currently have C<IO::String> support loaded.
-
-Either C<IO::String> or C<perlio> support is needed to support writing 
-stringified archives. Currently, C<perlio> is the preferred method, if
-available.
-
-See the C<GLOBAL VARIABLES> section to see how to change this preference.
-
-=cut
-
-sub has_io_string { return $HAS_IO_STRING; }
-
-=head2 $bool = $tar->has_perlio
-
-Returns true if we currently have C<perlio> support loaded.
-
-This requires C<perl-5.8> or higher, compiled with C<perlio> 
-
-Either C<IO::String> or C<perlio> support is needed to support writing 
-stringified archives. Currently, C<perlio> is the preferred method, if
-available.
-
-See the C<GLOBAL VARIABLES> section to see how to change this preference.
-
-=cut
-
-sub has_perlio { return $HAS_PERLIO; }
-
-
 =head1 Class Methods
 
 =head2 Archive::Tar->create_archive($file, $compressed, @filelist)
@@ -1667,6 +1636,52 @@ sub extract_archive {
     return $tar->read( $file, $gzip, { extract => 1 } );
 }
 
+=head2 $bool = Archive::Tar->has_io_string
+
+Returns true if we currently have C<IO::String> support loaded.
+
+Either C<IO::String> or C<perlio> support is needed to support writing 
+stringified archives. Currently, C<perlio> is the preferred method, if
+available.
+
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
+
+=cut
+
+sub has_io_string { return $HAS_IO_STRING; }
+
+=head2 $bool = Archive::Tar->has_perlio
+
+Returns true if we currently have C<perlio> support loaded.
+
+This requires C<perl-5.8> or higher, compiled with C<perlio> 
+
+Either C<IO::String> or C<perlio> support is needed to support writing 
+stringified archives. Currently, C<perlio> is the preferred method, if
+available.
+
+See the C<GLOBAL VARIABLES> section to see how to change this preference.
+
+=cut
+
+sub has_perlio { return $HAS_PERLIO; }
+
+=head2 $bool = Archive::Tar->has_zlib_support
+
+Returns true if C<Archive::Tar> can extract C<zlib> compressed archives
+
+=cut
+
+sub has_zlib_support { return ZLIB }
+
+=head2 $bool = Archive::Tar->has_bzip2_support
+
+Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives
+
+=cut
+
+sub has_bzip2_support { return BZIP }
+
 =head2 Archive::Tar->can_handle_compressed_files
 
 A simple checking routine, which will return true if C<Archive::Tar>
@@ -2045,7 +2060,7 @@ and especially Andrew Savige for their help and suggestions.
 
 =head1 COPYRIGHT
 
-This module is copyright (c) 2002 - 2007 Jos Boumans 
+This module is copyright (c) 2002 - 2008 Jos Boumans 
 E<lt>kane@cpan.orgE<gt>. All rights reserved.
 
 This library is free software; you may redistribute and/or modify 
diff --git a/lib/Archive/Tar/File.pm b/lib/Archive/Tar/File.pm
index d5c2fee..ead236f 100644
--- a/lib/Archive/Tar/File.pm
+++ b/lib/Archive/Tar/File.pm
@@ -393,6 +393,9 @@ sub _prefix_and_file {
     ### if it's a directory, then $file might be empty
     $file = pop @dirs if $self->is_dir and not length $file;
 
+    ### splitting ../ gives you the relative path in native syntax
+    map { $_ = '..' if $_  eq '-' } @dirs if ON_VMS;
+
     my $prefix = File::Spec::Unix->catdir(
                         grep { length } $vol, @dirs
                     );
diff --git a/lib/Archive/Tar/t/02_methods.t b/lib/Archive/Tar/t/02_methods.t
index 7354e6c..cd633ab 100644
--- a/lib/Archive/Tar/t/02_methods.t
+++ b/lib/Archive/Tar/t/02_methods.t
@@ -21,9 +21,14 @@ use File::Spec::Unix    ();
 use File::Basename      ();
 use Data::Dumper;
 
-use Archive::Tar;
+### need the constants at compile time;
 use Archive::Tar::Constant;
 
+my $Class   = 'Archive::Tar';
+use_ok( $Class );
+
+
+
 ### XXX TODO:
 ### * change to fullname
 ### * add tests for global variables
@@ -72,20 +77,15 @@ if ($TOO_LONG) {
 }
 
 my @ROOT        = grep { length }   'src', $TOO_LONG ? 'short' : 'long';
-
-my $ZLIB        = eval { require IO::Zlib;
-                         require IO::Compress::Bzip2; 1 } ? 1 : 0;
-my $BZIP        = eval { require IO::Uncompress::Bunzip2;
-                         require IO::Compress::Bzip2; 1 } ? 1 : 0;
-
 my $NO_UNLINK   = $ARGV[0] ? 1 : 0;
 
-### enable debugging?
-$Archive::Tar::DEBUG = 1 if $ARGV[1];
+### enable debugging? 
+### pesky warnings
+$Archive::Tar::DEBUG = $Archive::Tar::DEBUG = 1 if $ARGV[1];
 
 ### tests for binary and x/x files
-my $TARBIN      = Archive::Tar->new;
-my $TARX        = Archive::Tar->new;
+my $TARBIN      = $Class->new;
+my $TARX        = $Class->new;
 
 ### paths to a .tar and .tgz file to use for tests
 my $TAR_FILE        = File::Spec->catfile( @ROOT, 'bar.tar' );
@@ -102,15 +102,16 @@ chmod 0644, $COMPRESS_FILE;
 
 ### done setting up environment ###
 
+### check for zlib/bzip2 support
+{   for my $meth ( qw[has_zlib_support has_bzip2_support] ) {
+        can_ok( $Class, $meth );
+    }
+}    
 
-### did we probe IO::Zlib support ok? ###
-{   is( Archive::Tar->can_handle_compressed_files, $ZLIB,
-                                    "Proper IO::Zlib support detected" );
-}
 
 
 ### tar error tests
-{   my $tar     = Archive::Tar->new;
+{   my $tar     = $Class->new;
 
     ok( $tar,                       "Object created" );
     isa_ok( $tar,                   'Archive::Tar');
@@ -139,7 +140,7 @@ chmod 0644, $COMPRESS_FILE;
 
     ### check if ->error eq $error
     is( $tar->error, $Archive::Tar::error,
-                                    '$error matches error() method' );
+                                    "Error '$Archive::Tar::error' matches $Class->error method" );
                      
     ### check that 'contains_file' doesn't warn about missing files.                     
     {   ### turn on warnings in general!
@@ -156,13 +157,13 @@ chmod 0644, $COMPRESS_FILE;
 
 ### read tests ###
 {   my @to_try = ($TAR_FILE);
-    push @to_try, $TGZ_FILE if $ZLIB;
-    push @to_try, $TBZ_FILE if $BZIP;
+    push @to_try, $TGZ_FILE if $Class->has_zlib_support;
+    push @to_try, $TBZ_FILE if $Class->has_bzip2_support;
 
     for my $type( @to_try ) {
 
         ### normal tar + gz compressed file
-        my $tar             = Archive::Tar->new;
+        my $tar             = $Class->new;
 
         ### check we got the object
         ok( $tar,                       "Object created" );
@@ -202,7 +203,7 @@ chmod 0644, $COMPRESS_FILE;
 
 
         ### list_archive test
-        {   my @list    = Archive::Tar->list_archive( $type );
+        {   my @list    = $Class->list_archive( $type );
             my $cnt     = scalar @list;
             my $expect  = scalar __PACKAGE__->get_expect();
 
@@ -225,7 +226,7 @@ chmod 0644, $COMPRESS_FILE;
 ### add files tests ###
 {   my @add     = map { File::Spec->catfile( @ROOT, @$_ ) } ['b'];
     my @addunix = map { File::Spec::Unix->catfile( @ROOT, @$_ ) } ['b'];
-    my $tar     = Archive::Tar->new;
+    my $tar     = $Class->new;
 
     ### check we got the object
     ok( $tar,                       "Object created" );
@@ -258,7 +259,7 @@ chmod 0644, $COMPRESS_FILE;
 
     ### check adding files doesn't conflict with a secondary archive
     ### old A::T bug, we should keep testing for it
-    {   my $tar2    = Archive::Tar->new;
+    {   my $tar2    = $Class->new;
         my @added   = $tar2->add_files( $COMPRESS_FILE );
         my @count   = $tar2->list_files;
 
@@ -279,7 +280,7 @@ chmod 0644, $COMPRESS_FILE;
 {
     {   ### standard data ###
         my @to_add  = ( 'a', 'aaaaa' );
-        my $tar     = Archive::Tar->new;
+        my $tar     = $Class->new;
 
         ### check we got the object
         ok( $tar,                   "Object created" );
@@ -324,7 +325,7 @@ chmod 0644, $COMPRESS_FILE;
 }
 
 ### rename/replace_content tests ###
-{   my $tar     = Archive::Tar->new;
+{   my $tar     = $Class->new;
     my $from    = 'c';
     my $to      = 'e';
 
@@ -356,7 +357,7 @@ chmod 0644, $COMPRESS_FILE;
 
 ### remove tests ###
 {   my $remove  = 'c';
-    my $tar     = Archive::Tar->new;
+    my $tar     = $Class->new;
 
     ok( $tar->read( $TAR_FILE ),    "Read in '$TAR_FILE'" );
 
@@ -370,12 +371,14 @@ chmod 0644, $COMPRESS_FILE;
 }
 
 ### write + read + extract tests ###
-SKIP: {
+SKIP: {                             ### pesky warnings
     skip('no IO::String', 326) if   !$Archive::Tar::HAS_PERLIO && 
+                                    !$Archive::Tar::HAS_PERLIO && 
+                                    !$Archive::Tar::HAS_IO_STRING &&
                                     !$Archive::Tar::HAS_IO_STRING;
                                     
-    my $tar = Archive::Tar->new;
-    my $new = Archive::Tar->new;
+    my $tar = $Class->new;
+    my $new = $Class->new;
     ok( $tar->read( $TAR_FILE ),    "Read in '$TAR_FILE'" );
 
     for my $aref (  [$tar,    \@EXPECT_NORMAL],
@@ -415,12 +418,12 @@ SKIP: {
 
 
             {   ### create_archive()
-                ok( Archive::Tar->create_archive( $out, 0, $COMPRESS_FILE ),
+                ok( $Class->create_archive( $out, 0, $COMPRESS_FILE ),
                                     "Wrote tarfile using 'create_archive'" );
                 check_tar_file( $out );
 
                 ### now extract it again
-                ok( Archive::Tar->extract_archive( $out ),
+                ok( $Class->extract_archive( $out ),
                                     "Extracted file using 'extract_archive'");
                 rm( $out ) unless $NO_UNLINK;
             }
@@ -428,8 +431,8 @@ SKIP: {
 
         ## write tgz tests
         {   my @out;
-            push @out, [ $OUT_TGZ_FILE => 1             ] if $ZLIB;
-            push @out, [ $OUT_TBZ_FILE => COMPRESS_BZIP ] if $BZIP;
+            push @out, [ $OUT_TGZ_FILE => 1             ] if $Class->has_zlib_support;
+            push @out, [ $OUT_TBZ_FILE => COMPRESS_BZIP ] if $Class->has_bzip2_support;
         
             for my $entry ( @out ) {
 
@@ -456,12 +459,12 @@ SKIP: {
                 }
 
                 {   ### create_archive()
-                    ok( Archive::Tar->create_archive( $out, $compression, $COMPRESS_FILE ),
+                    ok( $Class->create_archive( $out, $compression, $COMPRESS_FILE ),
                                     "Wrote '$out' using 'create_archive'" );
                     check_compressed_file( $out );
 
                     ### now extract it again
-                    ok( Archive::Tar->extract_archive( $out, $compression ),
+                    ok( $Class->extract_archive( $out, $compression ),
                                     "Extracted file using 'extract_archive'");
                     rm( $out ) unless $NO_UNLINK;
                 }
@@ -472,7 +475,7 @@ SKIP: {
 
 
 ### limited read + extract tests ###
-{   my $tar     = Archive::Tar->new;
+{   my $tar     = $Class->new;
     my @files   = $tar->read( $TAR_FILE, 0, { limit => 1 } );
     my $obj     = $files[0];
 
@@ -513,7 +516,7 @@ SKIP: {
 
 
 ### clear tests ###
-{   my $tar     = Archive::Tar->new;
+{   my $tar     = $Class->new;
     my @files   = $tar->read( $TAR_FILE );
 
     my $cnt = $tar->list_files();
@@ -525,7 +528,7 @@ SKIP: {
 }
 
 ### $DO_NOT_USE_PREFIX tests
-{   my $tar     = Archive::Tar->new;
+{   my $tar     = $Class->new;
 
 
     ### first write a tar file without prefix
@@ -541,7 +544,10 @@ SKIP: {
         is( $obj->prefix, $dir,     "   Prefix set to '$dir'" );
 
         ### write the tar file without a prefix in it
+        ### pesky warnings
         local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
+        local $Archive::Tar::DO_NOT_USE_PREFIX = 1;
+
         ok( $tar->write( $OUT_TAR_FILE ),
                                     "   Tar file written" );
 
diff --git a/lib/Archive/Tar/t/04_resolved_issues.t b/lib/Archive/Tar/t/04_resolved_issues.t
index 8d17923..eba271f 100644
--- a/lib/Archive/Tar/t/04_resolved_issues.t
+++ b/lib/Archive/Tar/t/04_resolved_issues.t
@@ -113,7 +113,7 @@ use_ok( $FileClass );
     ### absolute paths are already taken care of. Only relative paths
     ### matter
     my $in_file     = basename($0);
-    my $out_file    = '../' . $in_file . ".$$";
+    my $out_file    = '../' . $in_file . "_$$";
     
     ok( $tar->add_files( $in_file ), 
                                 "       Added '$in_file'" );
@@ -121,7 +121,6 @@ use_ok( $FileClass );
                                 "       Renamed to '$out_file'" );
     
     ### first, test with strict extract permissions on
-TODO:
     {   local $Archive::Tar::INSECURE_EXTRACT_MODE = 0;
 
         ### we quell the error on STDERR
@@ -135,20 +134,14 @@ TODO:
         ok( ! -e $out_file,     "       File '$out_file' does not exist" );
     
         ok( $tar->error,        "       Error message stored" );
-
-        local $TODO = 'Exposed unrelated filespec handling bugs on VMS' if $^O eq 'VMS';
-
         like( $tar->error, qr/attempting to leave/,
                                 "           Proper violation detected" );
     }
     
     ### now disable those
-TODO:
     {   local $Archive::Tar::INSECURE_EXTRACT_MODE = 1;
         ok( 1,                  "   Extracting in insecure mode" );
     
-        local $TODO = 'Exposed unrelated filespec handling bugs on VMS' if $^O eq 'VMS';
-
         ok( $tar->extract_file( $out_file ),
                                 "       File extracted" );
         ok( -e $out_file,       "       File '$out_file' exists" );
diff --git a/lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar.packed b/lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar.packed
index 24ef956..bd8d8a4 100644
--- a/lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar.packed
+++ b/lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar.packed
@@ -4,13 +4,13 @@ is included in the Perl distribution.
 
 To unpack this file use the following command:
 
-     uupacktool.pl -u linktest_missing_dir.tar.packed linktest_missing_dir.tar
+     uupacktool.pl -u lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar.packed lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar
 
 To recreate it use the following command:
 
-     uupacktool.pl -p linktest_missing_dir.tar linktest_missing_dir.tar.packed
+     uupacktool.pl -p lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar lib/Archive/Tar/t/src/linktest/linktest_missing_dir.tar.packed
 
-Created at Wed Oct  1 17:21:49 2008
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M;&EN:W1E<W0O;&EN:P``````````````````````````````````````````
diff --git a/lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar.packed b/lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar.packed
index 671146e..6b6f09e 100644
--- a/lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar.packed
+++ b/lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar.packed
@@ -4,13 +4,13 @@ is included in the Perl distribution.
 
 To unpack this file use the following command:
 
-     uupacktool.pl -u linktest_with_dir.tar.packed linktest_with_dir.tar
+     uupacktool.pl -u lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar.packed lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar
 
 To recreate it use the following command:
 
-     uupacktool.pl -p linktest_with_dir.tar linktest_with_dir.tar.packed
+     uupacktool.pl -p lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar lib/Archive/Tar/t/src/linktest/linktest_with_dir.tar.packed
 
-Created at Wed Oct  1 17:22:07 2008
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M;&EN:W1E<W0O;W)I9R\`````````````````````````````````````````
diff --git a/lib/Archive/Tar/t/src/long/bar.tar.packed b/lib/Archive/Tar/t/src/long/bar.tar.packed
index 85e4706..045e5a3 100644
--- a/lib/Archive/Tar/t/src/long/bar.tar.packed
+++ b/lib/Archive/Tar/t/src/long/bar.tar.packed
@@ -10,7 +10,7 @@ To recreate it use the following command:
 
      uupacktool.pl -p lib/Archive/Tar/t/src/long/bar.tar lib/Archive/Tar/t/src/long/bar.tar.packed
 
-Created at Sun Sep 16 10:56:54 2007
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M8P``````````````````````````````````````````````````````````
diff --git a/lib/Archive/Tar/t/src/long/foo.tbz.packed b/lib/Archive/Tar/t/src/long/foo.tbz.packed
index 96e9788..d43f7b4 100644
--- a/lib/Archive/Tar/t/src/long/foo.tbz.packed
+++ b/lib/Archive/Tar/t/src/long/foo.tbz.packed
@@ -4,13 +4,13 @@ is included in the Perl distribution.
 
 To unpack this file use the following command:
 
-     uupacktool.pl -u foo.tbz.packed foo.tbz
+     uupacktool.pl -u lib/Archive/Tar/t/src/long/foo.tbz.packed lib/Archive/Tar/t/src/long/foo.tbz
 
 To recreate it use the following command:
 
-     uupacktool.pl -p foo.tbz foo.tbz.packed
+     uupacktool.pl -p lib/Archive/Tar/t/src/long/foo.tbz lib/Archive/Tar/t/src/long/foo.tbz.packed
 
-Created at Wed Oct  1 17:23:46 2008
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M0EIH.3%!62936=873NT``9C_A._0`DA``_^`0`0)`._OGJ```40(,`%X9`8`
diff --git a/lib/Archive/Tar/t/src/long/foo.tgz.packed b/lib/Archive/Tar/t/src/long/foo.tgz.packed
index f7b9adc..c011d05 100644
--- a/lib/Archive/Tar/t/src/long/foo.tgz.packed
+++ b/lib/Archive/Tar/t/src/long/foo.tgz.packed
@@ -10,7 +10,7 @@ To recreate it use the following command:
 
      uupacktool.pl -p lib/Archive/Tar/t/src/long/foo.tgz lib/Archive/Tar/t/src/long/foo.tgz.packed
 
-Created at Sun Sep 16 10:56:54 2007
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M'XL(`````````^W72VZ#,!`&8*]S"BY`F,$/MCT`ET")25`<D"A1Q.UKR*M1
diff --git a/lib/Archive/Tar/t/src/short/bar.tar.packed b/lib/Archive/Tar/t/src/short/bar.tar.packed
index 09c7b88..3afd1b6 100644
--- a/lib/Archive/Tar/t/src/short/bar.tar.packed
+++ b/lib/Archive/Tar/t/src/short/bar.tar.packed
@@ -10,7 +10,7 @@ To recreate it use the following command:
 
      uupacktool.pl -p lib/Archive/Tar/t/src/short/bar.tar lib/Archive/Tar/t/src/short/bar.tar.packed
 
-Created at Sun Sep 16 10:56:55 2007
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M8P``````````````````````````````````````````````````````````
diff --git a/lib/Archive/Tar/t/src/short/foo.tbz.packed b/lib/Archive/Tar/t/src/short/foo.tbz.packed
index 3e6752d..ba48a0f 100644
--- a/lib/Archive/Tar/t/src/short/foo.tbz.packed
+++ b/lib/Archive/Tar/t/src/short/foo.tbz.packed
@@ -4,13 +4,13 @@ is included in the Perl distribution.
 
 To unpack this file use the following command:
 
-     uupacktool.pl -u foo.tbz.packed foo.tbz
+     uupacktool.pl -u lib/Archive/Tar/t/src/short/foo.tbz.packed lib/Archive/Tar/t/src/short/foo.tbz
 
 To recreate it use the following command:
 
-     uupacktool.pl -p foo.tbz foo.tbz.packed
+     uupacktool.pl -p lib/Archive/Tar/t/src/short/foo.tbz lib/Archive/Tar/t/src/short/foo.tbz.packed
 
-Created at Wed Oct  1 17:24:13 2008
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M0EIH.3%!62936>GH,8X``)O[A.90`D!``'^```#O*1X```%`""``E(*JGDA#
diff --git a/lib/Archive/Tar/t/src/short/foo.tgz.packed b/lib/Archive/Tar/t/src/short/foo.tgz.packed
index 45524b0..66e8001 100644
--- a/lib/Archive/Tar/t/src/short/foo.tgz.packed
+++ b/lib/Archive/Tar/t/src/short/foo.tgz.packed
@@ -10,7 +10,7 @@ To recreate it use the following command:
 
      uupacktool.pl -p lib/Archive/Tar/t/src/short/foo.tgz lib/Archive/Tar/t/src/short/foo.tgz.packed
 
-Created at Sun Sep 16 10:56:55 2007
+Created at Mon Oct 13 15:18:08 2008
 #########################################################################
 __UU__
 M'XL(`````````^W300K",!"%X5GW%#G"3-JFYREJ080NJKU_A^A"$.RJ(\+_