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