| 1 | #!./miniperl -w |
| 2 | use strict; |
| 3 | use Config; |
| 4 | use 5.012; |
| 5 | die "Can't fork" unless $Config{d_fork}; |
| 6 | |
| 7 | # Brute force testing for makedef.pl |
| 8 | # |
| 9 | # To use this... |
| 10 | # |
| 11 | # Before modifying makedef.pl, create your golden results: |
| 12 | # |
| 13 | # $ mkdir Gold |
| 14 | # $ ./perl -Ilib Porting/exercise_makedef.pl Gold/ |
| 15 | # $ chmod -R -w Gold/ |
| 16 | # $ mkdr Test |
| 17 | # |
| 18 | # then modify makedef.pl |
| 19 | # |
| 20 | # then test |
| 21 | # |
| 22 | # $ ./perl -Ilib Porting/exercise_makedef.pl Test |
| 23 | # $ diff -rpu Gold Test |
| 24 | |
| 25 | my $prefix = shift; |
| 26 | die "$0 prefix" unless $prefix; |
| 27 | die "No such directory $prefix" unless -d $prefix; |
| 28 | |
| 29 | my @unlink; |
| 30 | sub END { |
| 31 | unlink @unlink; |
| 32 | } |
| 33 | |
| 34 | $SIG{INT} = sub { die }; # Trigger END processing |
| 35 | |
| 36 | { |
| 37 | # needed for OS/2, so fake one up |
| 38 | my $mpm = 'miniperl.map'; |
| 39 | |
| 40 | die "$mpm exists" if -e $mpm; |
| 41 | |
| 42 | open my $in, '<', 'av.c' or die "Can't open av.c: $!"; |
| 43 | push @unlink, $mpm; |
| 44 | open my $out, '>', $mpm or die "Can't open $mpm: $!"; |
| 45 | while (<$in>) { |
| 46 | print $out "f $1\n" if /^(Perl_[A-Za-z_0-9]+)\(pTHX/; |
| 47 | } |
| 48 | close $out or die "Can't close $mpm: $!"; |
| 49 | } |
| 50 | |
| 51 | my @args = (platform => [map {"PLATFORM=$_"} qw(aix win32 wince os2 netware vms test)], |
| 52 | cflags => ['', 'CCFLAGS=-Dperl=rules -Dzzz'], |
| 53 | Deq => ['', '-Dbeer=foamy'], |
| 54 | D => ['', '-DPERL_IMPLICIT_SYS'], |
| 55 | cctype => ['', map {"CCTYPE=$_"} qw (MSVC60 GCC)], |
| 56 | filetype => ['', 'FILETYPE=def', 'FILETYPE=imp'], |
| 57 | targ_dir => ['', 'TARG_DIR=t/../'], |
| 58 | ); |
| 59 | |
| 60 | sub expand { |
| 61 | my ($names, $args, $key, $vals, @rest) = @_; |
| 62 | if (defined $key) { |
| 63 | my $bad; |
| 64 | while (my ($i, $v) = each @$vals) { |
| 65 | $bad += expand([@$names, "$key=$i"], [@$args, $v], @rest); |
| 66 | } |
| 67 | return $bad; |
| 68 | } |
| 69 | # time to process something: |
| 70 | my $name = join ',', @$names; |
| 71 | my @args = grep {length} @$args; |
| 72 | |
| 73 | $ENV{PERL5LIB} = join $Config{path_sep}, @INC; |
| 74 | my $pid = fork; |
| 75 | unless ($pid) { |
| 76 | open STDOUT, '>', "$prefix/$name.out" |
| 77 | or die "Can't open $prefix/$name.out: $!"; |
| 78 | open STDERR, '>', "$prefix/$name.err" |
| 79 | or die "Can't open $prefix/$name.err: $!"; |
| 80 | exec $^X, 'makedef.pl', @args; |
| 81 | die "Something went horribly wrong: $!"; |
| 82 | } |
| 83 | die "Bad waitpid: $!" unless waitpid $pid, 0 == $pid; |
| 84 | if ($?) { |
| 85 | print STDERR "`$^X makedef.pl @args` failed with $?\n"; |
| 86 | print STDERR "See output in $prefix/$name.err\n"; |
| 87 | return 1; |
| 88 | } |
| 89 | return 0; |
| 90 | } |
| 91 | |
| 92 | my $bad = expand([], [], @args); |
| 93 | exit($bad > 255 ? 255 : $bad); |