From f56953582ae4af437649f099e3968dfe2c4718c9 Mon Sep 17 00:00:00 2001 From: "Jos I. Boumans" Date: Mon, 13 Oct 2008 17:40:22 +0200 Subject: [PATCH] Update Archive::Tar to 1.40 From: "Jos I. Boumans" Message-Id: ...minus the Pod tests that we've been regularly removing. p4raw-id: //depot/perl@34486 --- lib/Archive/Tar.pm | 81 ++++++++++++--------- lib/Archive/Tar/File.pm | 3 + lib/Archive/Tar/t/02_methods.t | 82 ++++++++++++---------- lib/Archive/Tar/t/04_resolved_issues.t | 9 +-- .../t/src/linktest/linktest_missing_dir.tar.packed | 6 +- .../t/src/linktest/linktest_with_dir.tar.packed | 6 +- lib/Archive/Tar/t/src/long/bar.tar.packed | 2 +- lib/Archive/Tar/t/src/long/foo.tbz.packed | 6 +- lib/Archive/Tar/t/src/long/foo.tgz.packed | 2 +- lib/Archive/Tar/t/src/short/bar.tar.packed | 2 +- lib/Archive/Tar/t/src/short/foo.tbz.packed | 6 +- lib/Archive/Tar/t/src/short/foo.tgz.packed | 2 +- 12 files changed, 112 insertions(+), 95 deletions(-) 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 support loaded. - -Either C or C support is needed to support writing -stringified archives. Currently, C is the preferred method, if -available. - -See the C 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 support loaded. - -This requires C or higher, compiled with C - -Either C or C support is needed to support writing -stringified archives. Currently, C is the preferred method, if -available. - -See the C 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 support loaded. + +Either C or C support is needed to support writing +stringified archives. Currently, C is the preferred method, if +available. + +See the C 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 support loaded. + +This requires C or higher, compiled with C + +Either C or C support is needed to support writing +stringified archives. Currently, C is the preferred method, if +available. + +See the C 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 can extract C compressed archives + +=cut + +sub has_zlib_support { return ZLIB } + +=head2 $bool = Archive::Tar->has_bzip2_support + +Returns true if C can extract C 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 @@ -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 Ekane@cpan.orgE. 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:W1EGH,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(\+_ -- 2.7.4