The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

RJBS / perl-5.36.0 / t / porting / customized.t 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
—
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

              
#!./perl -w
# Test that CUSTOMIZED files in Maintainers.pl have not been overwritten.
BEGIN {
        # This test script uses a slightly atypical invocation of the 'standard'
        # core testing setup stanza.
        # The existing porting tools which manage the Maintainers file all
        # expect to be run from the root
        # XXX that should be fixed
    chdir '..' unless -d 't';
    @INC = qw(lib Porting t);
    require 'test.pl';
    skip_all("pre-computed SHA1 won't match under EBCDIC") if $::IS_EBCDIC;
    skip_all("This distro may have modified some files in cpan/. Skipping validation.") if $ENV{'PERL_BUILD_PACKAGING'};
}
use strict;
use warnings;
use Digest;
use File::Spec;
use Maintainers qw[%Modules get_module_files get_module_pat];
sub filter_customized {
    my ($m, @files) = @_;
    return @files
        unless my $customized = $Modules{$m}{CUSTOMIZED};
    my ($pat) = map { qr/$_/ } join '|' => map {
        ref $_ ? $_ : qr/\b\Q$_\E$/
    } @{ $customized };
    return grep { $_ =~ $pat } @files;
}
sub my_get_module_files {
    my $m = shift;
    return filter_customized $m => map { Maintainers::expand_glob($_) } get_module_pat($m);
}
my $TestCounter = 0;
my $digest_type = 'SHA-1';
my $original_dir = File::Spec->rel2abs(File::Spec->curdir);
my $data_dir = File::Spec->catdir('t', 'porting');
my $customised = File::Spec->catfile($data_dir, 'customized.dat');
my %customised;
my $regen = 0;
while (@ARGV && substr($ARGV[0], 0, 1) eq '-') {
    my $arg = shift @ARGV;
    $arg =~ s/^--/-/; # Treat '--' the same as a single '-'
    if ($arg eq '-regen') {
        $regen = 1;
    }
    else {
        die <<EOF;
Unknown option '$arg'
Usage: $0 [ --regen ]\n"
    --regen    -> Regenerate the data file for $0
EOF
    }
}
my $data_fh;
if ( $regen ) {
  open $data_fh, '>:raw', $customised or die "Can't open $customised";
  print $data_fh <<'#';
# Regenerate this file using:
#     cd t
#     ./perl -I../lib porting/customized.t --regen
#
}
else {
  open $data_fh, '<:raw', $customised or die "Can't open $customised";
  while (<$data_fh>) {
    next if /^#/;
    chomp;
    my ($module,$file,$sha) = split ' ';
    $customised{ $module }->{ $file } = $sha;
  }
  close $data_fh;
}
foreach my $module ( sort keys %Modules ) {
  next unless my $files = $Modules{ $module }{CUSTOMIZED};
  next unless @{ $files };
  my @perl_files = my_get_module_files( $module );
  foreach my $file ( @perl_files ) {
    my $digest = Digest->new( $digest_type );
    {
      open my $fh, '<', $file or die "Can't open $file";
      binmode $fh;
      $digest->addfile( $fh );
      close $fh;
    }
    my $id = $digest->hexdigest;
    if ( $regen ) {
      print $data_fh join(' ', $module, $file, $id), "\n";
      next;
    }
    my $should_be = $customised{ $module }->{ $file };
    is( $id, $should_be, "SHA for $file matches stashed SHA" );
  }
}
if ( $regen ) {
  pass( "regenerated data file" );
  close $data_fh;
}
done_testing();
=pod
=head1 NAME
customized.t - Test that CUSTOMIZED files in Maintainers.pl have not been overwritten
=head1 SYNOPSIS
 cd t
 ./perl -I../lib porting/customized.t --regen
=head1 DESCRIPTION
customized.t checks that files listed in C<Maintainers.pl> that have been C<CUSTOMIZED>
are not accidentally overwritten by CPAN module updates.
=head1 OPTIONS
=over
=item C<--regen>
Use this command line option to regenerate the C<customized.dat> file.
=back
=cut