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