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