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 # Identify tarballs available for testing
  13 # Some contain only files
  14 # Others contain both files and directories
  15
  16 my @file_only_archives = (
  17   [qw( src short bar.tar )],
  18 );
  19 push @file_only_archives, [qw( src short foo.tgz )]
  20   if Archive::Tar->has_zlib_support;
  21 push @file_only_archives, [qw( src short foo.tbz )]
  22   if Archive::Tar->has_bzip2_support;
  23
  24 @file_only_archives = map File::Spec->catfile(@$_), @file_only_archives;
  25
  26
  27 my @file_and_directory_archives = (
  28     [qw( src long bar.tar )],
  29     [qw( src linktest linktest_with_dir.tar )],
  30 );
  31 push @file_and_directory_archives, [qw( src long foo.tgz )]
  32   if Archive::Tar->has_zlib_support;
  33 push @file_and_directory_archives, [qw( src long foo.tbz )]
  34   if Archive::Tar->has_bzip2_support;
  35
  36 @file_and_directory_archives = map File::Spec->catfile(@$_), @file_and_directory_archives;
  37
  38 my @archives = (@file_only_archives, @file_and_directory_archives);
  39 plan tests => scalar @archives;
  40
  41 # roundtrip test
  42 for my $archive_name (@file_only_archives) {
  43
  44       # create a new tarball with the same content as the old one
  45       my $old = Archive::Tar->new($archive_name);
  46       my $new = Archive::Tar->new();
  47       $new->add_files( $old->get_files );
  48
  49       # save differently if compressed
  50       my $ext = ( split /\./, $archive_name )[-1];
  51       my @compress =
  52           $ext =~ /t?gz$/       ? (COMPRESS_GZIP)
  53         : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP)
  54         : ();
  55
  56       my ( $fh, $filename ) = tempfile( UNLINK => 1 );
  57       $new->write( $filename, @compress );
  58
  59       # read the archive again from disk
  60       $new = Archive::Tar->new($filename);
  61
  62       # compare list of files
  63       is_deeply(
  64           [ $new->list_files ],
  65           [ $old->list_files ],
  66           "$archive_name roundtrip on file names"
  67       );
  68 }
  69
  70 # rt.cpan.org #115160
  71 # t/09_roundtrip.t was added with all 7 then existent tests marked TODO even
  72 # though 3 of them were passing.  So what was really TODO was to figure out
  73 # why the other 4 were not passing.
  74 #
  75 # It turns out that the tests are expecting behavior which, though on the face
  76 # of it plausible and desirable, is not Archive::Tar::write()'s current
  77 # behavior.  write() -- which is used in the unit tests in this file -- relies
  78 # on Archive::Tar::File::_prefix_and_file().  Since at least 2006 this helper
  79 # method has had the effect of removing a trailing slash from archive entries
  80 # which are in fact directories.  So we have to adjust our expectations for
  81 # what we'll get when round-tripping on an archive which contains one or more
  82 # entries for directories.
  83
  84 for my $archive_name (@file_and_directory_archives) {
  85     my @contents;
  86     if ($archive_name =~ m/\.tar$/) {
  87         @contents = qx{tar tvf $archive_name};
  88     }
  89     elsif ($archive_name =~ m/\.tgz$/) {
  90         @contents = qx{tar tzvf $archive_name};
  91     }
  92     elsif ($archive_name =~ m/\.tbz$/) {
  93         @contents = qx{tar tjvf $archive_name};
  94     }
  95     chomp(@contents);
  96     my @directory_or_not;
  97     for my $entry (@contents) {
  98         my $perms = (split(/\s+/ => $entry))[0];
  99         my @chars = split('' => $perms);
 100         push @directory_or_not,
 101             ($chars[0] eq 'd' ? 1 : 0);
 102     }
 103
 104     # create a new tarball with the same content as the old one
 105     my $old = Archive::Tar->new($archive_name);
 106     my $new = Archive::Tar->new();
 107     $new->add_files( $old->get_files );
 108
 109     # save differently if compressed
 110     my $ext = ( split /\./, $archive_name )[-1];
 111     my @compress =
 112         $ext =~ /t?gz$/       ? (COMPRESS_GZIP)
 113       : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP)
 114       : ();
 115
 116     my ( $fh, $filename ) = tempfile( UNLINK => 1 );
 117     $new->write( $filename, @compress );
 118
 119     # read the archive again from disk
 120     $new = Archive::Tar->new($filename);
 121
 122     # Adjust our expectations of
 123     my @oldfiles = $old->list_files;
 124     for (my $i = 0; $i <= $#oldfiles; $i++) {
 125         chop $oldfiles[$i] if $directory_or_not[$i];
 126     }
 127
 128     # compare list of files
 129     is_deeply(
 130         [ $new->list_files ],
 131         [ @oldfiles ],
 132         "$archive_name roundtrip on file names"
 133     );
 134 }