Commit | Line | Data |
---|---|---|
e95aa0cb NC |
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 | ||
1f7ae1be | 51 | my @args = (platform => [map {"PLATFORM=$_"} qw(aix win32 wince os2 netware vms test)], |
e95aa0cb NC |
52 | cflags => ['', 'CCFLAGS=-Dperl=rules -Dzzz'], |
53 | Deq => ['', '-Dbeer=foamy'], | |
54 | D => ['', '-DPERL_IMPLICIT_SYS'], | |
378eeda7 | 55 | cctype => ['', map {"CCTYPE=$_"} qw (MSVC60 GCC)], |
e95aa0cb | 56 | filetype => ['', 'FILETYPE=def', 'FILETYPE=imp'], |
813af182 | 57 | targ_dir => ['', 'TARG_DIR=t/../'], |
e95aa0cb NC |
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); |