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