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