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, '>:bytes', $customised or die "Can't open $customised";
  75 }
  76 else {
  77   open $data_fh, '<:bytes', $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 ( keys %Modules ) {
  87   next unless my $files = $Modules{ $module }{CUSTOMIZED};
  88   my @perl_files = my_get_module_files( $module );
  89   foreach my $file ( @perl_files ) {
  90     my $digest = Digest->new( $digest_type );
  91     {
  92       open my $fh, '<', $file or die "Can't open $file";
  93       binmode $fh;
  94       $digest->addfile( $fh );
  95       close $fh;
  96     }
  97     my $id = $digest->hexdigest;
  98     if ( $regen ) {
  99       print $data_fh join(' ', $module, $file, $id), "\n";
 100       next;
 101     }
 102     my $should_be = $customised{ $module }->{ $file };
 103     is( $id, $should_be, "SHA for $file matches stashed SHA" );
 104   }
 105 }
 106
 107 if ( $regen ) {
 108   pass( "regenerated data file" );
 109   close $data_fh;
 110 }
 111
 112 done_testing();
 113
 114 =pod
 115
 116 =head1 NAME
 117
 118 customized.t - Test that CUSTOMIZED files in Maintainers.pl have not been overwritten
 119
 120 =head1 SYNOPSIS
 121
 122  cd t
 123  ./perl -I../lib porting/customized.t --regen
 124
 125 =head1 DESCRIPTION
 126
 127 customized.t checks that files listed in C<Maintainers.pl> that have been C<CUSTOMIZED>
 128 are not accidently overwritten by CPAN module updates.
 129
 130 =head1 OPTIONS
 131
 132 =over
 133
 134 =item C<--regen>
 135
 136 Use this command line option to regenerate the C<customized.dat> file.
 137
 138 =back
 139
 140 =cut