helpers/verify-tarball

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings FATAL => 'all';
   4
   5 use ExtUtils::Manifest qw(maniread);
   6 use File::Spec;
   7 use Getopt::Long qw(:config gnu_getopt);
   8
   9 GetOptions(
  10   'tar=s'   => \(my $tar = 'tar'),
  11 ) or die("Error in command line arguments\n");
  12
  13 my ($tarball, $manifest) = @ARGV;
  14 my $type
  15   = $tarball =~ /\.bz2$/  ? '-j'
  16   : $tarball =~ /\.xz$/   ? '-J'
  17   : $tarball =~ /\.t?gz$/ ? '-z'
  18   : $tarball =~ /\.Z$/    ? '-Z'
  19   : '';
  20
  21 my @tarfiles;
  22 {
  23   my $null = File::Spec->devnull;
  24   @tarfiles = `$tar -t $type -f "$tarball" 2>$null`;
  25   chomp @tarfiles;
  26 }
  27
  28 {
  29   my $prefix;
  30   for my $path (@tarfiles) {
  31     if (!defined $prefix) {
  32       ($prefix) = $path =~ m{^([^/]+)};
  33     }
  34     elsif ($path !~ m{^\Q$prefix\E(?:/|$)}) {
  35       undef $prefix;
  36       last;
  37     }
  38   }
  39   if ($prefix) {
  40     s{^\Q$prefix\E/}{} for @tarfiles;
  41   }
  42 }
  43
  44 @tarfiles = grep !m{(?:^|/)$}, @tarfiles;
  45 my %tarfiles = map +($_ => 1), @tarfiles;
  46
  47 my %manifiles = %{ maniread($manifest) };
  48
  49 my @extra = grep { !exists $manifiles{$_} } sort keys %tarfiles;
  50 my @missing = grep { !exists $tarfiles{$_} } sort keys %manifiles;
  51
  52 my $message = '';
  53 if (@extra) {
  54   $message .= "$tarball has extra files:\n" . join '', map "  $_\n", @extra;
  55 }
  56 if (@missing) {
  57   $message .= "$tarball is missing files:\n" . join '', map "  $_\n", @missing;
  58 }
  59 if ($message) {
  60   die $message . <<'END_MESSAGE';
  61
  62 This may happen if the file attributes are not compatible with the ustar format.
  63 END_MESSAGE
  64 }
  65 exit 0;