optreecheck.pm

source of perl for linux application,

       'expect_nt-nonthreaded'	=> '',
       'expect-threaded'	=> '',
       );

#######
sub getCmdLine {	# import assistant
    # offer help
    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    },
	  mydumper(\%gOpts))
	if grep /help/, @ARGV;

    # replace values for each key !! MUST MARK UP %gOpts
    foreach my $opt (keys %gOpts) {

	# scan ARGV for known params
	if (ref $gOpts{$opt} eq 'ARRAY') {

	    # $opt is a One-Of construct
	    # replace with valid selection from the list

	    # uhh this WORKS. but it's inscrutable
	    # grep s/$opt=(\w+)/grep {$_ eq $1} @ARGV and $gOpts{$opt}=$1/e, @ARGV;
	    my $tval;  # temp
	    if (grep s/$opt=(\w+)/$tval=$1/e, @ARGV) {
		# check val before accepting
		my @allowed = @{$gOpts{$opt}};
		if (grep { $_ eq $tval } @allowed) {
		    $gOpts{$opt} = $tval;
		}
		else {die "invalid value: '$tval' for $opt\n"}
	    }

	    # take 1st val as default
	    $gOpts{$opt} = ${$gOpts{$opt}}[0]
		if ref $gOpts{$opt} eq 'ARRAY';
        }
        else { # handle scalars

	    # if 'opt' is present, true
	    $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", mydumper(\%gOpts))
	if $gOpts{help} or $gOpts{dump};

    exit if $gOpts{help};
}
# the above arg-handling cruft should be replaced by a Getopt call

##############################
# the API (1 function)

sub checkOptree {
    my $tc = newTestCases(@_);	# ctor
    my ($rendering);

    print "checkOptree args: ",mydumper($tc) if $tc->{dump};
    SKIP: {
	skip("$tc->{skip} $tc->{name}", 1) if $tc->{skip};

	return runSelftest($tc) if $gOpts{selftest};

	$tc->getRendering();	# get the actual output
	$tc->checkErrs();

	local $Level = $Level + 2;
      TODO:
	foreach my $want (@{$modes{$gOpts{testmode}}}) {
	    local $TODO = $tc->{todo} if $tc->{todo};

	    $tc->{cross} = $msgs{"$want-$thrstat"};

	    $tc->mkCheckRex($want);
	    $tc->mylike();
	}
    }
    return;
}

sub newTestCases {
    # make test objects (currently 1) from args (passed to checkOptree)
    my $tc = bless { @_ }, __PACKAGE__
	or die "test cases are hashes";

    $tc->label();

    # cpy globals into each test
    foreach my $k (keys %gOpts) {
	if ($gOpts{$k}) {
	    $tc->{$k} = $gOpts{$k} unless defined $tc->{$k};
	}
    }
    # 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";
	}
    }
    return $tc;
}

sub label {
    # may help get/keep test output consistent
    my ($tc) = @_;
    return $tc->{name} if $tc->{name};

    my $buf = (ref $tc->{bcopts}) 
	? join(',', @{$tc->{bcopts}}) : $tc->{bcopts};

    foreach (qw( note prog code )) {
	$buf .= " $_: $tc->{$_}" if $tc->{$_} and not ref $tc->{$_};
    }
    return $tc->{name} = $buf;
}

#################
# render and its helpers

sub getRendering {
    my $tc = shift;
    fail("getRendering: code or prog is required")
	unless $tc->{code} or $tc->{prog};

    my @opts = get_bcopts($tc);
    my $rendering = ''; # suppress "Use of uninitialized value in open"
    my @errs;		# collect errs via 


    if ($tc->{prog}) {
	$rendering = runperl( switches => ['-w',join(',',"-MO=Concise",@opts)],
			      prog => $tc->{prog}, stderr => 1,
			      ); # verbose => 1);
    } else {
	my $code = $tc->{code};
	unless (ref $code eq 'CODE') {
	    # treat as source, and wrap into subref 
	    #  in caller's package ( to test arg-fixup, comment next line)
	    my $pkg = '{ package '.caller(1) .';';
	    {
		no strict;
		no warnings;
		$code = eval "$pkg sub { $code } }";
	    }
	    # return errors
	    if ($@) { chomp $@; push @errs, $@ }
	}
	# set walk-output b4 compiling, which writes 'announce' line
	walk_output(\$rendering);

	my $opwalker = B::Concise::compile(@opts, $code);
	die "bad BC::compile retval" unless ref $opwalker eq 'CODE';

      B::Concise::reset_sequence();
	$opwalker->();

	# kludge error into rendering if its empty.
	$rendering = $@ if $@ and ! $rendering;
    }
    # 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 $tc->{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 ($tc) = shift;
    my @opts = ();
    if ($tc->{bcopts}) {
	@opts = (ref $tc->{bcopts} eq 'ARRAY')
	    ? @{$tc->{bcopts}} : ($tc->{bcopts});
    }
    return @opts;
}

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);
    $tc->{goterrs} ||= [];
    @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") 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)

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.

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

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 simplifies
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]+\)\)';;

sub mkCheckRex {
    # converts expected text into Regexp which should match against
    # unaltered version.  also adjusts threaded => non-threaded
    my ($tc, $want) = @_;
    eval "no re 'debug'";

    my $str = $tc->{expect} || $tc->{expect_nt};	# standard bias
    $str = $tc->{$want} if $want && $tc->{$want};	# stated pref

    die("no '$want' golden-sample found: $tc->{name}") unless $str;

    $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;

    # make targ args wild
    $str =~ s/\[t\d+\]/[t\\d+]/msg;

    # escape bracing, etc.. manual \Q (doesnt escape '+')
    $str =~ s/([\[\]()*.\$\@\#\|{}])/\\$1/msg;
    # $str =~ s/(?<!\\)([\[\]\(\)*.\$\@\#\|{}])/\\$1/msg;

    # treat dbstate like nextstate (no in-debugger false reports)
    # Note also that there may be 1 level of () nexting, if there's an eval
    # Seems easiest to explicitly match the eval, rather than trying to parse
    # for full balancing and then substitute .*?
    # In which case, we can continue to match for the eval in the rexexp built
    # from the golden result.

    $str =~ s!(?:next|db)state
	      \\\(			# opening literal ( (backslash escaped)
	      [^()]*?			# not ()
	      (\\\(eval\ \d+\\\)	# maybe /eval \d+/ in ()
	       [^()]*?			# which might be followed by something
	      )?
	      \\\)			# closing literal )
	     !'(?:next|db)state\\([^()]*?' .
	      ($1 && '\\(eval \\d+\\)[^()]*')	# Match the eval if present
	      . '\\)'!msgxe;
    # widened for -terse mode
    $str =~ s/(?:next|db)state/(?:next|db)state/msg;
    if (!$using_open && $tc->{strip_open_hints}) {
      $str =~ s[(			# capture
		 \(\?:next\|db\)state	# the regexp matching next/db state
		 .*			# all sorts of things follow it
		 v			# The opening v
		)
		(?:(:>,<,%,\\{)		# hints when open.pm is in force
		   |(:>,<,%))		# (two variations)
		(\ ->[0-9a-z]+)?
		$
	       ]
	[$1 . ($2 && ':{') . $4]xegm;	# change to the hints without open.pm
    }

    if ($] < 5.009) {
	# 5.8.x doesn't provide the hints in the OP, which means that
	# B::Concise doesn't show the symbolic hints. So strip all the
	# symbolic hints from the golden results.
	$str =~ s[(			# capture
		   \(\?:next\|db\)state	# the regexp matching next/db state
		   .*			# all sorts of things follow it
		  v			# The opening v
		  )
		  :(?:\\[{*]		# \{ or \*
		      |[^,\\])		# or other symbols on their own
		    (?:,
		     (?:\\[{*]
			|[^,\\])
		      )*		# maybe some more joined with commas
		(\ ->[0-9a-z]+)?
		$
	       ]
	[$1$2]xgm;			# change to the hints without flags
    }

    # don't care about:
    $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;		# FAKE line numbers
    $str =~ s/match\\\(.*?\\\)/match\(.*?\)/msg;	# match args