#!/usr/bin/perl
BEGIN {
chdir
'..'
if
-f
'test.pl'
;
@INC
= (
'./lib'
);
require
'./t/test.pl'
;
}
skip_all
"not devel"
unless
-d
"./.git"
;
skip_all
"not linux"
unless
$^O eq
'linux'
;
skip_all
"no valgrind"
unless
-x
'/bin/valgrind'
|| -x
'/usr/bin/valgrind'
;
skip_all
"not with ASAN"
if
$Config
{ccflags} =~ /sanitize=address/;
skip_all
"cachegrind broken"
if
system
"( ulimit -c 0; ulimit -t 15; valgrind -q --tool=cachegrind --cachegrind-out-file=/dev/null $^X -e0 ) 2>/dev/null"
;
my
$bench_pl
=
"Porting/bench.pl"
;
ok -e
$bench_pl
,
"$bench_pl exists and is executable"
;
my
$bench_cmd
=
"$^X -Ilib $bench_pl"
;
my
(
$out
,
$cmd
);
my
%formats
;
my
%format_qrs
;
{
my
$cur
;
while
(<DATA>) {
next
if
/^
if
(/^FORMAT:/) {
die
"invalid format line: $_"
unless
/^FORMAT:\s+(\w+)\s*$/;
$cur
= $1;
die
"duplicate format: '$cur'\n"
if
exists
$formats
{
$cur
};
next
;
}
$formats
{
$cur
} .=
$_
;
}
for
my
$name
(
sort
keys
%formats
) {
my
$f
=
$formats
{
$name
};
$f
=~ s{^ \s* %% (\w+) %% [ \t]* \n}
{
my
$f1
=
$formats
{$1};
die
"No such sub-format '%%$1%%' in format '$name'\n"
unless
defined
$f1
;
$f1
;
}gmxe;
$f
=
quotemeta
$f
;
$f
=~ s{(N+)\\.(N+)}
{
my
$l
=
length
($2);
"("
.
"\\s*-?\\d+\\."
.
"\\d"
x
$l
.
"|\\s*-)"
}ge;
$f
=~ s/(\A|\n)(\\ )+/$1 */g;
$f
=~ s/(\\ )+/ +/g;
$f
=~ s/(\\-){2,}/-+/g;
$format_qrs
{
$name
} =
qr/\A$f\z/
;
}
}
for
my
$test
(
[
"--boz"
,
"Unknown option: boz\nUse the -h option for usage information.\n"
,
"croak: basic unknown option"
],
[
"--fields=Ir,Boz"
,
"Error: --fields: unknown field 'Boz'\n"
,
"croak: unknown --field"
],
[
"--action=boz"
,
"Error: unrecognised action 'boz'\nmust be one of: grind, selftest\n"
,
"croak: unknown --action"
],
[
"--sort=boz"
,
"Error: --sort argument should be of the form field:perl: 'boz'\n"
,
"croak: invalid --sort"
],
[
"--sort=boz:perl"
,
"Error: --sort: unknown field 'boz'\n"
,
"croak: unknown --sort field"
],
[
"-action=selftest perl"
,
"Error: no perl executables may be specified with selftest\n"
,
"croak: --action-selftest with executable"
],
[
"--tests=/boz perl"
,
"Error: --tests regex must be of the form /.../\n"
,
"croak: invalid --tests regex"
],
[
"--tests=call::sub::empty,foo::bar::baz::boz perl"
,
"Error: no such test found: 'foo::bar::baz::boz'\n"
.
"Re-run with --verbose for a list of valid tests.\n"
,
"croak: unknown test in --tests"
],
[
"--verbose --tests=call::sub::empty,foo::bar::baz::boz --read=t/porting/bench/callsub.json"
,
"Error: no such test found: 'foo::bar::baz::boz'\n"
.
"Valid test names are:\n"
.
" call::sub::amp_empty\n"
.
" call::sub::empty\n"
,
"croak: unknown test in --tests --verbose"
],
[
"--tests=/foo::bar::baz::boz/ perl"
,
"Error: no tests to run\n"
,
"croak: no --tests to run "
],
[
"--benchfile=no-such-file-boz perl"
,
qr/\AError: can't read 'no-such-file-boz':/
,
"croak: non-existent --benchfile "
],
[
"--benchfile=t/porting/bench/synerr perl"
,
qr{\AError: can't parse 't/porting/bench/synerr':\nsyntax error}
,
"croak: --benchfile with syntax error"
],
[
"--benchfile=t/porting/bench/ret0 perl"
,
"Error: can't load 't/porting/bench/ret0': code didn't return a true value\n"
,
"croak: --benchfile which returns 0"
],
[
"--benchfile=t/porting/bench/oddentry perl"
,
qr{\AError: 't/porting/bench/oddentry' does not contain evenly paired test names and hashes\n}
,
"croak: --benchfile with odd number of entries"
],
[
"--benchfile=t/porting/bench/badname perl"
,
qr{\AError: 't/porting/bench/badname': invalid test name: '1='\n}
,
"croak: --benchfile with invalid test name"
],
[
"--benchfile=t/porting/bench/badhash perl"
,
qr{\AError: 't/porting/bench/badhash': invalid key 'blah' for test 'foo::bar'\n}
,
"croak: --benchfile with invalid test hash key"
],
[
"--norm=2 ./miniperl ./perl"
,
"Error: --norm value 2 outside range 0..1\n"
,
"croak: select-a-perl out of range"
],
[
"--norm=-0 ./miniperl ./perl"
,
"Error: --norm value -0 outside range -1..-2\n"
,
"croak: select-a-perl out of range"
],
[
"--norm=-3 ./miniperl ./perl"
,
"Error: --norm value -3 outside range -1..-2\n"
,
"croak: select-a-perl out of range"
],
[
"--sort=Ir:myperl ./miniperl ./perl"
,
"Error: --sort: unrecognised perl 'myperl'\n"
.
"Valid perl names are:\n"
.
" ./miniperl\n"
.
" ./perl\n"
,
"croak: select-a-perl unrecognised"
],
[
"--compact=./perl ./perl=A ./perl=B"
,
"Error: --compact: ambiguous perl './perl'\n"
,
"croak: select-a-perl ambiguous"
],
[
"./perl --foo"
,
"Error: unrecognised executable switch '--foo'\n"
,
"croak: ./perl --foo"
],
[
"-- --args=foo"
,
"Error: --args without a preceding executable name\n"
,
"croak: --args without perl"
],
[
"-- --env=foo=bar"
,
"Error: --env without a preceding executable name\n"
,
"croak: --env without perl"
],
[
"./perl --args"
,
"Error: --args is missing value\n"
,
"croak: --args without value"
],
[
"./perl --env"
,
"Error: --env is missing value\n"
,
"croak: --env without value"
],
[
"./perl --env='FOO'"
,
"Error: --env is missing =value\n"
,
"croak: --env without =value"
],
[
"./perl ./perl"
,
"Error: duplicate label './perl': each executable must have a unique label\n"
,
"croak: duplicate label ./perl ./perl"
],
[
"./perl=A ./miniperl=A"
,
"Error: duplicate label 'A': each executable must have a unique label\n"
,
"croak: duplicate label =A =A"
],
[
"--read=t/porting/bench/callsub.json --read=t/porting/bench/callsub.json"
,
"Error: duplicate label './perl': seen in file 't/porting/bench/callsub.json'\n"
,
"croak: duplicate label --read=... --read=..."
],
[
"--read=t/porting/bench/callsub.json ./perl"
,
"Error: duplicate label './perl': seen both in --read file and on command line\n"
,
"croak: duplicate label --read=... ./perl"
],
[
"./nosuch-perl"
,
qr{^\QError: unable to execute './nosuch-perl': }
,
"croak: no such perl"
],
[
"--grindargs=Boz --debug --tests=call::sub::empty ./perl=A ./perl=B"
,
qr{Error: .*?(unexpected code or cachegrind output|gave return status)}
s,
"croak: cachegrind output format "
],
[
"--bisect=Ir"
,,
"Error: --bisect option must be of form 'field,integer,integer'\n"
,
"croak: --bisect=Ir"
],
[
"--bisect=Ir,1"
,,
"Error: --bisect option must be of form 'field,integer,integer'\n"
,
"croak: --bisect=Ir,1"
],
[
"--bisect=Ir,1,2,3"
,
"Error: --bisect option must be of form 'field,integer,integer'\n"
,
"croak: --bisect=Ir,1,2,3"
],
[
"--bisect=Ir,1,x"
,
"Error: --bisect option must be of form 'field,integer,integer'\n"
,
"croak: --bisect=Ir,1,x"
],
[
"--bisect=Ir,x,2"
,
"Error: --bisect option must be of form 'field,integer,integer'\n"
,
"croak: --bisect=Ir,x,2"
],
[
"--bisect=boz,1,2"
,
"Error: unrecognised field 'boz' in --bisect option\n"
,
"croak: --bisect=boz,1,2"
],
[
"--bisect=Ir,2,1"
,
"Error: --bisect min (2) must be <= max (1)\n"
,
"croak: --bisect=boz,2,1"
],
[
"--read=no-such-file-boz"
,
qr/\AError: can't open 'no-such-file-boz' for reading:/
,
"croak: non-existent --read file "
],
[
"--read=t/porting/bench/badversion.json"
,
"Error: unsupported version 9999.9 in file 't/porting/bench/badversion.json' (too new)\n"
,
"croak: --read version"
],
[
"--read=t/porting/bench/callsub.json --benchfile=t/perf/benchmarks ./perl "
,
"Error: --benchfile cannot be used when --read is present\n"
,
"croak: benchfile with read"
],
[
""
,
"Error: nothing to do: no perls to run, no data to read.\n"
,
"croak: no input"
],
[
"./perl"
,
"Error: need at least 2 perls for comparison.\n"
,
"croak: need 2 perls"
],
[
"--bisect=Ir,1,2 ./perl=A ./perl=B"
,
"Error: exactly one perl executable must be specified for bisect\n"
,
"croak: --bisect, need 1 perls"
],
[
"--bisect=Ir,1,2 --tests=/call/ ./perl=A"
,
"Error: only a single test may be specified with --bisect\n"
,
"croak: --bisect one test only"
],
[
"--read=t/porting/bench/callsub.json --write=no/such/file/boz"
,
qr{\AError: can't open 'no/such/file/boz' for writing: }
,
"croak: --write open error"
],
[
"--read=t/porting/bench/callsub.json "
.
" --read=t/porting/bench/callsub2.json"
,
"Can't merge multiple read files: they contain differing test sets.\n"
.
"Re-run with --verbose to see the differences.\n"
,
"croak: --read callsub, callsub2"
],
[
"--read=t/porting/bench/callsub.json "
.
" --read=t/porting/bench/callsub2.json"
.
" --verbose"
,
"Can't merge multiple read files: they contain differing test sets.\n"
.
"Previous tests:\n"
.
" call::sub::amp_empty\n"
.
" call::sub::empty\n"
.
"tests from 't/porting/bench/callsub2.json':\n"
.
" call::sub::args3\n"
.
" call::sub::empty\n"
,
"croak: --read callsub, callsub2 --verbose"
],
)
{
my
(
$args
,
$expected
,
$desc
) =
@$test
;
$out
=
qx($bench_cmd $args 2>&1)
;
if
(
ref
(
$expected
)) {
like
$out
,
$expected
,
$desc
;
}
else
{
is
$out
,
$expected
,
$desc
;
}
}
my
$resultfile1
= tempfile();
my
$resultfile2
= tempfile();
note(
"running cachegrind for 1st perl; may be slow..."
);
$out
=
qx($bench_cmd -j 2 --write=$resultfile1 --tests=call::sub::empty $^X=p0 2>&1)
;
is
$out
,
""
,
"--write should produce no output (1 perl)"
;
ok -s
$resultfile1
,
"--write should create a non-empty results file (1 perl)"
;
note(
"running cachegrind for 2nd perl; may be slow..."
);
$out
=
qx($bench_cmd -j 2 --read=$resultfile1 --write=$resultfile2 $^X=p1 2>&1)
;
is
$out
,
""
,
"--write should produce no output (2 perls)"
or diag(
"got: $out"
);
ok -s
$resultfile2
,
"--write should create a non-empty results file (2 perls)"
;
$out
=
qx($bench_cmd --read=$resultfile1 --raw 2>&1)
;
like
$out
,
$format_qrs
{raw1},
"basic cachegrind raw format; 1 perl"
;
$out
=
qx($bench_cmd --read=$resultfile1 --raw --compact=0 2>&1)
;
like
$out
,
$format_qrs
{raw_compact},
"basic cachegrind raw compact format; 1 perl"
;
$out
=
qx($bench_cmd --read=$resultfile1 --raw --average 2>&1)
;
like
$out
,
$format_qrs
{raw_average1},
"basic cachegrind raw average format; 1 perl"
;
$out
=
qx($bench_cmd --read=$resultfile1 --raw --fields=Ir,Dr 2>&1)
;
like
$out
,
$format_qrs
{fields1},
"basic cachegrind --fields; 1 perl"
;
$out
=
qx($bench_cmd --read=$resultfile2 2>&1)
;
like
$out
,
$format_qrs
{percent2},
"basic cachegrind percent format; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --norm=0 2>&1)
;
like
$out
,
$format_qrs
{percent2},
"basic cachegrind percent format, norm; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --norm=-2 2>&1)
;
like
$out
,
$format_qrs
{percent2},
"basic cachegrind percent format, norm -2; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --sort=Ir:0 2>&1)
;
like
$out
,
$format_qrs
{percent2},
"basic cachegrind percent format, sort; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --sort=Ir:0 --norm=0 2>&1)
;
like
$out
,
$format_qrs
{percent2},
"basic cachegrind percent format, sort, norm; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --raw 2>&1)
;
like
$out
,
$format_qrs
{raw2},
"basic cachegrind raw format; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --raw --norm=0 2>&1)
;
like
$out
,
$format_qrs
{raw2},
"basic cachegrind raw format, norm; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --raw --sort=Ir:0 2>&1)
;
like
$out
,
$format_qrs
{raw2},
"basic cachegrind raw format, sort, norm; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --raw --sort=Ir:0 --norm=0 2>&1)
;
like
$out
,
$format_qrs
{raw2},
"basic cachegrind raw format, sort, norm; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --compact=1 2>&1)
;
like
$out
,
$format_qrs
{compact},
"basic cachegrind compact format; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --average 2>&1)
;
like
$out
,
$format_qrs
{average},
"basic cachegrind average format; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --fields=Ir,Dr 2>&1)
;
like
$out
,
$format_qrs
{fields2},
"basic cachegrind --fields; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --compact=1 --fields=Ir,Dr 2>&1)
;
like
$out
,
$format_qrs
{compact_fields},
"basic cachegrind compact, fields; 2 perls"
;
$out
=
qx($bench_cmd --read=$resultfile2 --fields=Ir 2>&1)
;
like
$out
,
$format_qrs
{
'1field'
},
"basic cachegrind 1 field; 2 perls"
;
$out
=
qx($bench_cmd --read=t/porting/bench/callsub.json --tests=call::sub::empty --bisect=Ir,100000,100001 2>&1)
;
is $?, 1 << 8,
"--bisect: exit result: should not match"
;
like
$out
,
qr/^Bisect: Ir had the value -?\d+\n/
,
"--bisect: got expected output"
;
$out
=
qx($bench_cmd --read=t/porting/bench/callsub.json --read=t/porting/bench/callsub2.json --tests=call::sub::empty 2>&1)
;
$out
=~ s{\Q./perl perl2}{ p0 p1};
$out
=~ s{^\./perl}{p0}m;
like
$out
,
$format_qrs
{percent2},
"2 reads; overlapping test sets"
;
note(
"running cachegrind on 1 perl; may be slow..."
);
$out
=
qx($bench_cmd --read=t/porting/bench/callsub.json --tests=call::sub::empty $^X=p1 2>&1)
;
$out
=~ s{^\./perl}{p0}m;
$out
=~ s{\Q./perl}{ p0};
like
$out
,
$format_qrs
{percent2},
"1 read; 1 generate"
;
note(
"running cachegrind on 2 perls; may be slow..."
);
$cmd
=
<<EOF;
$bench_cmd
--read=t/porting/bench/callsub.json
--read=t/porting/bench/callsub2.json
--tests=call::sub::empty
--autolabel
--perlargs=-Ilib
$^X --args='-Ifoo/bar -Mstrict' --env='FOO=foo'
$^X --args='-Ifoo/bar' --env='BAR=bar' --env='BAZ=baz'
2>&1
EOF
$cmd
=~ s/\n\s+/ /g;
$out
=
qx($cmd)
;
$out
=~ s{^\./perl}{p0}m;
$out
=~ s{\Q ./perl perl2 p-0 p-1}
{ p0 p1 p2 p3};
like
$out
,
$format_qrs
{percent4},
"4 perls with autolabel and args and env"
;
done_testing();