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;
46
47@file_only_archives = map File::Spec->catfile(@$_), @file_only_archives;
48
49
50my @file_and_directory_archives = (
51    [qw( src long bar.tar )],
52    [qw( src linktest linktest_with_dir.tar )],
53);
54push @file_and_directory_archives, [qw( src long foo.tgz )]
55  if Archive::Tar->has_zlib_support;
56push @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
61my @archives = (@file_only_archives, @file_and_directory_archives);
62plan tests => scalar @archives;
63
64# roundtrip test
65for 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
124sub can_tar_gzip {
125  my ($tar_help) = @_;
126  return 0 unless can_run('gzip');
127  $tar_help =~ /-z, --gzip|-z,.+gzip/;
128}
129
130sub can_tar_bzip2 {
131  my ($tar_help) = @_;
132  return 0 unless can_run('bzip2');
133  $tar_help =~ /-j, --bzip2|-j,+bzip2/;
134}
135
136# The name of the external tar executable.
137my $TAR_EXE;
138
139SKIP: {
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}
231