| 1 | #!./perl -w |
| 2 | |
| 3 | # Verify that all files generated by perl scripts are up to date. |
| 4 | |
| 5 | BEGIN { |
| 6 | push @INC, '..' if -f '../TestInit.pm'; |
| 7 | push @INC, '.' if -f './TestInit.pm'; |
| 8 | } |
| 9 | use TestInit qw(T A); # T is chdir to the top level, A makes paths absolute |
| 10 | use strict; |
| 11 | |
| 12 | require './regen/regen_lib.pl'; |
| 13 | require './t/test.pl'; |
| 14 | $::NO_ENDING = $::NO_ENDING = 1; |
| 15 | |
| 16 | if ( $^O eq "VMS" ) { |
| 17 | skip_all( "- regen.pl needs porting." ); |
| 18 | } |
| 19 | if ($^O eq 'dec_osf') { |
| 20 | skip_all("$^O cannot handle this test"); |
| 21 | } |
| 22 | if ( $::IS_EBCDIC || $::IS_EBCDIC) { |
| 23 | skip_all( "- We don't regen on EBCDIC." ); |
| 24 | } |
| 25 | use Config; |
| 26 | if ( $Config{usecrosscompile} ) { |
| 27 | skip_all( "Not all files are available during cross-compilation" ); |
| 28 | } |
| 29 | |
| 30 | my $tests = 27; # I can't see a clean way to calculate this automatically. |
| 31 | |
| 32 | my %skip = ("regen_perly.pl" => [qw(perly.act perly.h perly.tab)], |
| 33 | "regen/keywords.pl" => [qw(keywords.c keywords.h)], |
| 34 | "regen/mk_invlists.pl" => [qw(charclass_invlists.h uni_keywords.h)], |
| 35 | "regen/regcharclass.pl" => [qw(regcharclass.h)], |
| 36 | ); |
| 37 | |
| 38 | my %other_requirement = ( |
| 39 | "regen_perly.pl" => "requires bison", |
| 40 | "regen/keywords.pl" => "requires Devel::Tokenizer::C", |
| 41 | "regen/mk_invlists.pl" => "needs the Perl you've just built", |
| 42 | "regen/regcharclass.pl" => "needs the Perl you've just built", |
| 43 | ); |
| 44 | |
| 45 | my %skippable_script_for_target; |
| 46 | for my $script (keys %other_requirement) { |
| 47 | $skippable_script_for_target{$_} = $script |
| 48 | for @{ $skip{$script} }; |
| 49 | } |
| 50 | |
| 51 | my @files = map {@$_} sort values %skip; |
| 52 | |
| 53 | # find out what regen scripts would be executed by regen.pl which |
| 54 | # is the script that implements `make regen`. We need to know this |
| 55 | # because we will run regen.pl --tap, and it will in turn |
| 56 | # so we don't need to execute the scripts it executes directly. |
| 57 | my %regen_files; |
| 58 | { |
| 59 | open my $fh, '<', 'regen.pl' |
| 60 | or die "Can't open regen.pl: $!"; |
| 61 | |
| 62 | while (<$fh>) { |
| 63 | last if /^__END__/; |
| 64 | } |
| 65 | die "Can't find __END__ in regen.pl" |
| 66 | if eof $fh; |
| 67 | while (<$fh>) { |
| 68 | chomp $_; |
| 69 | ++$regen_files{$_}; |
| 70 | } |
| 71 | close $fh |
| 72 | or die "Can't close regen.pl: $!"; |
| 73 | } |
| 74 | |
| 75 | # This may look a bit weird but it makes sense. We build a skip hash of |
| 76 | # all the scripts that we want to avoid executing /explicitly/ during |
| 77 | # our tests. This includes the files listed in %regen_files because we |
| 78 | # will execute them via regen.pl instead. |
| 79 | foreach ( |
| 80 | qw( |
| 81 | charset_translations.pl |
| 82 | embed_lib.pl |
| 83 | mph.pl |
| 84 | regcharclass_multi_char_folds.pl |
| 85 | regen_lib.pl |
| 86 | sorted_types.pl |
| 87 | ), |
| 88 | keys %regen_files |
| 89 | ) { |
| 90 | ++$skip{"regen/$_"}; |
| 91 | } |
| 92 | |
| 93 | |
| 94 | my @progs = grep {!$skip{$_}} <regen/*.pl>; |
| 95 | push @progs, 'regen.pl', map {"Porting/makemeta $_"} qw(-j -y); |
| 96 | @progs = sort @progs; |
| 97 | |
| 98 | plan (tests => $tests + @files + @progs); |
| 99 | |
| 100 | OUTER: foreach my $file (@files) { |
| 101 | open my $fh, '<', $file or die "Can't open $file: $!"; |
| 102 | 1 while defined($_ = <$fh>) and !/Generated from:/; |
| 103 | if (eof $fh) { |
| 104 | fail("Can't find 'Generated from' line in $file"); |
| 105 | next; |
| 106 | } |
| 107 | my @bad; |
| 108 | while (<$fh>) { |
| 109 | last if /ex:[^:]+:/; |
| 110 | unless (/^(?: \* | #)([0-9a-f]+) (\S+)$/) { |
| 111 | chomp $_; |
| 112 | fail("Bad line in $file: '$_'"); |
| 113 | next OUTER; |
| 114 | } |
| 115 | |
| 116 | my $digest = digest($2); |
| 117 | note("$digest $2"); |
| 118 | push @bad, $2 unless $digest eq $1; |
| 119 | } |
| 120 | is("@bad", '', "generated $file is up to date"); |
| 121 | if (@bad && (my $skippable_script = $skippable_script_for_target{$file})) { |
| 122 | my $reason = delete $other_requirement{$skippable_script}; |
| 123 | diag("Note: $skippable_script must be run manually, because it $reason") |
| 124 | if $reason; |
| 125 | } |
| 126 | } |
| 127 | |
| 128 | my @errors; |
| 129 | foreach my $prog (@progs) { |
| 130 | my $args = qq[-Ilib $prog --tap]; |
| 131 | note("./perl $args"); |
| 132 | my $command = "$^X $args"; |
| 133 | if (system $command) { # if it exits with an error... |
| 134 | $command=~s/\s*--tap//; |
| 135 | push @errors, $prog eq "regen.pl" |
| 136 | ? "make regen" |
| 137 | : $command; |
| 138 | } |
| 139 | } |
| 140 | if ( @errors ) { |
| 141 | my $commands= join "\n", sort @errors; |
| 142 | die "\n\nERROR. There are generated files which are NOT up to date.\n", |
| 143 | "You should run the following commands to update these files:\n\n", |
| 144 | $commands, "\n\n", |
| 145 | "Once they are regenerated you should commit the changes.\n\n"; |
| 146 | } |