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