From: Jim Cromie Date: Sun, 16 Jan 2005 17:16:00 +0000 (-0700) Subject: Re: [patch] decrufting OptreeCheck stuff X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=19e169bfb15baa663525996999bfeb9bd76bdc62;p=p5sagit%2Fp5-mst-13.2.git Re: [patch] decrufting OptreeCheck stuff Message-ID: <41EB03C0.7030509@divsol.com> (with minor typos fixed) p4raw-id: //depot/perl@23891 --- diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 668b378..e13b249 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -346,7 +346,7 @@ my @linenoise = my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; -sub op_flags { +sub op_flags { # common flags (see BASOP.op_flags in op.h) my($x) = @_; my(@v); push @v, "v" if ($x & 3) == 1; @@ -519,7 +519,8 @@ sub fmt_line { # generate text-line for op. return $text; # suppress empty lines } -my %priv; +our %priv; # used to display each opcode's BASEOP.op_private values + $priv{$_}{128} = "LVINTRO" for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", @@ -913,48 +914,74 @@ sophisticated and flexible. =head1 EXAMPLE -Here's is a short example of output (aka 'rendering'), using the -default formatting conventions : +Here's an example of 2 outputs (aka 'renderings'), using the +-exec and -basic (i.e. default) formatting conventions on the same code +snippet. + + % perl -MO=Concise,-exec -e '$a = $b + 42' + 1 <0> enter + 2 <;> nextstate(main 1 -e:1) v + 3 <#> gvsv[*b] s + 4 <$> const[IV 42] s + * 5 <2> add[t3] sK/2 + 6 <#> gvsv[*a] s + 7 <2> sassign vKS/2 + 8 <@> leave[1 ref] vKP/REFC + +Each line corresponds to an opcode. The opcode marked with '*' is used +in a few examples below. + +The 1st column is the op's sequence number, starting at 1, and is +displayed in base 36 by default. This rendering is in -exec (i.e. +execution) order. + +The symbol between angle brackets indicates the op's type, for +example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is +used in threaded perls. (see L). + +The opname, as in B<'add[t1]'>, which may be followed by op-specific +information in parentheses or brackets (ex B<'[t1]'>). + +The op-flags (ex B<'sK/2'>) follow, and are described in (L). % perl -MO=Concise -e '$a = $b + 42' 8 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 1 -e:1) v ->3 7 <2> sassign vKS/2 ->8 - 5 <2> add[t1] sK/2 ->6 + * 5 <2> add[t1] sK/2 ->6 - <1> ex-rv2sv sK/1 ->4 3 <$> gvsv(*b) s ->4 4 <$> const(IV 42) s ->5 - <1> ex-rv2sv sKRM*/1 ->7 6 <$> gvsv(*a) s ->7 -Each line corresponds to an opcode. Null ops appear as C, -where I is the op that has been optimized away by perl. +The default rendering is top-down, so they're not in execution order. +This form reflects the way the stack is used to parse and evaluate +expressions; the add operates on the two terms below it in the tree. -The number on the first row indicates the op's sequence number. It's -given in base 36 by default. +Nullops appear as C, where I is an op that has been +optimized away by perl. They're displayed with a sequence-number of +'-', because they are not executed (they don't appear in previous +example), they're printed here because they reflect the parse. -The symbol between angle brackets indicates the op's type : for example, -<2> is a BINOP, <@> a LISTOP, etc. (see L). +The arrow points to the sequence number of the next op; they're not +displayed in -exec mode, for obvious reasons. -The opname may be followed by op-specific information in parentheses -(e.g. C), and by targ information in brackets (e.g. -C). +Note that because this rendering was done on a non-threaded perl, the +PADOPs in the previous examples are now SVOPs, and some (but not all) +of the square brackets have been replaced by round ones. This is a +subtle feature to provide some visual distinction between renderings +on threaded and un-threaded perls. -Next come the op flags. The common flags are listed below -(L). The private flags follow, separated -by a slash. For example, C means that the leave op has -public flags OPf_WANT_VOID, OPf_KIDS, and OPf_PARENS, and the private -flag OPpREFCOUNTED. - -Finally an arrow points to the sequence number of the next op. =head1 OPTIONS Arguments that don't start with a hyphen are taken to be the names of subroutines to print the OPs of; if no such functions are specified, the main body of the program (outside any subroutines, and not -including use'd or require'd files) is printed. Passing C, +including use'd or require'd files) is rendered. Passing C, C, C, or C will cause all of the corresponding special blocks to be printed. @@ -974,8 +1001,9 @@ These options control the 'vertical display' of opcodes. The display Print OPs in the order they appear in the OP tree (a preorder traversal, starting at the root). The indentation of each OP shows its -level in the tree. This mode is the default, so the flag is included -simply for completeness. +level in the tree, and the '->' at the end of the line indicates the +next opcode in execution order. This mode is the default, so the flag +is included simply for completeness. =item B<-exec> @@ -1162,12 +1190,14 @@ B:: namespace that represents the ops in your Perl code. =head2 OP flags abbreviations -These symbols represent various flags which alter behavior of the -opcode, sometimes in opcode-specific ways. +OP flags are either public or private. The public flags alter the +behavior of each opcode in consistent ways, and are represented by 0 +or more single characters. v OPf_WANT_VOID Want nothing (void context) s OPf_WANT_SCALAR Want single value (scalar context) l OPf_WANT_LIST Want list of any length (list context) + Want is unknown K OPf_KIDS There is a firstborn child. P OPf_PARENS This operator was parenthesized. (Or block needs explicit scope entry.) @@ -1177,6 +1207,18 @@ opcode, sometimes in opcode-specific ways. S OPf_STACKED Some arg is arriving on the stack. * OPf_SPECIAL Do something weird for this op (see op.h) +Private flags, if any are set for an opcode, are displayed after a '/' + + 8 <@> leave[1 ref] vKP/REFC ->(end) + 7 <2> sassign vKS/2 ->8 + +They're opcode specific, and occur less often than the public ones, so +they're represented by short mnemonics instead of single-chars; see +L for gory details, or try this quick 2-liner: + + $> perl -MB::Concise -de 1 + DB<1> |x \%B::Concise::priv + =head1 FORMATTING SPECIFICATIONS For each line-style ('concise', 'terse', 'linenoise', etc.) there are @@ -1303,7 +1345,7 @@ The target of the OP, or nothing for a nulled OP. =item B<#firstaddr> -The address of the OP's first child, in hexidecimal. +The address of the OP's first child, in hexadecimal. =item B<#flags> @@ -1324,7 +1366,7 @@ mode, or empty otherwise. =item B<#lastaddr> -The address of the OP's last child, in hexidecimal. +The address of the OP's last child, in hexadecimal. =item B<#name> @@ -1340,7 +1382,7 @@ The sequence number of the OP's next OP. =item B<#nextaddr> -The address of the OP's next OP, in hexidecimal. +The address of the OP's next OP, in hexadecimal. =item B<#noise> @@ -1383,11 +1425,11 @@ Only available in 5.9 and later. =item B<#sibaddr> -The address of the OP's next youngest sibling, in hexidecimal. +The address of the OP's next youngest sibling, in hexadecimal. =item B<#svaddr> -The address of the OP's SV, if it has an SV, in hexidecimal. +The address of the OP's SV, if it has an SV, in hexadecimal. =item B<#svclass> @@ -1468,9 +1510,10 @@ several styles. =head2 add_callback() -If your newly minted styles refer to any #variables, you'll need to -define a callback subroutine that will populate (or modify) those -variables. They are then available for use in the style you've chosen. +If your newly minted styles refer to any new #variables, you'll need +to define a callback subroutine that will populate (or modify) those +variables. They are then available for use in the style you've +chosen. The callbacks are called for each opcode visited by Concise, in the same order as they are added. Each subroutine is passed five @@ -1499,8 +1542,8 @@ STDOUT. You can reuse this, and can change the rendering style used each time; thereafter the coderef renders in the new style. B lets you change the print destination from STDOUT to -another open filehandle, or (unless you've built with -Uuseperlio) -into a string passed as a ref. +another open filehandle, or into a string passed as a ref (unless +you've built perl with -Uuseperlio). my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1 walk_output(\my $buf); diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm index f8e2995..fed8bb2 100644 --- a/ext/B/t/OptreeCheck.pm +++ b/ext/B/t/OptreeCheck.pm @@ -1,7 +1,12 @@ -# non-package OptreeCheck.pm -# pm allows 'use OptreeCheck', which also imports -# no package decl means all functions defined into main -# otherwise, it's like "require './test.pl'" + +package OptreeCheck; +use base 'Exporter'; +require "test.pl"; + +# now export checkOptree, and those test.pl functions used by tests +our @EXPORT = qw( checkOptree plan skip skip_all pass is like unlike + require_ok runperl ); + =head1 NAME @@ -9,27 +14,44 @@ 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). It -invokes B::Concise upon sample code, and checks that it 'agrees' with -reference renderings. +OptreeCheck supports 'golden-sample' regression testing of perl's +parser, optimizer, bytecode generator, via a single function: +checkOptree(%in). + +It invokes B::Concise upon the sample code, checks that the rendering +'agrees' with the golden sample, and reports mismatches. + +Additionally, the module processes @ARGV (which is typically unused in +the Core test harness), and thus provides a means to run the tests in +various modes. + +=head1 EXAMPLE + + # your test file + use OptreeCheck; + plan tests => 1; checkOptree ( - name => "test-name', # optional, (synth from others) + name => "test-name', # optional, made from others if not given - # 2 kinds of code-under-test: must provide 1 + # code-under-test: must provide 1 of them 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 => 'Useless variable "@main::a" .*' # str, regex, [str+] [regex+], + + # various test options # 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 + # retry => 1 # retry on test failure + # debug => 1, # use re 'debug' for retried failures !! + + # the 'golden-sample's, (must provide both) - expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT' ); # start HERE-DOCS # 1 <;> nextstate(main 45 optree.t:23) v # 2 <0> padsv[$a:45,46] M/LVINTRO # 3 <1> leavesub[1 ref] K/REFC,1 @@ -39,126 +61,223 @@ reference renderings. # 3 <1> leavesub[1 ref] K/REFC,1 EONT_EONT -=head1 checkOptree(%in) Overview + __END__ + +=head2 Failure Reports + + Heres a sample failure, as induced by the following command. + Note the argument; option=value, after the test-file, more on that later + + $> PERL_CORE=1 ./perl ext/B/t/optree_check.t testmode=cross + ... + ok 19 - canonical example w -basic + not ok 20 - -exec code: $a=$b+42 + # Failed at test.pl line 249 + # got '1 <;> nextstate(main 600 optree_check.t:208) v + # 2 <#> gvsv[*b] s + # 3 <$> const[IV 42] s + # 4 <2> add[t3] sK/2 + # 5 <#> gvsv[*a] s + # 6 <2> sassign sKS/2 + # 7 <1> leavesub[1 ref] K/REFC,1 + # ' + # expected /(?ms-xi:^1 <;> (?:next|db)state(.*?) v + # 2 <\$> gvsv\(\*b\) s + # 3 <\$> const\(IV 42\) s + # 4 <2> add\[t\d+\] sK/2 + # 5 <\$> gvsv\(\*a\) s + # 6 <2> sassign sKS/2 + # 7 <1> leavesub\[\d+ refs?\] K/REFC,1 + # $)/ + # got: '2 <#> gvsv[*b] s' + # want: (?-xism:2 <\$> gvsv\(\*b\) s) + # got: '3 <$> const[IV 42] s' + # want: (?-xism:3 <\$> const\(IV 42\) s) + # got: '5 <#> gvsv[*a] s' + # want: (?-xism:5 <\$> gvsv\(\*a\) s) + # remainder: + # 2 <#> gvsv[*b] s + # 3 <$> const[IV 42] s + # 5 <#> gvsv[*a] s + # these lines not matched: + # 2 <#> gvsv[*b] s + # 3 <$> const[IV 42] s + # 5 <#> gvsv[*a] s + +Errors are reported 3 different ways; + +The 1st form is directly from test.pl's like() and unlike(). Note +that this form is used as input, so you can easily cut-paste results +into test-files you are developing. Just make sure you recognize +insane results, to avoid canonizing them as golden samples. + +The 2nd and 3rd forms show only the unexpected results and opcodes. +This is done because it's blindingly tedious to find a single opcode +causing the failure. 2 different ways are done in case one is +unhelpful. + +=head1 TestCase Overview + +checkOptree(%tc) constructs a testcase object from %tc, and then calls +methods which eventually call test.pl's like() to produce test +results. + +=head2 getRendering + +getRendering() runs code or prog through B::Concise, and captures its +rendering. Errors emitted during rendering are checked against +expected errors, and are reported as diagnostics by default, or as +failures if 'report=fail' cmdline-option is given. + +prog is run in a sub-shell, with $bcopts passed through. This is the way +to run code intended for main. The code arg in contrast, is always a +CODEREF, either because it starts that way as an arg, or because it's +wrapped and eval'd as $sub = sub {$code}; + +=head2 mkCheckRex + +mkCheckRex() selects the golden-sample for the threaded-ness of the +platform, and produces a regex which matches the expected rendering, +and fails when it doesn't match. + +The regex includes 'workarounds' which accommodate expected rendering +variations. These include: + + string constants # avoid injection + line numbers, etc # args of nexstate() + hexadecimal-numbers + + pad-slot-assignments # for 5.8 compat, and testmode=cross + (map|grep)(start|while) # for 5.8 compat + +=head2 mylike + +mylike() calls either unlike() or like(), depending on +expectations. Mismatch reports are massaged, because the actual +difference can easily be lost in the forest of opcodes. + +=head1 checkOptree API and Operation + +Since the arg is a hash, the api is wide-open, and this really is +about what elements must be or are in the hash, and what they do. %tc +is passed to newTestCase(), the ctor, which adds in %proto, a global +prototype object. + +=head2 name => STRING + +If name property is not provided, it is synthesized from these params: +bcopts, note, prog, code. This is more convenient than trying to do +it manually. + +=head2 code or prog + +Either code or prog must be present. + +=head2 prog => $perl_source_string + +prog => $src provides a snippet of code, which is run in a sub-process, +via test.pl:runperl, and through B::Concise like so: -optreeCheck() calls getRendering(), which runs code or prog through -B::Concise, and captures its rendering. + './perl -w -MO=Concise,$bcopts_massaged -e $src' -It then calls mkCheckRex() to produce a regex which will match the -expected rendering, and fail when it doesn't match. +=head2 code => $perl_source_string || CODEREF -Finally, it compares the 2; like($rendering,/$regex/,$testname). +The $code arg is passed to B::Concise::compile(), and run in-process. +If $code is a string, it's first wrapped and eval'd into a $coderef. +In either case, $coderef is then passed to B::Concise::compile(): + $subref = eval "sub{$code}"; + $render = B::Concise::compile($subref)->(); -=head1 checkOptree(%Args) API +=head2 expect and expect_nt -Accepts %Args, with following requirements and actions: +expect and expect_nt args are the B renderings, and are +sampled from known-ok threaded and un-threaded bleadperl (5.9.1) builds. +They're both required, and the correct one is selected for the platform +being tested, and saved into the synthesized property B. -Either code or prog must be present. prog is some source code, and is -passed through via test.pl:runperl, to B::Concise like this: (bcopts -are fixed up for cmdline) +=head2 bcopts => $bcopts || [ @bcopts ] - './perl -w -MO=Concise,$bcopts_massaged -e $src' +When getRendering() runs, it passes bcopts into B::Concise::compile(). +The bcopts arg can be a singls string, or an array of strings. -code is a subref, or $src, like above. If it's not a subref, it's -treated like source-code, is wrapped as a subroutine, and is passed to -B::Concise::compile(). +=head2 errs => $err_str_regex || [ @err_str_regexs ] - $subref = eval "sub{$src}"; - B::Concise::compile($subref). +getRendering() processes the code or prog arg under warnings, and both +parsing and optree-traversal errors are collected. These are +validated against the one or more errors you specify. -expect and expect_nt are the reference optree renderings. Theyre -required, except when the code/prog compilation fails. +=head1 testcase modifier properties -I suppose I should also explain these more, but they seem obvious. +These properties are set as %tc parameters to change test behavior. - # prog => 'sort @a', # run in subprocess, aka -MO=Concise - # noanchors => 1, # no /^$/. needed for 1-liners like above +=head2 skip => 'reason' - # 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 +invokes skip('reason'), causing test to skip. -=head1 Test Philosophy +=head2 todo => 'reason' -2 platforms --> 2 reftexts: You want an accurate test, independent of -which platform you're on. So, two refdata properties, 'expect' and -'expect_nt', carry renderings taken from threaded and non-threaded -builds. This has several benefits: +invokes todo('reason') - 1. native reference data allows closer matching by regex. - 2. samples can be eyeballed to grok t-nt differences. - 3. data can help to validate mkCheckRex() operation. - 4. can develop regexes which accomodate t-nt differences. - 5. can test with both native and cross+converted regexes. +=head2 fail => 1 -Cross-testing (expect_nt on threaded, expect on non-threaded) exposes -differences in B::Concise output, so mkCheckRex has code to do some -cross-test manipulations. This area needs more work. +For code arguments, this option causes getRendering to redirect the +rendering operation to STDERR, which causes the regex match to fail. -=head1 Test Modes +=head2 retry => 1 -One consequence of a single-function API is difficulty controlling -test-mode. Ive chosen for now to use a package hash, %gOpts, to store -test-state. These properties alter checkOptree() function, either -short-circuiting to selftest, or running a loop that runs the testcase -2^N times, varying conditions each time. (current N is 2 only). +If retry is set, and a test fails, it is run a second time, possibly +with regex debug. -So Test-mode is controlled with cmdline args, also called options below. -Run with 'help' to see the test-state, and how to change it. +=head2 debug => 1 -=head2 selftest +If a failure is retried, this turns on eval "use re 'debug'", thus +turning on regex debug. It's quite verbose, and not hugely helpful. -This argument invokes runSelftest(), which tests a regex against the -reference renderings that they're made from. Failure of a regex match -its 'mold' is a strong indicator that mkCheckRex is buggy. +=head2 noanchors => 1 -That said, selftest mode currently runs a cross-test too, they're not -completely orthogonal yet. See below. +If set, this relaxes the regex check, which is normally pretty strict. +It's used primarily to validate checkOptree via tests in optree_check. -=head2 testmode=cross -Cross-testing is purposely creating a T-NT mismatch, looking at the -fallout, and tweaking the regex to deal with it. Thus tests lead to -'provably' complete understanding of the differences. +=head1 Synthesized object properties -The tweaking appears contrary to the 2-refs philosophy, but the tweaks -will be made in conversion-specific code, which (will) handles T->NT -and NT->T separately. The tweaking is incomplete. +These properties are added into the test object during execution. -A reasonable 1st step is to add tags to indicate when TonNT or NTonT -is known to fail. This needs an option to force failure, so the -test.pl reporting mechanics show results to aid the user. +=head2 wanted -=head2 testmode=native +This stores the chosen expect expect_nt string. The OptreeCheck +object may in the future delete the raw strings once wanted is set, +thus saving space. -This is normal mode. Other valid values are: native, cross, both. +=head2 cross => 1 -=head2 checkOptree Notes +This tag is added if testmode=cross is passed in as argument. +It causes test-harness to purposely use the wrong string. -Accepts test code, renders its optree using B::Concise, and matches that -rendering against a regex built from one of 2 reference-renderings %in data. -The regex is built by mkCheckRex(\%in), which scrubs %in data to -remove match-irrelevancies, such as (args) and [args]. For example, -it strips leading '# ', making it easy to cut-paste new tests into -your test-file, run it, and cut-paste actual results into place. You -then retest and reedit until all 'errors' are gone. (now make sure you -haven't 'enshrined' a bug). +=head2 checkErrs + +checkErrs() is a getRendering helper that verifies that expected errs +against those found when rendering the code on the platform. It is +run after rendering, and before mkCheckRex. + +Errors can be reported 3 different ways; diag, fail, print. + + diag - uses test.pl _diag() + fail - causes double-testing + print-.no # in front of the output (may mess up test harnesses) + +The 3 ways are selectable at runtimve via cmdline-arg: +report={diag,fail,print}. + -name: The test name. May be augmented by a label, which is built from -important params, and which helps keep names in sync with whats being -tested.' =cut use Config; use Carp; use B::Concise qw(walk_output); -use Data::Dumper; -$Data::Dumper::Sortkeys = 1; BEGIN { $SIG{__WARN__} = sub { @@ -167,8 +286,12 @@ BEGIN { }; } -# but wait - more skullduggery ! -sub OptreeCheck::import { &getCmdLine; } # process @ARGV +sub import { + my $pkg = shift; + $pkg->export_to_level(1,'checkOptree', @EXPORT); + getCmdLine(); # process @ARGV +} + # %gOpts params comprise a global test-state. Initial values here are # HELP strings, they MUST BE REPLACED by runtime values before use, as @@ -177,52 +300,49 @@ sub OptreeCheck::import { &getCmdLine; } # process @ARGV our %gOpts = # values are replaced at runtime !! ( # scalar values are help string - rextract => 'writes src-code todo same Optree matching', - vbasic => 'prints $str and $rex', retry => 'retry failures after turning on re debug', - retrydbg => 'retry failures after turning on re debug', + debug => 'turn on re debug for those retries', selftest => 'self-tests mkCheckRex vs the reference rendering', - selfdbg => 'redo failing selftests with re debug', - xtest => 'extended thread/non-thread testing', + fail => 'force all test to fail, print to stdout', dump => 'dump cmdline arg prcessing', - rexpedant => 'try tighter regex, still buggy', noanchors => 'dont anchor match rex', - help => 0, # 1 ends in die # array values are one-of selections, with 1st value as default - testmode => [qw/ native cross both /], + # array: 2nd value is used as help-str, 1st val (still) default + help => [0, 'provides help and exits', 0], + 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 + # reporting mode for rendering errs + report => [qw/ diag fail print /], + errcont => [1, 'if 1, tests match even if report is fail', 0], + # fixup for VMS, cygwin, which dont have stderr b4 stdout 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', + errs => 'expected compile errs, array if several', ); # Not sure if this is too much cheating. Officially we say that -# $Config::Config{usethreads} is true if some sort of threading is in use, -# in which case we ought to be able to use it in place of the || below. -# However, it is now possible to Configure perl with "threads" but neither -# ithreads or 5005threads, which forces the re-entrant APIs, but no perl -# user visible threading. This seems to have the side effect that most of perl -# doesn't think that it's threaded, hence the ops aren't threaded either. -# Not sure if this is actually a "supported" configuration, but given that -# ponie uses it, it's going to be used by something official at least in the -# interim. So it's nice for tests to all pass. +# $Config::Config{usethreads} is true if some sort of threading is in +# use, in which case we ought to be able to use it in place of the || +# below. However, it is now possible to Configure perl with "threads" +# but neither ithreads or 5005threads, which forces the re-entrant +# APIs, but no perl user visible threading. + +# This seems to have the side effect that most of perl doesn't think +# that it's threaded, hence the ops aren't threaded either. Not sure +# if this is actually a "supported" configuration, but given that +# ponie uses it, it's going to be used by something official at least +# in the interim. So it's nice for tests to all pass. + our $threaded = 1 if $Config::Config{useithreads} || $Config::Config{use5005threads}; our $platform = ($threaded) ? "threaded" : "plain"; our $thrstat = ($threaded) ? "threaded" : "nonthreaded"; -our ($MatchRetry,$MatchRetryDebug); # let mylike be generic -# test.pl-ish hack -*MatchRetry = \$gOpts{retry}; # but alias it into %gOpts -*MatchRetryDebug = \$gOpts{retrydbg}; # but alias it into %gOpts - our %modes = ( both => [ 'expect', 'expect_nt'], native => [ ($threaded) ? 'expect' : 'expect_nt'], @@ -234,9 +354,9 @@ our %modes = ( our %msgs # announce cross-testing. = ( # cross-platform - 'expect_nt-threaded' => " (Non-threaded-ref on Threaded-build)", - 'expect-nonthreaded' => " (Threaded-ref on Non-threaded-build)", - # native - nothing to say + 'expect_nt-threaded' => " (nT on T) ", + 'expect-nonthreaded' => " (T on nT) ", + # native - nothing to say (must stay empty - used for $crosstesting) 'expect_nt-nonthreaded' => '', 'expect-threaded' => '', ); @@ -247,7 +367,7 @@ sub getCmdLine { # import assistant print(qq{\n$0 accepts args to update these state-vars: turn on a flag by typing its name, select a value from list by typing name=val.\n }, - Dumper \%gOpts) + mydumper(\%gOpts)) if grep /help/, @ARGV; # replace values for each key !! MUST MARK UP %gOpts @@ -278,197 +398,122 @@ sub getCmdLine { # import assistant else { # handle scalars # if 'opt' is present, true - $gOpts{$opt} = (grep /$opt/, @ARGV) ? 1 : 0; + $gOpts{$opt} = (grep /^$opt/, @ARGV) ? 1 : 0; # override with 'foo' if 'opt=foo' appears grep s/$opt=(.*)/$gOpts{$opt}=$1/e, @ARGV; } } - print("$0 heres current state:\n", Dumper \%gOpts) + print("$0 heres current state:\n", mydumper(\%gOpts)) if $gOpts{help} or $gOpts{dump}; exit if $gOpts{help}; } # the above arg-handling cruft should be replaced by a Getopt call -################################## -# API +############################## +# the API (1 function) sub checkOptree { - my %in = @_; - my ($in, $res) = (\%in,0); # set up privates. + my $tc = newTestCases(@_); # ctor + my ($rendering); - print "checkOptree args: ",Dumper \%in if $in{dump}; + print "checkOptree args: ",mydumper($tc) if $tc->{dump}; 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; + skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip}; - return runSelftest(\%in) if $gOpts{selftest}; + return runSelftest($tc) if $gOpts{selftest}; - my ($rendering,@errs) = getRendering(\%in); # get the actual output + $tc->getRendering(); # get the actual output + $tc->checkErrs(); - 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 .. TODO: foreach $want (@{$modes{$gOpts{testmode}}}) { - local $TODO = $in{todo} if $in{todo}; - - my ($rex,$txt,$rexstr) = mkCheckRex(\%in,$want); - my $cross = $msgs{"$want-$thrstat"}; - - # bad is anticipated failure on cross testing ONLY - my $bad = (0 or ( $cross && $in{crossfail}) - or (!$cross && $in{fail}) - or 0); # no undefs! pedant - - # couldn't bear to pass \%in to likeyn - $res = mylike ( # custom test mode stuff - [ !$bad, - $in{retry} || $gOpts{retry}, - $in{debug} || $gOpts{retrydbg}, - $rexstr, - ], - # remaining is std API - $rendering, qr/$rex/ms, "$cross $in{name} $in{label}") - || 0; - printhelp(\%in, $rendering, $rex); + local $TODO = $tc->{todo} if $tc->{todo}; + + $tc->{cross} = $msgs{"$want-$thrstat"}; + + $tc->mkCheckRex($want); + $tc->mylike(); } } $res; } -################# -# helpers - -sub label { - # may help get/keep test output consistent - my ($in) = @_; - return if $in->{name}; +sub newTestCases { + # make test objects (currently 1) from args (passed to checkOptree) + my $tc = bless { @_ }, __PACKAGE__ + or die "test cases are hashes"; - my $buf = (ref $in->{bcopts}) - ? join(',', @{$in->{bcopts}}) : $in->{bcopts}; - - foreach (qw( note prog code )) { - $buf .= " $_: $in->{$_}" if $in->{$_} and not ref $in->{$_}; - } - return $in->{label} = $buf; -} + $tc->label(); -sub testCombo { - # generate a set of test-cases from the options - my $in = @_; - my @cases; - foreach $want (@{$modes{$gOpts{testmode}}}) { - push @cases, [ %in ] + # cpy globals into each test + foreach $k (keys %gOpts) { + if ($gOpts{$k}) { + $tc->{$k} = $gOpts{$k} unless defined $tc->{$k}; + } } - return @cases; -} - -sub runSelftest { - # tests the test-cases offered (expect, expect_nt) - # needs Unification with above. - my ($in) = @_; - my $ok; - foreach $want (@{$modes{$gOpts{testmode}}}) {} - - for my $provenance (qw/ expect expect_nt /) { - next unless $in->{$provenance}; - my ($rex,$gospel) = mkCheckRex($in, $provenance); - return unless $gospel; - - my $cross = $msgs{"$provenance-$thrstat"}; - my $bad = (0 or ( $cross && $in->{crossfail}) - or (!$cross && $in->{fail}) - or 0); - # couldn't bear to pass \%in to likeyn - $res = mylike ( [ !$bad, - $in->{retry} || $gOpts{retry}, - $in->{debug} || $gOpts{retrydbg}, - #label($in) - ], - $rendering, qr/$rex/ms, "$cross $in{name}") - || 0; + # transform errs to self-hash for efficient set-math + if ($tc->{errs}) { + if (not ref $tc->{errs}) { + $tc->{errs} = { $tc->{errs} => 1}; + } + elsif (ref $tc->{errs} eq 'ARRAY') { + my %errs; + @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}}; + $tc->{errs} = \%errs; + } + elsif (ref $tc->{errs} eq 'Regexp') { + warn "regexp err matching not yet implemented"; + } } - $ok; + return $tc; } -# use re; -sub mylike { - # note dependence on unlike() - my ($control) = shift; - my ($yes,$retry,$debug,$postmortem) = @$control; # or dies - my ($got, $expected, $name, @mess) = @_; # pass thru mostly - - die "unintended usage, expecting Regex". Dumper \@_ - unless ref $_[1] eq 'Regexp'; - - #ok($got=~/$expected/, "wow"); +sub label { + # may help get/keep test output consistent + my ($tc) = @_; + return $tc->{name} if $tc->{name}; - # same as A ^ B, but B has side effects - my $ok = ( (!$yes and unlike($got, $expected, $name, @mess)) - or ($yes and like($got, $expected, $name, @mess))); - - if (not $ok and $postmortem) { - # split rexstr into units that should eat leading lines. - my @rexs = map qr/^$_/, split (/\n/,$postmortem); - foreach my $rex (@rexs) { - #$got =~ s/($rex)/ate: $1/msg; # noisy - $got =~ s/($rex)\n//msg; # remove matches - } - print "these lines not matched:\n$got\n"; - } + my $buf = (ref $tc->{bcopts}) + ? join(',', @{$tc->{bcopts}}) : $tc->{bcopts}; - if (not $ok and $retry) { - # redo, perhaps with use re debug - NOT ROBUST - eval "use re 'debug'" if $debug; - $ok = (!$yes and unlike($got, $expected, "(RETRY) $name", @mess) - or $yes and like($got, $expected, "(RETRY) $name", @mess)); - - no re 'debug'; + foreach (qw( note prog code )) { + $buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_}; } - return $ok; + return $tc->{name} = $buf; } +################# +# render and its helpers + sub getRendering { - my ($in) = @_; - die "getRendering: code or prog is required\n" - unless $in->{code} or $in->{prog}; + my $tc = shift; + fail("getRendering: code or prog is required") + unless $tc->{code} or $tc->{prog}; - my @opts = get_bcopts($in); + my @opts = get_bcopts($tc); my $rendering = ''; # suppress "Use of uninitialized value in open" my @errs; # collect errs via - if ($in->{prog}) { + if ($tc->{prog}) { $rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)], - prog => $in->{prog}, stderr => 1, + prog => $tc->{prog}, stderr => 1, ); # verbose => 1); } else { - my $code = $in->{code}; + my $code = $tc->{code}; unless (ref $code eq 'CODE') { - # treat as source, and wrap - $code = eval "sub { $code }"; + # treat as source, and wrap into subref + # in caller's package ( to test arg-fixup, comment next line) + my $pkg = '{ package '.caller(1) .';'; + $code = eval "$pkg sub { $code } }"; # return errors - push @errs, $@ if $@; + if ($@) { chomp $@; push @errs, $@ } } # set walk-output b4 compiling, which writes 'announce' line walk_output(\$rendering); - if ($in->{fail}) { + if ($tc->{fail}) { fail("forced failure: stdout follows"); walk_output(\*STDOUT); } @@ -477,49 +522,109 @@ sub getRendering { B::Concise::reset_sequence(); $opwalker->(); + + # kludge error into rendering if its empty. + $rendering = $@ if $@ and ! $rendering; } - if ($in->{strip}) { + # separate banner, other stuff whose printing order isnt guaranteed + if ($tc->{strip}) { $rendering =~ s/(B::Concise::compile.*?\n)//; - print "stripped from rendering <$1>\n" if $1 and $in->{stripv}; + print "stripped from rendering <$1>\n" if $1 and $tc->{stripv}; - while ($rendering =~ s/^(.*?-e line .*?\n)//g) { - print "stripped <$1>\n" if $in->{stripv}; + #while ($rendering =~ s/^(.*?(-e) line \d+\.)\n//g) { + while ($rendering =~ s/^(.*?(-e|\(eval \d+\).*?) line \d+\.)\n//g) { + print "stripped <$1> $2\n" if $tc->{stripv}; push @errs, $1; } $rendering =~ s/-e syntax OK\n//; $rendering =~ s/-e had compilation errors\.\n//; } + $tc->{got} = $rendering; + $tc->{goterrs} = \@errs if @errs; return $rendering, @errs; } sub get_bcopts { # collect concise passthru-options if any - my ($in) = shift; + my ($tc) = shift; my @opts = (); - if ($in->{bcopts}) { - @opts = (ref $in->{bcopts} eq 'ARRAY') - ? @{$in->{bcopts}} : ($in->{bcopts}); + if ($tc->{bcopts}) { + @opts = (ref $tc->{bcopts} eq 'ARRAY') + ? @{$tc->{bcopts}} : ($tc->{bcopts}); } return @opts; } -=head1 mkCheckRex +sub checkErrs { + # check rendering errs against expected errors, reduce and report + my $tc = shift; + + # check for agreement, by hash (order less important) + my (%goterrs, @got); + @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}}; + + foreach my $k (keys %{$tc->{errs}}) { + if (@got = grep /^$k$/, keys %goterrs) { + delete $tc->{errs}{$k}; + delete $goterrs{$_} foreach @got; + } + } + $tc->{goterrs} = \%goterrs; + + # relook at altered + if (%{$tc->{errs}} or %{$tc->{goterrs}}) { + $tc->diag_or_fail(); + } + fail("FORCED: $tc->{name}:\n$rendering") if $gOpts{fail}; # silly ? +} + +sub diag_or_fail { + # help checkErrs + my $tc = shift; + + my @lines; + push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}}; + push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}}; + + if (@lines) { + unshift @lines, $tc->{name}; + my $report = join("\n", @lines); + + if ($gOpts{report} eq 'diag') { _diag ($report) } + elsif ($gOpts{report} eq 'fail') { fail ($report) } + else { print ($report) } + next unless $gOpts{errcont}; # skip block + } +} + +=head1 mkCheckRex ($tc) -mkCheckRex receives the full testcase object, and constructs a regex. -1st, it selects a reftxt from either the expect or expect_nt items. +It selects the correct golden-sample from the test-case object, and +converts it into a Regexp which should match against the original +golden-sample (used in selftest, see below), and on the renderings +obtained by applying the code on the perl being tested. + +The 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. -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 +The selected golden-sample is massaged to eliminate various match +irrelevancies. This is done so that the tests dont fail just because +you added a line to the top of the test file. (Recall that the +renderings contain the program's line numbers). Similar cleanups are +done on "strings", hex-constants, etc. + +The need to massage is reflected in the 2 golden-sample approach of +the test-cases; we want the match to be as rigorous as possible, and +thats easier to achieve when matching against 1 input than 2. + 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 @@ -536,16 +641,25 @@ my $announce = 'B::Concise::compile\(CODE\(0x[0-9a-f]+\)\)';; sub mkCheckRex { # converts expected text into Regexp which should match against # unaltered version. also adjusts threaded => non-threaded - my ($in, $want) = @_; + my ($tc, $want) = @_; eval "no re 'debug'"; - my $str = $in->{expect} || $in->{expect_nt}; # standard bias - $str = $in->{$want} if $want; # stated pref + my $str = $tc->{expect} || $tc->{expect_nt}; # standard bias + $str = $tc->{$want} if $want && $tc->{$want}; # stated pref - #fail("rex-str is empty, won't allow false positives") unless $str; + die("no '$want' golden-sample found: $tc->{name}") unless $str; - $str =~ s/^\# //mg; # ease cut-paste testcase authoring - my $reftxt = $str; # extra return val !! + $str =~ s/^\# //mg; # ease cut-paste testcase authoring + + if ($] < 5.009) { + # add 5.8 private flags, which bleadperl (5.9.1) doesn't have/use/render + # works because it adds no wildcards, which are butchered below.. + $str =~ s|(mapstart l?K\*?)|$1/2|mg; + $str =~ s|(grepstart l?K\*?)|$1/2|msg; + $str =~ s|(mapwhile.*? l?K)|$1/1|msg; + $str =~ s|(grepwhile.*? l?K)|$1/1|msg; + } + $tc->{wantstr} = $str; # convert all (args) and [args] to temp forms wo bracing $str =~ s/\[(.*?)\]/__CAPSQR$1__/msg; @@ -560,7 +674,7 @@ sub mkCheckRex { $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; $str =~ s/__CAPRND(.*?)__\b/\\($1\\)/msg; # nested () in nextstate - # no 'invisible' failures in debugger + # treat dbstate like nextstate (no in-debugger false reports) $str =~ s/(?:next|db)state(\\\(.*?\\\))/(?:next|db)state(.*?)/msg; # widened for -terse mode $str =~ s/(?:next|db)state/(?:next|db)state/msg; @@ -571,10 +685,16 @@ sub mkCheckRex { $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/(\d refs?)/\\d+ refs?/msg; # 1 ref, 2+ refs (plural) $str =~ s/leavesub \[\d\]/leavesub [\\d]/msg; # for -terse + #$str =~ s/(\s*)\n/\n/msg; # trailing spaces + + # these fix up pad-slot assignment args + if ($] < 5.009 or $tc->{cross}) { + $str =~ s/\[t\d+\\]/\[t\\d+\\]/msg; # pad slot assignments + } - croak "no reftext found for $want: $in->{name}" + croak "no reftext found for $want: $tc->{name}" unless $str =~ /\w+/; # fail unless a real test # $str = '.*' if 1; # sanity test @@ -582,33 +702,211 @@ sub mkCheckRex { # allow -eval, banner at beginning of anchored matches $str = "(-e .*?)?(B::Concise::compile.*?)?\n" . $str - unless $in->{noanchors} or $in->{rxnoorder}; + unless $tc->{noanchors} or $tc->{rxnoorder}; eval "use re 'debug'" if $debug; - my $qr = ($in->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ; + my $qr = ($tc->{noanchors}) ? qr/$str/ms : qr/^$str$/ms ; no re 'debug'; - return ($qr, $reftxt, $str) if wantarray; - return $qr; + $tc->{rex} = $qr; + $tc->{rexstr} = $str; + $tc; } +############## +# compare and report -sub printhelp { - # crufty - may be still useful - my ($in, $rendering, $rex) = @_; - print "<$rendering>\nVS\n<$rex>\n" if $gOpts{vbasic}; +sub mylike { + # reworked mylike to use hash-obj + my $tc = shift; + my $got = $tc->{got}; + my $want = $tc->{rex}; + my $cmnt = $tc->{name}; + my $cross = $tc->{cross}; + + my $msgs = $tc->{msgs}; + my $retry = $tc->{retry}; # || $gopts{retry}; + my $debug = $tc->{debug}; #|| $gopts{retrydbg}; + + # bad is anticipated failure + my $bad = (0 or ( $cross && $tc->{crossfail}) + or (!$cross && $tc->{fail}) + or 0); # no undefs ! + + # same as A ^ B, but B has side effects + my $ok = ( $bad && unlike ($got, $want, $cmnt, @$msgs) + or !$bad && like ($got, $want, $cmnt, @$msgs)); + + reduceDiffs ($tc) if not $ok; + + if (not $ok and $retry) { + # redo, perhaps with use re debug - NOT ROBUST + eval "use re 'debug'" if $debug; + $ok = ( $bad && unlike ($got, $want, "(RETRY) $cmnt", @$msgs) + or !$bad && like ($got, $want, "(RETRY) $cmnt", @$msgs)); + eval "no re 'debug'"; + } + return $ok; +} - # save this output to afile, edit out 'ok's and 1..N - # then perl -d afile, and add re 'debug' to suit. - print("\$str = q%$rendering%;\n". - "\$rex = qr%$rex%;\n\n". - #"print \"\$str =~ m%\$rex%ms \";\n". - "\$str =~ m{\$rex}ms or print \"doh\\n\";\n\n") - if $in{rextract} or $gOpts{rextract}; +sub reduceDiffs { + # isolate the real diffs and report them. + # i.e. these kinds of errs: + # 1. missing or extra ops. this skews all following op-sequences + # 2. single op diff, the rest of the chain is unaltered + # in either case, std err report is inadequate; + + my $tc = shift; + my $got = $tc->{got}; + my @got = split(/\n/, $got); + my $want = $tc->{wantstr}; + my @want = split(/\n/, $want); + + # split rexstr into units that should eat leading lines. + my @rexs = map qr/$_/, split (/\n/, $tc->{rexstr}); + + foreach my $rex (@rexs) { + my $exp = shift @want; + my $line = shift @got; + # remove matches, and report + unless ($got =~ s/($rex\n)//msg) { + _diag("got:\t\t'$line'\nwant:\t $rex\n"); + } + } + _diag("remainder:\n$got"); + _diag("these lines not matched:\n$got\n"); } +=head1 Global modes + +Unusually, this module also processes @ARGV for command-line arguments +which set global modes. These 'options' change the way the tests run, +essentially reusing the tests for different purposes. -######################### + + +Additionally, there's an experimental control-arg interface (i.e. +subject to change) which allows the user to set global modes. + + +=head1 Testing Method + +At 1st, optreeCheck used one reference-text, but the differences +between Threaded and Non-threaded renderings meant that a single +reference (sampled from say, threaded) would be tricky and iterative +to convert for testing on a non-threaded build. Worse, this conflicts +with making tests both strict and precise. + +We now use 2 reference texts, the right one is used based upon the +build's threaded-ness. This has several benefits: + + 1. native reference data allows closer/easier matching by regex. + 2. samples can be eyeballed to grok T-nT differences. + 3. data can help to validate mkCheckRex() operation. + 4. can develop regexes which accomodate T-nT differences. + 5. can test with both native and cross-converted regexes. + +Cross-testing (expect_nt on threaded, expect on non-threaded) exposes +differences in B::Concise output, so mkCheckRex has code to do some +cross-test manipulations. This area needs more work. + +=head1 Test Modes + +One consequence of a single-function API is difficulty controlling +test-mode. I've chosen for now to use a package hash, %gOpts, to store +test-state. These properties alter checkOptree() function, either +short-circuiting to selftest, or running a loop that runs the testcase +2^N times, varying conditions each time. (current N is 2 only). + +So Test-mode is controlled with cmdline args, also called options below. +Run with 'help' to see the test-state, and how to change it. + +=head2 selftest + +This argument invokes runSelftest(), which tests a regex against the +reference renderings that they're made from. Failure of a regex match +its 'mold' is a strong indicator that mkCheckRex is buggy. + +That said, selftest mode currently runs a cross-test too, they're not +completely orthogonal yet. See below. + +=head2 testmode=cross + +Cross-testing is purposely creating a T-NT mismatch, looking at the +fallout, which helps to understand the T-NT differences. + +The tweaking appears contrary to the 2-refs philosophy, but the tweaks +will be made in conversion-specific code, which (will) handles T->NT +and NT->T separately. The tweaking is incomplete. + +A reasonable 1st step is to add tags to indicate when TonNT or NTonT +is known to fail. This needs an option to force failure, so the +test.pl reporting mechanics show results to aid the user. + +=head2 testmode=native + +This is normal mode. Other valid values are: native, cross, both. + +=head2 checkOptree Notes + +Accepts test code, renders its optree using B::Concise, and matches +that rendering against a regex built from one of 2 reference +renderings %tc data. + +The regex is built by mkCheckRex(\%tc), which scrubs %tc data to +remove match-irrelevancies, such as (args) and [args]. For example, +it strips leading '# ', making it easy to cut-paste new tests into +your test-file, run it, and cut-paste actual results into place. You +then retest and reedit until all 'errors' are gone. (now make sure you +haven't 'enshrined' a bug). + +name: The test name. May be augmented by a label, which is built from +important params, and which helps keep names in sync with whats being +tested. + +=cut + +sub runSelftest { + # tests the regex produced by mkCheckRex() + # by using on the expect* text it was created with + # failures indicate a code bug, + # OR regexs plugged into the expect* text (which defeat conversions) + my $tc = shift; + + for my $provenance (qw/ expect expect_nt /) { + #next unless $tc->{$provenance}; + + $tc->mkCheckRex($provenance); + $tc->{got} = $tc->{wantstr}; # fake the rendering + $tc->mylike(); + } +} + +my $dumploaded = 0; + +sub mydumper { + + do { Dumper(@_); return } if $dumploaded; + + eval "require Data::Dumper" + or do{ + print "Sorry, Data::Dumper is not available\n"; + print "half hearted attempt:\n"; + foreach $it (@_) { + if (ref $it eq 'HASH') { + print " $_ => $it->{$_}\n" foreach sort keys %$it; + } + } + return; + }; + + Data::Dumper->import; + $Data::Dumper::Sortkeys = 1; + $dumploaded++; + Dumper(@_); +} + +############################ # support for test writing sub preamble { @@ -643,8 +941,10 @@ checkOptree(note => q{$comment}, code => q{$code}, expect => < < < < <<'EOT_EOT', expect_nt => <<'EONT_EONT'}; @@ -691,7 +991,9 @@ sub OptreeCheck::gentest { sub OptreeCheck::processExamples { my @files = @_; - # gets array of paragraphs, which should be tests. + + # gets array of paragraphs, which should be code-samples. Theyre + # turned into optreeCheck tests, foreach my $file (@files) { open (my $fh, $file) or die "cant open $file: $!\n"; @@ -738,7 +1040,8 @@ bugs. To that end, OptreeCheck has support for developing new tests, according to the following model: 1. write a set of sample code into a single file, one per - paragraph. f_map and f_sort in ext/B/t/ are examples. + paragraph. Add <=for gentest> blocks if you care to, or just look at + f_map and f_sort in ext/B/t/ for examples. 2. run OptreeCheck as a program on the file @@ -755,19 +1058,6 @@ according to the following model: the gots into the expects, easier than running step 2 on both builds then trying to sdiff them together. -=head1 TODO - -There's a considerable amount of cruft in the whole arg-handling setup. -I'll replace / strip it before 5.10 - -Treat %in as a test object, interwork better with Test::* - -Refactor mkCheckRex() and selfTest() to isolate the selftest, -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 diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index 851428d..25bed73 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -13,25 +13,28 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } if (!$Config::Config{useperlio}) { print "1..0 # Skip -- need perlio to walk the optree\n"; exit 0; } - if ($] < 5.009) { - print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; - exit 0; - } - require q(test.pl); + # require q(test.pl); # now done by OptreeCheck } use OptreeCheck; plan tests => 9; +=head1 f_map.t + +Code test snippets here are adapted from `perldoc -f map` + +Due to a bleadperl optimization (Dave Mitchell, circa may 04), the +(map|grep)(start|while) opcodes have different flags in 5.9, their +private flags /1, /2 are gone in blead (for the cases covered) + +When the optree stuff was integrated into 5.8.6, these tests failed, +and were todo'd. Theyre now done, by version-specific tweaking in +mkCheckRex(), therefore the skip is removed too. + =for gentest # chunk: #!perl diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t index 729b244..7b34713 100644 --- a/ext/B/t/f_sort.t +++ b/ext/B/t/f_sort.t @@ -17,20 +17,22 @@ BEGIN { print "1..0 # Skip -- need perlio to walk the optree\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - if ($] < 5.009) { - print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; - exit 0; - } - require q(test.pl); + # require q(test.pl); # now done by OptreeCheck; } use OptreeCheck; plan tests => 20; +=head1 f_sort.t + +Code test snippets here are adapted from `perldoc -f map` + +Due to a bleadperl optimization (Dave Mitchell, circa apr 04), the +(map|grep)(start|while) opcodes have different flags in 5.9, their +private flags /1, /2 are gone in blead (for the cases covered) + +When the optree stuff was integrated into 5.8.6, these tests failed, +and were todo'd. Theyre now done, by version-specific tweaking in +mkCheckRex(), therefore the skip is removed too. =head1 Test Notes diff --git a/ext/B/t/optree_check.t b/ext/B/t/optree_check.t index af1dbab..03ccbcb 100644 --- a/ext/B/t/optree_check.t +++ b/ext/B/t/optree_check.t @@ -13,12 +13,7 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - require 'test.pl'; + # require 'test.pl'; # now done by OptreeCheck } use OptreeCheck; @@ -34,11 +29,10 @@ cmdline args in 'standard' way across all clients of OptreeCheck. =cut -use Config; -plan tests => 5 + 18 + 14 * $gOpts{selftest}; # fudged +plan tests => 5 + 15 + 16 * $gOpts{selftest}; # pass()s + $#tests SKIP: { - skip "no perlio in this build", 5 + 18 + 14 * $gOpts{selftest} + skip "no perlio in this build", 5 + 17 + 14 * $gOpts{selftest} unless $Config::Config{useperlio}; @@ -59,7 +53,7 @@ checkOptree ( name => "found print opcode", expect_nt => 'leavesub'); checkOptree ( name => 'test skip itself', - skip => 1, + skip => 'this is skip-reason', bcopts => '-exec', code => sub {print 1}, expect => 'dont-care, skipping', @@ -75,11 +69,11 @@ checkOptree ( name => 'test todo itself', code => sub {print 1}, noanchors => 1, # unanchored match expect => 'print', - expect_nt => 'print'); + expect_nt => 'print') if 0; checkOptree ( name => 'impossible match, remove skip to see failure', todo => "see! it breaks!", - skip => 1, # but skip it 1st + skip => 'skip the failure', code => sub {print 1}, expect => 'look out ! Boy Wonder', expect_nt => 'holy near earth asteroid Batman !'); @@ -89,16 +83,7 @@ pass ("TEST FATAL ERRS"); if (1) { # test for fatal errors. Im unsettled on fail vs die. # calling fail isnt good enough by itself. - eval { - - checkOptree ( name => 'empty code or prog', - todo => "your excuse here ;-)", - code => '', - prog => '', - ); - }; - like($@, 'code or prog is required', 'empty code or prog prevented'); - + $@=''; eval { checkOptree ( name => 'test against empty expectations', @@ -107,7 +92,7 @@ if (1) { expect => '', expect_nt => ''); }; - like($@, 'no reftext found for', "empty expectations prevented"); + like($@, /no '\w+' golden-sample found/, "empty expectations prevented"); $@=''; eval { @@ -118,31 +103,37 @@ if (1) { expect_nt => "\n", expect => "\n"); }; - like($@, 'no reftext found for', "just whitespace expectations prevented"); + like($@, /no '\w+' golden-sample found/, + "just whitespace expectations prevented"); } - + pass ("TEST -e \$srcCode"); -checkOptree - ( name => '-w errors seen', - prog => 'sort our @a', - errs => 'Useless use of sort in void context at -e line 1.', - ); +checkOptree ( name => 'empty code or prog', + skip => 'or fails', + todo => "your excuse here ;-)", + code => '', + prog => '', + ); checkOptree ( name => "self strict, catch err", prog => 'use strict; bogus', errs => 'Bareword "bogus" not allowed while "strict subs" in use at -e line 1.', + expect => "nextstate", # simple expectations + expect_nt => "nextstate", + noanchors => 1, # allow them to work ); -checkOptree ( name => "sort vK - flag specific search", - prog => 'sort our @a', +checkOptree ( name => "sort lK - flag specific search", + prog => 'our (@a,@b); @b = sort @a', noanchors => 1, - expect => '<@> sort vK ', - expect_nt => '<@> sort vK '); + expect => '<@> sort lK ', + expect_nt => '<@> sort lK '); -checkOptree ( name => "'prog' => 'sort our \@a'", +checkOptree ( name => "sort vK - flag specific search", prog => 'sort our @a', + errs => 'Useless use of sort in void context at -e line 1.', noanchors => 1, expect => '<@> sort vK', expect_nt => '<@> sort vK'); @@ -214,13 +205,8 @@ EOT_EOT # 5 <$> gvsv(*a) s ->6 EONT_EONT -checkOptree ( name => 'canonical example w -exec', +checkOptree ( code => '$a=$b+42', bcopts => '-exec', - code => sub{$a=$b+42}, - crossfail => 1, - retry => 1, - debug => 1, - xtestfail => 1, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <;> nextstate(main 61 optree_concise.t:139) v # 2 <#> gvsv[*b] s @@ -239,9 +225,6 @@ EOT_EOT # 7 <1> leavesub[1 ref] K/REFC,1 EONT_EONT -checkOptree ( name => 'tree reftext is messy cut-paste', - skip => 1); - } # skip __END__ diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t index 00a04cb..b839fb8 100644 --- a/ext/B/t/optree_concise.t +++ b/ext/B/t/optree_concise.t @@ -13,19 +13,14 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - require 'test.pl'; + # require 'test.pl'; # now done by OptreeCheck } # import checkOptree(), and %gOpts (containing test state) use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! use Config; -plan tests => 24; +plan tests => 23; SKIP: { skip "no perlio in this build", 24 unless $Config::Config{useperlio}; @@ -40,11 +35,11 @@ checkOptree ( name => 'canonical example w -basic', bcopts => '-basic', code => sub{$a=$b+42}, expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); -# 7 <1> leavesub[\d+ refs?] K/REFC,1 ->(end) +# 7 <1> leavesub[1 ref] K/REFC,1 ->(end) # - <@> lineseq KP ->7 # 1 <;> nextstate(foo bar) v ->2 # 6 <2> sassign sKS/2 ->7 -# 4 <2> add[t\d+] sK/2 ->5 +# 4 <2> add[t3] sK/2 ->5 # - <1> ex-rv2sv sK/1 ->3 # 2 <#> gvsv[*b] s ->3 # 3 <$> const[IV 42] s ->4 @@ -212,8 +207,11 @@ EONT_EONT pass("OPTIONS IN CMDLINE MODE"); -checkOptree ( name => 'cmdline invoke -basic works', - prog => 'sort @a', +checkOptree ( name => 'cmdline invoke -basic works', + prog => 'sort @a', + errs => [ 'Useless use of sort in void context at -e line 1.', + 'Name "main::a" used only once: possible typo at -e line 1.', + ], #bcopts => '-basic', # default expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 7 <@> leave[1 ref] vKP/REFC ->(end) @@ -233,10 +231,13 @@ EOT_EOT # 4 <$> gv(*a) s ->5 EONT_EONT -checkOptree ( name => 'cmdline invoke -exec works', - prog => 'sort @a', - bcopts => '-exec', - expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +checkOptree ( name => 'cmdline invoke -exec works', + prog => 'sort @a', + errs => [ 'Useless use of sort in void context at -e line 1.', + 'Name "main::a" used only once: possible typo at -e line 1.', + ], + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 1 <0> enter 2 <;> nextstate(main 1 -e:1) v 3 <0> pushmark s @@ -255,33 +256,33 @@ EOT_EOT 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.', + errs => 'Global symbol "@a" requires explicit package name at -e line 1.', + expect => 'nextstate', + expect_nt => 'nextstate', + noanchors => 1, # allow simple expectations to work ); 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.', + note => 'this test relys on a kludge which copies $@ to rendering when empty', + expect => 'Global symbol', + expect_nt => 'Global symbol', + noanchors => 1, # allow simple expectations to work ); checkOptree ( name => 'cmdline -basic -concise -exec works', prog => 'our @a; sort @a', bcopts => [qw/ -basic -concise -exec /], + errs => ['Useless use of sort in void context at -e line 1.'], expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); # 1 <0> enter # 2 <;> nextstate(main 1 -e:1) v diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 13b0282..442ae6a 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -13,16 +13,7 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - if ($] < 5.009) { - print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n"; - exit 0; - } - require 'test.pl'; + # require 'test.pl'; # now done by OptreeCheck } use OptreeCheck; use Config; diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t index be7dc52..278ebd7 100644 --- a/ext/B/t/optree_sort.t +++ b/ext/B/t/optree_sort.t @@ -13,12 +13,7 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - require 'test.pl'; + # require 'test.pl'; # now done by OptreeCheck } use OptreeCheck; use Config; @@ -48,10 +43,13 @@ EOT_EOT # 6 <1> leavesub[1 ref] K/REFC,1 EONT_EONT -checkOptree ( name => 'sort @a', - prog => 'sort @a', - bcopts => '-exec', - expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); +checkOptree ( name => 'sort @a', + prog => 'sort @a', + errs => [ 'Useless use of sort in void context at -e line 1.', + 'Name "main::a" used only once: possible typo at -e line 1.', + ], + bcopts => '-exec', + expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 1 <0> enter 2 <;> nextstate(main 1 -e:1) v 3 <0> pushmark s @@ -82,7 +80,7 @@ checkOptree ( name => 'sub {@a = sort @a}', 7 <0> pushmark s 8 <#> gv[*a] s 9 <1> rv2av[t2] lKRM*/1 -a <2> aassign[t\d+] KS/COMMON +a <2> aassign[t5] KS/COMMON b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 65 optree.t:311) v @@ -154,6 +152,7 @@ EONT_EONT checkOptree ( name => '@a = sort @a; reverse @a', prog => '@a = sort @a; reverse @a', + errs => ['Useless use of reverse in void context at -e line 1.'], bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 1 <0> enter @@ -198,7 +197,7 @@ checkOptree ( name => 'sub {my @a; @a = sort @a}', 7 <@> sort lK 8 <0> pushmark s 9 <0> padav[@a:-437,-436] lRM* -a <2> aassign[t\d+] KS/COMMON +a <2> aassign[t2] KS/COMMON b <1> leavesub[1 ref] K/REFC,1 EOT_EOT # 1 <;> nextstate(main 427 optree_sort.t:172) v diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t index 67053c1..6c8dcc6 100644 --- a/ext/B/t/optree_specials.t +++ b/ext/B/t/optree_specials.t @@ -20,12 +20,7 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - require 'test.pl'; + # require 'test.pl'; # now done by OptreeCheck } # import checkOptree(), and %gOpts (containing test state) diff --git a/ext/B/t/optree_varinit.t b/ext/B/t/optree_varinit.t index 25260b8..8748f29 100644 --- a/ext/B/t/optree_varinit.t +++ b/ext/B/t/optree_varinit.t @@ -13,12 +13,7 @@ BEGIN { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } - if ($Config::Config{'extensions'} !~ /\bData\/Dumper\b/) { - print - "1..0 # Skip: Data::Dumper was not built, needed by OptreeCheck\n"; - exit 0; - } - require 'test.pl'; + # require 'test.pl'; # now done by OptreeCheck } use OptreeCheck; use Config; @@ -114,6 +109,7 @@ EONT_EONT checkOptree ( name => 'local $a', prog => 'local $a', + errs => ['Name "main::a" used only once: possible typo at -e line 1.'], bcopts => '-basic', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); 4 <@> leave[1 ref] vKP/REFC ->(end) @@ -229,6 +225,7 @@ EONT_EONT checkOptree ( name => 'local $a=undef', prog => 'local $a=undef', + errs => ['Name "main::a" used only once: possible typo at -e line 1.'], note => 'locals are rare, probly not worth doing', bcopts => '-basic', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT'); @@ -343,6 +340,7 @@ EONT_EONT checkOptree ( name => 'local $a=()', prog => 'local $a=()', + errs => ['Name "main::a" used only once: possible typo at -e line 1.'], #todo => 'probly not worth doing', bcopts => '-exec', expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');