Skip to content

Commit

Permalink
Add a utility to help test makedef.pl
Browse files Browse the repository at this point in the history
The output of makedef.pl varies too much based on local configuration to allow
us to generate any useful pre-canned expectations of correctness. Hence the only
real option left is to generate "Golden" results for the local platform prior to
any modification, and then compare post modification output with them, to see
that nothing (unexpected) changed. exercise_makedef.pl captures all output for
(currently) 576 permutations of command line parameters, to enable this testing.
  • Loading branch information
nwc10 committed Aug 1, 2011
1 parent ba048c2 commit e95aa0c
Show file tree
Hide file tree
Showing 2 changed files with 93 additions and 0 deletions.
1 change: 1 addition & 0 deletions MANIFEST
Expand Up @@ -4524,6 +4524,7 @@ Porting/corelist.pl Generates data for Module::CoreList
Porting/curliff.pl Curliff or liff your curliffable files.
Porting/epigraphs.pod the release epigraphs used over the years
Porting/exec-bit.txt List of files that get +x in release tarball
Porting/exercise_makedef.pl Brute force testing for makedef.pl
Porting/expand-macro.pl A tool to expand C macro definitions in the Perl source
Porting/findrfuncs Find reentrant variants of functions used in an executable
Porting/findvars Find occurrences of words
Expand Down
92 changes: 92 additions & 0 deletions Porting/exercise_makedef.pl
@@ -0,0 +1,92 @@
#!./miniperl -w
use strict;
use Config;
use 5.012;
die "Can't fork" unless $Config{d_fork};

# Brute force testing for makedef.pl
#
# To use this...
#
# Before modifying makedef.pl, create your golden results:
#
# $ mkdir Gold
# $ ./perl -Ilib Porting/exercise_makedef.pl Gold/
# $ chmod -R -w Gold/
# $ mkdr Test
#
# then modify makedef.pl
#
# then test
#
# $ ./perl -Ilib Porting/exercise_makedef.pl Test
# $ diff -rpu Gold Test

my $prefix = shift;
die "$0 prefix" unless $prefix;
die "No such directory $prefix" unless -d $prefix;

my @unlink;
sub END {
unlink @unlink;
}

$SIG{INT} = sub { die }; # Trigger END processing

{
# needed for OS/2, so fake one up
my $mpm = 'miniperl.map';

die "$mpm exists" if -e $mpm;

open my $in, '<', 'av.c' or die "Can't open av.c: $!";
push @unlink, $mpm;
open my $out, '>', $mpm or die "Can't open $mpm: $!";
while (<$in>) {
print $out "f $1\n" if /^(Perl_[A-Za-z_0-9]+)\(pTHX/;
}
close $out or die "Can't close $mpm: $!";
}

my @args = (platform => [map {"PLATFORM=$_"} qw(aix win32 wince os2 netware vms)],
cflags => ['', 'CCFLAGS=-Dperl=rules -Dzzz'],
Deq => ['', '-Dbeer=foamy'],
D => ['', '-DPERL_IMPLICIT_SYS'],
cctype => ['', map {"CCTYPE=$_"} qw (MSVC60 GCC BORLAND)],
filetype => ['', 'FILETYPE=def', 'FILETYPE=imp'],
);

sub expand {
my ($names, $args, $key, $vals, @rest) = @_;
if (defined $key) {
my $bad;
while (my ($i, $v) = each @$vals) {
$bad += expand([@$names, "$key=$i"], [@$args, $v], @rest);
}
return $bad;
}
# time to process something:
my $name = join ',', @$names;
my @args = grep {length} @$args;

$ENV{PERL5LIB} = join $Config{path_sep}, @INC;
my $pid = fork;
unless ($pid) {
open STDOUT, '>', "$prefix/$name.out"
or die "Can't open $prefix/$name.out: $!";
open STDERR, '>', "$prefix/$name.err"
or die "Can't open $prefix/$name.err: $!";
exec $^X, 'makedef.pl', @args;
die "Something went horribly wrong: $!";
}
die "Bad waitpid: $!" unless waitpid $pid, 0 == $pid;
if ($?) {
print STDERR "`$^X makedef.pl @args` failed with $?\n";
print STDERR "See output in $prefix/$name.err\n";
return 1;
}
return 0;
}

my $bad = expand([], [], @args);
exit($bad > 255 ? 255 : $bad);

0 comments on commit e95aa0c

Please sign in to comment.