From: Jim Cromie Date: Sat, 6 Nov 2004 00:57:13 +0000 (-0700) Subject: Re: optree tests and VMS progress (no really) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5e251bf1fe0e5e66987f1eeb75b275092a7de496;p=p5sagit%2Fp5-mst-13.2.git Re: optree tests and VMS progress (no really) Message-ID: Date: Sat, 6 Nov 2004 00:57:13 -0700 p4raw-id: //depot/perl@23481 --- diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm index fe5d84e..9c5a7e9 100644 --- a/ext/B/t/OptreeCheck.pm +++ b/ext/B/t/OptreeCheck.pm @@ -5,23 +5,31 @@ =head1 NAME -OptreeCheck - check optrees +OptreeCheck - check optrees as rendered by B::Concise =head1 SYNOPSIS OptreeCheck supports regression testing of perl's parser, optimizer, -bytecode generator, via a single function: checkOptree(%args).' - - checkOptree(name => "your title here", # optional, (synth from others) - bcopts => '-exec', # $opt or \@opts, passed to BC::compile - code => sub {my $a}, # coderef, or source (wrapped and evald) - # prog => 'sort @a', # run in subprocess, aka -MO=Concise - # skip => 1, # skips test - # todo => 'excuse', # anticipated failures - # fail => 1 # fails (by redirecting result) - # debug => 1, # turns on regex debug for match test !! - # retry => 1 # retry with debug on test failure - expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +bytecode generator, via a single function: checkOptree(%args). It +invokes B::Concise upon sample code, and checks that it 'agrees' with +reference renderings. + + checkOptree ( + name => "test-name', # optional, (synth from others) + + # 2 kinds of code-under-test: must provide 1 + code => sub {my $a}, # coderef, or source (wrapped and evald) + prog => 'sort @a', # run in subprocess, aka -MO=Concise + + bcopts => '-exec', # $opt or \@opts, passed to BC::compile + # errs => '.*', # match against any emitted errs, -w warnings + # skip => 1, # skips test + # todo => 'excuse', # anticipated failures + # fail => 1 # force fail (by redirecting result) + # debug => 1, # turns on regex debug for match test !! + # retry => 1 # retry with debug on test failure + + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # 1 <;> nextstate(main 45 optree.t:23) v # 2 <0> padsv[$a:45,46] M/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 @@ -33,33 +41,34 @@ bytecode generator, via a single function: checkOptree(%args).' =head1 checkOptree(%in) Overview -Calls getRendering(), which runs code or prog through B::Concise, and -captures its rendering. +optreeCheck() calls getRendering(), which runs code or prog through +B::Concise, and captures its rendering. -Calls mkCheckRex() to produce a regex which will match the expected -rendering, and fail when it doesn't match. +It then calls mkCheckRex() to produce a regex which will match the +expected rendering, and fail when it doesn't match. + +Finally, it compares the 2; like($rendering,/$regex/,$testname). -Also calls like($rendering,/$regex/,$name), and thereby plugs into the -test.pl framework. =head1 checkOptree(%Args) API Accepts %Args, with following requirements and actions: -expect and expect_nt are both: required, not empty, not whitespace. -It's a fatal error otherwise, because false positives are BAD. - Either code or prog must be present. prog is some source code, and is -passed through via runperl, to B::Concise like this: (bcopts are fixed -up for cmdline) +passed through via test.pl:runperl, to B::Concise like this: (bcopts +are fixed up for cmdline) './perl -w -MO=Concise,$bcopts_massaged -e $src' code is a subref, or $src, like above. If it's not a subref, it's -treated like source, but is wrapped as a subroutine, and passed to +treated like source-code, is wrapped as a subroutine, and is passed to B::Concise::compile(). $subref = eval "sub{$src}"; + B::Concise::compile($subref). + +expect and expect_nt are the reference optree renderings. Theyre +required, except when the code/prog compilation fails. I suppose I should also explain these more, but they seem obvious. @@ -182,8 +191,15 @@ our %gOpts = # values are replaced at runtime !! help => 0, # 1 ends in die # array values are one-of selections, with 1st value as default - # tbc: 1st value is help, 2nd is default testmode => [qw/ native cross both /], + + # fixup for VMS, cygwin, which dont have stderr b4 stdout + # 2nd value is used as help-str, 1st val (still) default + + rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0], + strip => [1, 'if 1, catch errs and remove from renderings',0], + stripv => 'if strip&&1, be verbose about it', + errs => 'expected compile errs', ); @@ -267,12 +283,13 @@ sub getCmdLine { # import assistant # override with 'foo' if 'opt=foo' appears grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV; } - } + } print("$0 heres current state:\n", Dumper \%gOpts) if $gOpts{help} or $gOpts{dump}; exit if $gOpts{help}; } +# the above arg-handling cruft should be replaced by a Getopt call ################################## # API @@ -285,9 +302,25 @@ sub checkOptree { SKIP: { label(\%in); skip($in{name}, 1) if $in{skip}; + + # cpy globals into each test + foreach $k (keys %gOpts) { + if ($gOpts{$k}) { + $in{$k} = $gOpts{$k} unless $in{$k}; + } + } + #die "no reftext found for $want: $in->{name}" unless $str; + return runSelftest(\%in) if $gOpts{selftest}; - my $rendering = getRendering(\%in); # get the actual output + my ($rendering,@errs) = getRendering(\%in); # get the actual output + + if ($in->{errs}) { + if (@errs) { + like ("@errs", qr/$in->{errs}\s*/, "$in->{name} - matched expected errs"); + next; + } + } fail("FORCED: $in{name}:\n$rendering") if $gOpts{fail}; # silly ? # Test rendering against .. @@ -397,7 +430,7 @@ sub mylike { #$got =~ s/($rex)/ate: $1/msg; # noisy $got =~ s/($rex)\n//msg; # remove matches } - print "sequentially deconstructed, these are unmatched:\n$got\n"; + print "these lines not matched:\n$got\n"; } if (not $ok and $retry) { @@ -418,18 +451,20 @@ sub getRendering { my @opts = get_bcopts($in); my $rendering = ''; # suppress "Use of uninitialized value in open" + my @errs; # collect errs via + if ($in->{prog}) { $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)], prog => $in->{prog}, stderr => 1, - ); #verbose => 1); + ); # verbose => 1); } else { my $code = $in->{code}; unless (ref $code eq 'CODE') { # treat as source, and wrap $code = eval "sub { $code }"; - die "$@ evaling code 'sub { $in->{code} }'\n" - unless ref $code eq 'CODE'; + # return errors + push @errs, $@ if $@; } # set walk-output b4 compiling, which writes 'announce' line walk_output(\$rendering); @@ -443,7 +478,18 @@ sub getRendering { B::Concise::reset_sequence(); $opwalker->(); } - return $rendering; + if ($in->{strip}) { + $rendering =~ s/(B::Concise::compile.*?\n)//; + print "stripped from rendering <$1>\n" if $1 and $in->{stripv}; + + while ($rendering =~ s/^(.*?-e line .*?\n)//g) { + print "stripped <$1>\n" if $in->{stripv}; + push @errs, $1; + } + $rendering =~ s/^(-e syntax OK\n)//ms; + $rendering =~ s/^(-e had compilation errors.\n)//ms; + } + return $rendering, @errs; } sub get_bcopts { @@ -457,6 +503,33 @@ sub get_bcopts { return @opts; } +=head1 mkCheckRex + +mkCheckRex receives the full testcase object, and constructs a regex. +1st, it selects a reftxt from either the expect or expect_nt items. + +Once selected, the reftext is massaged & converted into a Regex that +accepts 'good' concise renderings, with appropriate input variations, +but is otherwise as strict as possible. For example, it should *not* +match when opcode flags change, or when optimizations convert an op to +an ex-op. + +selection is driven by platform mostly, but also by test-mode, which +rather complicates the code. this is worsened by the potential need +to make platform specific conversions on the reftext. + +=head2 match criteria + +Opcode arguments (text within braces) are disregarded for matching +purposes. This loses some info in 'add[t5]', but greatly simplifys +matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing +for regressions, not for complete accuracy. + +The regex is anchored by default, but can be suppressed with +'noanchors', allowing 1-liner tests to succeed if opcode is found. + +=cut + # needless complexity due to 'too much info' from B::Concise v.60 my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';; @@ -469,7 +542,6 @@ sub mkCheckRex { my $str = $in->{expect} || $in->{expect_nt}; # standard bias $str = $in->{$want} if $want; # stated pref - die "no reftext found for $want: $in->{name}" unless $str; #fail("rex-str is empty, won't allow false positives") unless $str; $str =~ s/^\# //mg; # ease cut-paste testcase authoring @@ -490,13 +562,18 @@ sub mkCheckRex { # no 'invisible' failures in debugger $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg; - + # widened for -terse mode + $str =~ s/(?:next|db)state/(?:next|db)state/msg; + # don't care about: $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg; # FAKE line numbers $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg; # match args $str =~ s/(0x[0-9A-Fa-f]+)/0x[0-9A-Fa-f]+/msg; # hexnum values $str =~ s/".*?"/".*?"/msg; # quoted strings + $str =~ s/(\d refs?)/\\d refs?/msg; + $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse + croak "no reftext found for $want: $in->{name}" unless $str =~ /\w+/; # fail unless a real test @@ -505,7 +582,7 @@ sub mkCheckRex { # allow -eval, banner at beginning of anchored matches $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str - unless $in->{noanchors}; + unless $in->{noanchors} or $in->{rxnoorder}; eval "use re 'debug'" if $debug; my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ; @@ -654,27 +731,6 @@ if ($0 =~ /OptreeCheck\.pm/) { __END__ -=head1 mkCheckRex - -mkCheckRex receives the full testcase object, and constructs a regex. -1st, it selects a reftxt from either the expect or expect_nt items. - -Once selected, reftext is massaged & converted into a Regex that -accepts 'good' concise renderings, with appropriate input variations, -but is otherwise as strict as possible. For example, it should *not* -match when opcode flags change, or when optimizations convert an op to -an ex-op. - -=head2 match criteria - -Opcode arguments (text within braces) are disregarded for matching -purposes. This loses some info in 'add[t5]', but greatly simplifys -matching 'nextstate(main 22 (eval 10):1)'. Besides, we are testing -for regressions, not for complete accuracy. - -The regex is anchored by default, but can be suppressed with -'noanchors', allowing 1-liner tests to succeed if opcode is found. - =head1 TEST DEVELOPMENT SUPPORT This optree regression testing framework needs tests in order to find @@ -712,4 +768,10 @@ crosstest, etc selection mechanics. improve retry, retrydbg, esp. it's control of eval "use re debug". This seems to work part of the time, but isn't stable enough. +=head1 CAVEATS + +This code is purely for testing core. While checkOptree feels flexible +enough to be stable, the whole selftest framework is subject to change +w/o notice. + =cut diff --git a/ext/B/t/optree_check.t b/ext/B/t/optree_check.t index a037a78..b91da13 100644 --- a/ext/B/t/optree_check.t +++ b/ext/B/t/optree_check.t @@ -118,18 +118,18 @@ if (1) { pass ("TEST -e \$srcCode"); -checkOptree ( name => '-w errors seen', - prog => 'sort our @a', - noanchors => 1, # unanchored match - expect => 'Useless use of sort in void context', - expect_nt => 'Useless use of sort in void context'); - -checkOptree ( name => "self strict, catch err", - prog => 'use strict; bogus', - noanchors => 1, - expect => 'strict subs', - expect_nt => 'strict subs'); - +checkOptree + ( name => '-w errors seen', + prog => 'sort our @a', + errs => 'Useless use of sort in void context at -e line 1.', + ); + +checkOptree + ( name => "self strict, catch err", + prog => 'use strict; bogus', + errs => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.', + ); + checkOptree ( name => "sort vK - flag specific search", prog => 'sort our @a', noanchors => 1, diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t index efd351a..09a5207 100644 --- a/ext/B/t/optree_concise.t +++ b/ext/B/t/optree_concise.t @@ -20,7 +20,7 @@ BEGIN { use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! use Config; -plan tests => 23; +plan tests => 24; SKIP: { skip "no perlio in this build", 23 unless $Config::Config{useperlio}; @@ -249,24 +249,35 @@ EOT_EOT # 7 <@> leave[1 ref] vKP/REFC EONT_EONT -checkOptree ( name => 'cmdline self-strict compile err', - prog => 'use strict; sort @a', - bcopts => [qw/ -basic -concise -exec /], - noanchors => 1, - expect => 'compilation errors', - expect_nt => 'compilation errors'); - -checkOptree ( name => 'error at -e line 1', - prog => 'our @a; sort @a', - bcopts => [qw/ -basic -concise -exec /], - noanchors => 1, - expect => 'at -e line 1', - expect_nt => 'at -e line 1'); - -checkOptree ( name => 'cmdline -basic -concise -exec works', - prog => 'our @a; sort @a', - bcopts => [qw/ -basic -concise -exec /], - expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +; +$DB::single=1; +checkOptree + ( name => 'cmdline self-strict compile err using prog', + prog => 'use strict; sort @a', + bcopts => [qw/ -basic -concise -exec /], + errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + ); + +checkOptree + ( name => 'cmdline self-strict compile err using code', + code => 'use strict; sort @a', + bcopts => [qw/ -basic -concise -exec /], + #noanchors => 1, + errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + ); + +checkOptree + ( name => 'useless use of sort in void context', + prog => 'our @a; sort @a', + bcopts => [qw/ -basic -concise -exec /], + errs => 'Useless use of sort in void context at -e line 1.', + ); + +checkOptree + ( name => 'cmdline -basic -concise -exec works', + prog => 'our @a; sort @a', + bcopts => [qw/ -basic -concise -exec /], + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v # 3 <#> gv[*a] s