t/porting/customized.t

   1 #!./perl -w
   2
   3 # Test that CUSTOMIZED files in Maintainers.pl have not been overwritten.
   4
   5 BEGIN {
   6         # This test script uses a slightly atypical invocation of the 'standard'
   7         # core testing setup stanza.
   8         # The existing porting tools which manage the Maintainers file all
   9         # expect to be run from the root
  10         # XXX that should be fixed
  11
  12     chdir '..' unless -d 't';
  13     @INC = qw(lib Porting);
  14 }
  15
  16 use strict;
  17 use warnings;
  18 use Digest;
  19 use File::Spec;
  20 use Maintainers qw[%Modules get_module_files get_module_pat];
  21
  22 sub filter_customized {
  23     my ($m, @files) = @_;
  24
  25     return @files
  26         unless my $customized = $Modules{$m}{CUSTOMIZED};
  27
  28     my ($pat) = map { qr/$_/ } join '|' => map {
  29         ref $_ ? $_ : qr/\b\Q$_\E$/
  30     } @{ $customized };
  31
  32     return grep { $_ =~ $pat } @files;
  33 }
  34
  35 sub my_get_module_files {
  36     my $m = shift;
  37     return filter_customized $m => map { Maintainers::expand_glob($_) } get_module_pat($m);
  38 }
  39
  40 my $TestCounter = 0;
  41
  42 my $digest_type = 'SHA-1';
  43
  44 my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
  45 my $data_dir = File::Spec->catdir('t', 'porting');
  46 my $customised = File::Spec->catfile($data_dir, 'customized.dat');
  47
  48 my %customised;
  49
  50 my $regen = 0;
  51
  52 while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
  53     my $arg = shift @ARGV;
  54
  55     $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
  56     if ($arg eq '-regen') {
  57         $regen = 1;
  58     }
  59     else {
  60         die <<EOF;
  61 Unknown option '$arg'
  62
  63 Usage: $0 [ --regen ]\n"
  64     --regen    -> Regenerate the data file for $0
  65
  66 EOF
  67     }
  68 }
  69
  70 my $data_fh;
  71
  72 if ( $regen ) {
  73   open $data_fh, '>:bytes', $customised or die "Can't open $customised";
  74 }
  75 else {
  76   open $data_fh, '<:bytes', $customised or die "Can't open $customised";
  77   while (<$data_fh>) {
  78     chomp;
  79     my ($module,$file,$sha) = split ' ';
  80     $customised{ $module }->{ $file } = $sha;
  81   }
  82   close $data_fh;
  83 }
  84
  85 foreach my $module ( keys %Modules ) {
  86   next unless my $files = $Modules{ $module }{CUSTOMIZED};
  87   my @perl_files = my_get_module_files( $module );
  88   foreach my $file ( @perl_files ) {
  89     my $digest = Digest->new( $digest_type );
  90     {
  91       open my $fh, '<', $file or die "Can't open $file";
  92       binmode $fh;
  93       $digest->addfile( $fh );
  94       close $fh;
  95     }
  96     my $id = $digest->hexdigest;
  97     if ( $regen ) {
  98       print $data_fh join(' ', $module, $file, $id), "\n";
  99       next;
 100     }
 101     my $should_be = $customised{ $module }->{ $file };
 102     if ( $id ne $should_be ) {
 103        print  "not ok ".++$TestCounter." - SHA for $file does not match stashed SHA\n";
 104     }
 105     else {
 106        print  "ok ".++$TestCounter." - SHA for $file matched\n";
 107     }
 108   }
 109 }
 110
 111 if ( $regen ) {
 112   print "ok ".++$TestCounter." - regenerated data file\n";
 113   close $data_fh;
 114 }
 115
 116 print "1..".$TestCounter."\n";
 117
 118 =pod
 119
 120 =head1 NAME
 121
 122 customized.t - Test that CUSTOMIZED files in Maintainers.pl have not been overwritten
 123
 124 =head1 SYNOPSIS
 125
 126  cd t
 127  ./perl -I../lib porting/customized.t --regen
 128
 129 =head1 DESCRIPTION
 130
 131 customized.t checks that files listed in C<Maintainers.pl> that have been C<CUSTOMIZED>
 132 are not accidently overwritten by CPAN module updates.
 133
 134 =head1 OPTIONS
 135
 136 =over
 137
 138 =item C<--regen>
 139
 140 Use this command line option to regenerate the C<customized.dat> file.
 141
 142 =back
 143
 144 =cut