1BEGIN { chdir 't' if -d 't' } 2 3use Test::More; 4use strict; 5use lib '../lib'; 6 7plan skip_all => "Files contain an alien character set" if ord "A" != 65; 8 9use File::Spec (); 10use File::Temp qw( tempfile ); 11 12use Archive::Tar; 13 14BEGIN { 15 eval { require IPC::Cmd; }; 16 unless ( $@ ) { 17 *can_run = \&IPC::Cmd::can_run; 18 } 19 else { 20 *can_run = sub { 21 require ExtUtils::MakeMaker; 22 my $cmd = shift; 23 my $_cmd = $cmd; 24 return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 25 require Config; 26 for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 27 next if $dir eq ''; 28 require File::Spec; 29 my $abs = File::Spec->catfile($dir, $cmd, $Config::Config{exe_ext}); 30 return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 31 } 32 return; 33 }; 34 } 35} 36 37# Identify tarballs available for testing 38# Some contain only files 39# Others contain both files and directories 40 41my @file_only_archives = ( 42 [qw( src short bar.tar )], 43); 44push @file_only_archives, [qw( src short foo.tgz )] 45 if Archive::Tar->has_zlib_support; 46push @file_only_archives, [qw( src short foo.tbz )] 47 if Archive::Tar->has_bzip2_support; 48push @file_only_archives, [qw( src short foo.txz )] 49 if Archive::Tar->has_xz_support; 50 51@file_only_archives = map File::Spec->catfile(@$_), @file_only_archives; 52 53 54my @file_and_directory_archives = ( 55 [qw( src long bar.tar )], 56 [qw( src linktest linktest_with_dir.tar )], 57); 58push @file_and_directory_archives, [qw( src long foo.tgz )] 59 if Archive::Tar->has_zlib_support; 60push @file_and_directory_archives, [qw( src long foo.tbz )] 61 if Archive::Tar->has_bzip2_support; 62 63@file_and_directory_archives = map File::Spec->catfile(@$_), @file_and_directory_archives; 64 65my @archives = (@file_only_archives, @file_and_directory_archives); 66plan tests => scalar @archives; 67 68# roundtrip test 69for my $archive_name (@file_only_archives) { 70 71 # create a new tarball with the same content as the old one 72 my $old = Archive::Tar->new($archive_name); 73 my $new = Archive::Tar->new(); 74 $new->add_files( $old->get_files ); 75 76 # save differently if compressed 77 my $ext = ( split /\./, $archive_name )[-1]; 78 my @compress = 79 $ext =~ /t?gz$/ ? (COMPRESS_GZIP) 80 : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP) 81 : $ext =~ /(t?xz)$/ ? (COMPRESS_XZ) 82 : (); 83 84 my ( $fh, $filename ) = tempfile( UNLINK => 1 ); 85 $new->write( $filename, @compress ); 86 87 # read the archive again from disk 88 $new = Archive::Tar->new($filename); 89 90 # compare list of files 91 is_deeply( 92 [ $new->list_files ], 93 [ $old->list_files ], 94 "$archive_name roundtrip on file names" 95 ); 96} 97 98# rt.cpan.org #115160 99# t/09_roundtrip.t was added with all 7 then existent tests marked TODO even 100# though 3 of them were passing. So what was really TODO was to figure out 101# why the other 4 were not passing. 102# 103# It turns out that the tests are expecting behavior which, though on the face 104# of it plausible and desirable, is not Archive::Tar::write()'s current 105# behavior. write() -- which is used in the unit tests in this file -- relies 106# on Archive::Tar::File::_prefix_and_file(). Since at least 2006 this helper 107# method has had the effect of removing a trailing slash from archive entries 108# which are in fact directories. So we have to adjust our expectations for 109# what we'll get when round-tripping on an archive which contains one or more 110# entries for directories. 111 112# Divine whether the external tar command can do gzip/bzip2 113# from the output of 'tar --help'. 114# GNU tar: 115# ... 116# -j, --bzip2 filter the archive through bzip2 117# -z, --gzip, --gunzip, --ungzip filter the archive through gzip 118# 119# BSD tar: 120# .... 121# -z, -j, -J, --lzma Compress archive with gzip/bzip2/xz/lzma 122# ... 123# 124# BSD tar (older) 125# tar: unknown option -- help 126# usage: tar [-]{crtux}[-befhjklmopqvwzHOPSXZ014578] [archive] [blocksize] 127# ... 128 129sub can_tar_gzip { 130 my ($tar_help) = @_; 131 return 0 unless can_run('gzip'); 132 $tar_help =~ /-z, --gzip|-z,.+gzip/; 133} 134 135sub can_tar_bzip2 { 136 my ($tar_help) = @_; 137 return 0 unless can_run('bzip2'); 138 $tar_help =~ /-j, --bzip2|-j,+bzip2/; 139} 140 141# The name of the external tar executable. 142my $TAR_EXE; 143 144SKIP: { 145 my $skip_count = scalar @file_and_directory_archives; 146 147 # The preferred 'tar' command may not be called tar,: 148 # especially on legacy unix systems. Test first various 149 # alternative names that are more likely to work for us. 150 # 151 my @TRY_TAR = qw[gtar gnutar bsdtar tar]; 152 my $can_tar_gzip; 153 my $can_tar_bzip2; 154 for my $tar_try (@TRY_TAR) { 155 if (can_run($tar_try)) { 156 print "# Found tar executable '$tar_try'\n"; 157 my $tar_help = qx{$tar_try --help 2>&1}; 158 $can_tar_gzip = can_tar_gzip($tar_help); 159 $can_tar_bzip2 = can_tar_bzip2($tar_help); 160 printf "# can_tar_gzip = %d\n", $can_tar_gzip; 161 printf "# can_tar_bzip2 = %d\n", $can_tar_bzip2; 162 # We could dance more intricately and handle the case 163 # of only either of gzip and bzip2 being supported, 164 # or neither, but let's keep this simple. 165 if ($can_tar_gzip && $can_tar_bzip2) { 166 $TAR_EXE = $tar_try; 167 last; 168 } 169 } 170 } 171 unless (defined $TAR_EXE) { 172 skip("No suitable tar command found (tried: @TRY_TAR)", $skip_count); 173 } 174 175 for my $archive_name (@file_and_directory_archives) { 176 if ($^O eq 'VMS' && $TAR_EXE =~ m/gnutar$/i) { 177 $archive_name = VMS::Filespec::unixify($archive_name); 178 } 179 my $command; 180 if ($archive_name =~ m/\.tar$/) { 181 $command = "$TAR_EXE tvf $archive_name"; 182 } 183 elsif ($archive_name =~ m/\.tgz$/) { 184 $command = "$TAR_EXE tzvf $archive_name"; 185 } 186 elsif ($archive_name =~ m/\.tbz$/) { 187 $command = "$TAR_EXE tjvf $archive_name"; 188 } 189 print "# command = '$command'\n"; 190 my @contents = qx{$command}; 191 if ($?) { 192 fail("Failed running '$command'"); 193 } else { 194 chomp(@contents); 195 my @directory_or_not; 196 for my $entry (@contents) { 197 my $perms = (split(/\s+/ => $entry))[0]; 198 my @chars = split('' => $perms); 199 push @directory_or_not, 200 ($chars[0] eq 'd' ? 1 : 0); 201 } 202 203 # create a new tarball with the same content as the old one 204 my $old = Archive::Tar->new($archive_name); 205 my $new = Archive::Tar->new(); 206 $new->add_files( $old->get_files ); 207 208 # save differently if compressed 209 my $ext = ( split /\./, $archive_name )[-1]; 210 my @compress = 211 $ext =~ /t?gz$/ ? (COMPRESS_GZIP) 212 : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP) 213 : (); 214 215 my ( $fh, $filename ) = tempfile( UNLINK => 1 ); 216 $new->write( $filename, @compress ); 217 218 # read the archive again from disk 219 $new = Archive::Tar->new($filename); 220 221 # Adjust our expectations of 222 my @oldfiles = $old->list_files; 223 for (my $i = 0; $i <= $#oldfiles; $i++) { 224 chop $oldfiles[$i] if $directory_or_not[$i]; 225 } 226 227 # compare list of files 228 is_deeply( 229 [ $new->list_files ], 230 [ @oldfiles ], 231 "$archive_name roundtrip on file names" 232 ); 233 } 234 } 235} 236