New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
enhancement patch for B::Concise #7018
Comments
From jcromie@divsol.comin case your mail browser doesnt inline the 1st attachment, heres the The patch adds 3 things: 1. B::Concise::walk_output($fh), with which you can send Concise output 2. B::Concise::add_style(), with which you can add a named style to 3. Tests for above, inc test following pod recipe for using B::Concise |
From jcromie@divsol.comCreated by jimc@harpo.jimc.earthTHIS IS AN ENHANCEMENT PATCH The patch adds 3 things: 1. B::Concise::walk_output($fh), with which you can send Concise output 2. B::Concise::add_style(), with which you can add a named style to 3. Tests for above. Tested against bleadperl. all OK. Perl Info
|
From jcromie@divsol.comInline Patchdiff -ru bleadperl/ext/B/B/Concise.pm bleadconcise/ext/B/B/Concise.pm
--- bleadperl/ext/B/B/Concise.pm Thu Aug 14 02:02:53 2003
+++ bleadconcise/ext/B/B/Concise.pm Mon Jan 5 18:24:05 2004
@@ -1,4 +1,4 @@
-package B::Concise;
+package B::Concise; # -*- perl -*-
# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
@@ -14,10 +14,11 @@
use Exporter (); # use #5
-our $VERSION = "0.57";
+our $VERSION = "0.58_01";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main);
+ concise_subref concise_cv concise_main
+ add_style walk_output);
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
@@ -59,6 +60,21 @@
($format, $gotofmt, $treefmt) = @_;
}
+sub add_style {
+ my ($newstyle,@args) = @_;
+
+ die "$newstyle already exists, choose a new name"
+ if exists $style{$newstyle};
+
+ if (@args == 1 and ref $args[0] eq 'ARRAY' and @{$args[0]} == 3) {
+ $style{$newstyle} = $args[0];
+ }
+ elsif (@args == 3) {
+ $style{$newstyle} = [@args];
+ }
+ else { die "expecting 3 format args, or array-ref of same" }
+}
+
sub set_style_standard {
my($name) = @_;
set_style(@{$style{$name}});
@@ -267,6 +283,15 @@
return base_n($sequence_num{$$op});
}
+my $walkHandle = \*STDOUT;
+
+sub walk_output {
+ $walkHandle = shift;
+ my $iotype = ref $walkHandle;
+ die "expecting GLOB, FILEHANDLE or IO::* argument"
+ unless $iotype eq 'GLOB' or $iotype =~ /^IO::/;
+}
+
sub walk_topdown {
my($op, $sub, $level) = @_;
$sub->($op, $level);
@@ -597,14 +622,15 @@
}
sub B::OP::concise {
- my($op, $level) = @_;
+ my($op, $level, $fh) = @_;
+ $fh = $walkHandle unless $fh;
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $gotofmt, $level+1);
+ print $fh fmt_line($h, $gotofmt, $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $format);
+ print $fh concise_op($op, $level, $format);
}
# B::OP::terse (see Terse.pm) now just calls this
diff -ru bleadperl/ext/B/t/concise.t bleadconcise/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bleadconcise/ext/B/t/concise.t Mon Jan 5 19:20:58 2004
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 22;
require_ok("B::Concise");
@@ -35,3 +35,166 @@
);
like($out, qr/print/, "-exec option with //=");
+
+
+=head1 test use of B::Concise outside O framework
+
+this tests set_style, add_callback, and the machinery that calls them.
+The new style adds a #nextrel item, which is not particularly useful
+as it stands, but is enough to test with.
+
+Also tests walk_output function, whereby output from B::Concise is
+written to the provided 'filehandle'. The feature allows easier
+capture and manipulation of Concise output, and is leveraged here to
+compare 3 different styles, which are set 2 different ways.
+
+=cut
+
+sub test_this {
+ # canonical example from pod
+ $a = $b + 42;
+}
+
+
+sub setup {
+ # encapsulated setup for B::Concise testing, as outlined in POD
+
+ B::Concise->import(qw(set_style add_callback add_style));
+ # use B::Concise qw(set_style add_callback);
+
+
+ # this style is closely related to default, but adds a new item
+ set_style
+ (
+ "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ # new item here:
+ . "(x(;~=>#nextrel)x)\n"
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+ # and this callback adds the new item
+ add_callback
+ ( sub {
+ my ($h, $op, $level, $format) = @_;
+
+ $h->{nextnum} = '-';
+ $n = $op->next;
+ $h->{nextnum} = $n->seq unless ref $n eq 'B::NULL';
+
+ $rel = $h->{nextnum} - $h->{seqnum};
+ #print "nextnum-seqnum: $h->{nextnum} - $h->{seqnum} = $rel\n";
+
+ $rel = ($rel>0) ? "+$rel" : "-$rel";
+ $rel = 'na' unless $h->{nextnum} > 0 and $h->{seqnum} > 0;
+ $h->{nextrel} = $rel;
+ });
+
+ # now re-add the above style, giving it a name.
+ add_style
+ ( "relative",
+ "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ # new item here:
+ . "(x(;~=>#nextrel)x)\n"
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+}
+
+# set up 'filehandles' for testing walk_output()
+my ($s1,$s2,$s3);
+open(my $f1, '>', \$s1);
+open(my $f2, '>', \$s2);
+open(my $f3, '>', \$s3);
+
+
+# invoke setup above
+setup();
+
+ B::Concise::walk_output($f1);
+ # default style - should be style set above
+ B::Concise::compile('test_this')->();
+
+ B::Concise::walk_output($f2);
+ # use concise style
+ B::Concise::compile('-concise','test_this')->();
+
+ B::Concise::walk_output($f3);
+ # use new, named style
+ B::Concise::compile('-relative','test_this')->();
+
+is ($@, '', "use outside O framework $@");
+
+#print "$s1\n$s2\n$s3\n";
+
+ok ($s1, "preset style output non-empty");
+ok ($s2, "concise style output non-empty");
+ok ($s3, "relative style output non-empty");
+
+is ($s1, $s3, "preset and relative are same");
+isnt ($s2, $s3, "concise and relative styles are different");
+
+=head2 #nextrel item
+
+The following test demonstrates the potential usefulness of #nextrel,
+hopefully well enough to elicit constructive suggestions wrt how to do
+it.
+
+The test, as currently written, is quite dependent upon sequence
+numbers; this is likely somewhat brittle wrt multiple platforms, and
+entirely dependent upon previous statements.
+
+By putting the code under test in a subroutine, and naming that
+routine as the one to be walked, I was able to eliminate the previous
+statements, and thus stabilize the numbering done by B::Concise, but
+that will not work in the general case.
+
+=cut
+
+
+my $ref = <<'EORef';
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(main -\d+ concise.t:\d+) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t1] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <$> gvsv(*b) s ->3
+3 <$> const(IV 42) s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <$> gvsv(*a) s ->6
+EORef
+
+# this test is probably somewhat brittle, despite the qr//
+like ($s2, /\Q$ref/, "matches against hardcoded reference output");
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string", [], {}) {
+ eval { B::Concise::walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects bad Handle $foo");
+}
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo ($f1, $f2, $f3, \*STDOUT, \*STDERR) {
+ eval { B::Concise::walk_output($foo) };
+ is ($@, '', "walk_output() accepts Handle $foo");
+}
+
+__END__
+
+# try more robust test, with brittle lib inclusion
+SKIP: {
+ use lib '/usr/local/lib/perl5/site_perl/5.8.2/i686-linux-thread-multi';
+
+ eval "use String::Approx 'amatch'";
+ skip("no String::Approx, $@", 1) if $@;
+
+ my @matches = amatch($s1, $s2);
+
+ print "@matches\n";
+ ok(1, "I dont have it!");
+}
+ |
From jcromie@divsol.comJim Cromie (via RT) wrote:
this version supersedes previous, and adds POD, |
From jcromie@divsol.comInline Patchdiff -ru bleadperl/ext/B/B/Concise.pm bleadconcise/ext/B/B/Concise.pm
--- bleadperl/ext/B/B/Concise.pm Thu Aug 14 02:02:53 2003
+++ bleadconcise/ext/B/B/Concise.pm Wed Jan 7 01:08:41 2004
@@ -1,4 +1,4 @@
-package B::Concise;
+package B::Concise; # -*- perl -*-
# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
@@ -14,10 +14,11 @@
use Exporter (); # use #5
-our $VERSION = "0.57";
+our $VERSION = "0.58_01";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main);
+ concise_subref concise_cv concise_main
+ add_style walk_output);
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
@@ -59,6 +60,21 @@
($format, $gotofmt, $treefmt) = @_;
}
+sub add_style {
+ my ($newstyle,@args) = @_;
+
+ die "style '$newstyle' already exists, choose a new name"
+ if exists $style{$newstyle};
+
+ if (@args == 1 and ref $args[0] eq 'ARRAY' and @{$args[0]} == 3) {
+ $style{$newstyle} = $args[0];
+ }
+ elsif (@args == 3) {
+ $style{$newstyle} = [@args];
+ }
+ else { die "expecting 3 format args, or array-ref of same" }
+}
+
sub set_style_standard {
my($name) = @_;
set_style(@{$style{$name}});
@@ -267,6 +283,15 @@
return base_n($sequence_num{$$op});
}
+my $walkHandle = \*STDOUT;
+
+sub walk_output {
+ $walkHandle = shift;
+ my $iotype = ref $walkHandle;
+ die "expecting GLOB, FILEHANDLE or IO::* argument"
+ unless $iotype eq 'GLOB' or $iotype =~ /^IO::/;
+}
+
sub walk_topdown {
my($op, $sub, $level) = @_;
$sub->($op, $level);
@@ -597,14 +622,15 @@
}
sub B::OP::concise {
- my($op, $level) = @_;
+ my($op, $level, $fh) = @_;
+ $fh = $walkHandle unless $fh;
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $gotofmt, $level+1);
+ print $fh fmt_line($h, $gotofmt, $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $format);
+ print $fh concise_op($op, $level, $format);
}
# B::OP::terse (see Terse.pm) now just calls this
@@ -1095,8 +1121,10 @@
=head1 Using B::Concise outside of the O framework
-It is possible to extend B<B::Concise> by using it outside of the B<O>
-framework and providing new styles and new variables.
+It is possible to use B<B::Concise> outside of the B<O> framework, and
+by optionally providing new styles, and new variables within those
+styles. By doing so, you escape the compile-only operation of O; you
+can use both the perl debugger and B<B::Concise> simultaneously.
use B::Concise qw(set_style add_callback);
set_style($format, $gotofmt, $treefmt);
@@ -1115,12 +1143,22 @@
existing variable, you will need to add a callback to specify the value
for that variable.
-This is done by calling B<add_callback> passing references to any
-callback subroutines. The subroutines are called in the same order as
-they are added. Each subroutine is passed four parameters. These are a
-reference to a hash, the keys of which are the names of the variables
-and the values of which are their values, the op, the level and the
-format.
+You can also create named styles by using B<add_style>, which takes an
+additional styleName argument, and registers that style for later
+selection via B::Concise::compile(). This is handy if you expect to
+use several styles iteratively. B<add_style> will die if you attempt
+to re-add a known style, whether its standard or previously added by
+you.
+
+By calling B<add_callback> and passing references to any callback
+subroutines, you can populate new variables See L<formatting
+specifications>, or alter the values of existing ones. These
+variables are then available for use in the style youve chosen.
+
+The subroutines are called in the same order as they are added. Each
+subroutine is passed four parameters. These are a reference to a
+hash, the keys of which are the names of the variables and the values
+of which are their values, the op, the level and the format.
To define your own variables, simply add them to the hash, or change
existing values if you need to. The level and format are passed in as
@@ -1128,10 +1166,15 @@
changed or even used.
To switch back to one of the standard styles like C<concise> or
-C<terse>, use C<set_style_standard>.
+C<terse>, use C<set_style_standard>, or pass the styleName into
+B::Concise::compile.
To see the output, call the subroutine returned by B<compile> in the
-same way that B<O> does.
+same way that B<O> does. B<walk_output> allows you to redirect that
+output to a file.
+
+ open (my $fh, '>', \$concise_output);
+ walk_output($fh);
=head1 AUTHOR
diff -ru bleadperl/ext/B/t/concise.t bleadconcise/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bleadconcise/ext/B/t/concise.t Wed Jan 7 01:32:20 2004
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 21;
require_ok("B::Concise");
@@ -35,3 +35,174 @@
);
like($out, qr/print/, "-exec option with //=");
+
+
+=head1 test use of B::Concise outside O framework
+
+this tests set_style, add_callback, and the machinery that calls them.
+The new style adds a #nextrel item, which is not particularly useful
+as it stands, but is enough to test with.
+
+Also tests walk_output function, whereby output from B::Concise is
+written to the provided 'filehandle'. The feature allows easier
+capture and manipulation of Concise output, and is leveraged here to
+compare 3 different styles, which are set 2 different ways.
+
+=cut
+
+B::Concise->import(qw(set_style add_callback add_style));
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string", [], {}) {
+ eval { B::Concise::walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects bad Handle $foo");
+}
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { B::Concise::walk_output($foo) };
+ is ($@, '', "walk_output() accepts Handle $foo");
+}
+
+sub test_this {
+ # canonical example from pod
+ $a = $b + 42;
+}
+
+
+my @stylespec;
+sub setup {
+ # encapsulated setup for B::Concise testing, as outlined in POD
+
+ # define a style closely related to default,
+ # but which adds a (useless) new item
+ @stylespec =
+ (
+ "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ # new item here:
+ . "(x(;~=>#nextrel)x)\n"
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+ # set that style
+ set_style (@stylespec);
+
+ # now re-add the above style, giving it a (new) name.
+ add_style ( "relative", @stylespec );
+
+ # and this callback adds the new item
+ add_callback
+ ( sub {
+ my ($h, $op, $level, $format) = @_;
+
+ $h->{nextnum} = '-';
+ $n = $op->next;
+ $h->{nextnum} = $n->seq unless ref $n eq 'B::NULL';
+
+ $rel = $h->{nextnum} - $h->{seqnum};
+ #print "nextnum-seqnum: $h->{nextnum} - $h->{seqnum} = $rel\n";
+
+ $rel = ($rel>0) ? "+$rel" : "-$rel";
+ $rel = 'na' unless $h->{nextnum} > 0 and $h->{seqnum} > 0;
+ $h->{nextrel} = $rel;
+ });
+
+}
+
+SKIP: {
+ eval "require 5.008";
+ skip("IO to \scalar requires 5.008 ", 9) if $@;
+
+ # set up 'filehandles' for testing walk_output()
+ my ($s1,$s2,$s3);
+ open(my $f1, '>', \$s1);
+ open(my $f2, '>', \$s2);
+ open(my $f3, '>', \$s3);
+
+
+# invoke setup above
+ setup();
+
+ B::Concise::walk_output($f1);
+ # default style - should be style set above
+ B::Concise::compile('test_this')->();
+
+ B::Concise::walk_output($f2);
+ # use concise style
+ B::Concise::compile('-concise','test_this')->();
+
+ B::Concise::walk_output($f3);
+ # use new, named style
+ B::Concise::compile('-relative','test_this')->();
+
+ is ($@, '', "use outside O framework $@");
+
+#print "$s1\n$s2\n$s3\n";
+
+ ok ($s1, "preset style output non-empty");
+ ok ($s2, "concise style output non-empty");
+ ok ($s3, "named style output non-empty");
+
+ is ($s1, $s3, "preset and named styles are same");
+ isnt ($s2, $s3, "concise and named styles are different");
+
+=head2 #nextrel item
+
+The following test demonstrates the potential usefulness of #nextrel,
+hopefully well enough to elicit constructive suggestions wrt how to do
+it.
+
+The test, as currently written, is quite dependent upon sequence
+numbers; this is likely somewhat brittle wrt multiple platforms, and
+entirely dependent upon previous statements.
+
+By putting the code under test in a subroutine, and naming that
+routine as the one to be walked, I was able to eliminate the previous
+statements, and thus stabilize the numbering done by B::Concise, but
+that will not work in the general case.
+
+=cut
+
+
+my $ref = <<'EORef';
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(main -\d+ concise.t:\d+) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t1] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <$> gvsv(*b) s ->3
+3 <$> const(IV 42) s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <$> gvsv(*a) s ->6
+EORef
+
+ # this test is probably somewhat brittle, despite the qr//
+ like ($s2, /\Q$ref/, "matches against hardcoded reference output");
+}
+
+eval { add_style (relative => @stylespec) };
+like ($@, qr/style 'relative' already exists, choose a new name/,
+ "correctly disallows re-adding same style-name" );
+$@='';
+B::Concise::add_style ('somename' => [@stylespec]);
+is ($@, '', "accept args stylename => arrayref");
+
+
+__END__
+
+# try more robust test, with brittle lib inclusion
+SKIP: {
+ use lib '/usr/local/lib/perl5/site_perl/5.8.2/i686-linux-thread-multi';
+
+ eval "use String::Approx 'amatch'";
+ skip("no String::Approx, $@", 1) if $@;
+
+ my @matches = amatch($s1, $s2);
+
+ print "@matches\n";
+ ok(1, "I dont have it!");
+}
+ |
From @hvdsJim Cromie <jcromie@divsol.com> wrote: This sets my alarm bells ringing: if I have a 'Hugo::File' that But the patch as a whole looks interesting, thank you. :) Hugo |
The RT System itself - Status changed from 'new' to 'open' |
From @ysthOn Tue, Jan 06, 2004 at 02:49:59AM -0000, Jim Cromie <perlbug-followup@perl.org> wrote:
Will those opens work without perlio? Do we care?
I think that like() is getting passed "" as the pattern to check, the *result* of a
Not sure exactly what that's for, but you may want instead: lib.pm is supposed to automatically also add the archname subdirectory |
From @pjcjJim Cromie said:
Thanks very much. Presumably I hadn't added any tests because you hadn't -- |
From jcromie@divsol.comPaul Johnson via RT wrote:
huh ? Ok, youre Devel::Cover Dude. If the module does not use the t/*.t framework: =head1 ACKNOWLEDGEMENTS Some code and ideas cribbed from: Devel::OpProf |
From jcromie@divsol.comYitzchak Scott-Thoennes via RT wrote:
when I ran following, the above code worked. Should it have failed ? PERLIO=stdio ./perl -Ilib ext/B/t/concise.t BTW, in 2nd version (patch.concise3) I added a SKIP: {eval "use 5.008"; ALSO, Ive added $walkHandle->can('print'). to walk_output().
Indeed - once I actually added the intended qr//, test broke.
It was mostly to test another way. I gave up when it became obvious that @INC was heavily restricted in |
From @pjcjOn Wed, Jan 07, 2004 at 12:40:41PM -0700, Jim Cromie wrote:
I wrote the code and docs for using B::Concise outside of the O And yes, it was to help me writing Devel::Cover. -- |
From jcromie@divsol.comJim Cromie wrote:
This version supersedes others. 1. walk_output() tests GLOB and ->can('print') other items [jimc@harpo bleadconcise]$ PERLIO=stdio ./perl -Ilib ext/B/t/concise.t |
From jcromie@divsol.comInline Patchdiff -ru bleadperl/ext/B/B/Concise.pm bleadconcise/ext/B/B/Concise.pm
--- bleadperl/ext/B/B/Concise.pm Thu Aug 14 02:02:53 2003
+++ bleadconcise/ext/B/B/Concise.pm Wed Jan 7 22:15:53 2004
@@ -1,4 +1,4 @@
-package B::Concise;
+package B::Concise; # -*- perl -*-
# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
@@ -14,10 +14,11 @@
use Exporter (); # use #5
-our $VERSION = "0.57";
+our $VERSION = "0.58_01";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main);
+ concise_subref concise_cv concise_main
+ add_style walk_output);
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
@@ -57,6 +58,22 @@
sub set_style {
($format, $gotofmt, $treefmt) = @_;
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle,@args) = @_;
+
+ die "style '$newstyle' already exists, choose a new name"
+ if exists $style{$newstyle};
+
+ if (@args == 1 and ref $args[0] eq 'ARRAY' and @{$args[0]} == 3) {
+ $style{$newstyle} = $args[0];
+ }
+ elsif (@args == 3) {
+ $style{$newstyle} = [@args];
+ }
+ else { die "expecting 3 format args, or array-ref of same\n" }
}
sub set_style_standard {
@@ -68,6 +85,15 @@
push @callbacks, @_;
}
+my $walkHandle = \*STDOUT; # all prints below should use this
+
+sub walk_output {
+ $walkHandle = shift;
+ my $iotype = ref $walkHandle;
+ die "expecting argument/object that can print"
+ unless $iotype eq 'GLOB' or $iotype and $walkHandle->can('print');
+}
+
sub concise_subref {
my($order, $subref) = @_;
concise_cv_obj($order, svref_2object($subref));
@@ -86,7 +112,7 @@
} elsif ($order eq "basic") {
walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
} else {
- print tree($cv->ROOT, 0)
+ print $walkHandle tree($cv->ROOT, 0)
}
}
@@ -99,7 +125,7 @@
walk_exec(main_start);
} elsif ($order eq "tree") {
return if class(main_root) eq "NULL";
- print tree(main_root, 0);
+ print $walkHandle tree(main_root, 0);
} elsif ($order eq "basic") {
return if class(main_root) eq "NULL";
walk_topdown(main_root,
@@ -116,7 +142,7 @@
pop @cv_s; # skip the CHECK block that calls us
}
for my $cv (@cv_s) {
- print "$name $i:\n";
+ print $walkHandle "$name $i:\n";
$i++;
concise_cv_obj($order, $cv);
}
@@ -194,14 +220,14 @@
B::end_av->ARRAY : ());
} else {
$objname = "main::" . $objname unless $objname =~ /::/;
- print "$objname:\n";
+ print $walkHandle "$objname:\n";
eval "concise_subref(\$order, \\&$objname)";
die "concise_subref($order, \\&$objname) failed: $@" if $@;
}
}
}
if (!@args or $do_main) {
- print "main program:\n" if $do_main;
+ print $walkHandle "main program:\n" if $do_main;
concise_main($order);
}
}
@@ -597,14 +623,15 @@
}
sub B::OP::concise {
- my($op, $level) = @_;
+ my($op, $level, $fh) = @_;
+ $fh = $walkHandle unless $fh;
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $gotofmt, $level+1);
+ print $fh fmt_line($h, $gotofmt, $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $format);
+ print $fh concise_op($op, $level, $format);
}
# B::OP::terse (see Terse.pm) now just calls this
@@ -1095,8 +1122,12 @@
=head1 Using B::Concise outside of the O framework
-It is possible to extend B<B::Concise> by using it outside of the B<O>
-framework and providing new styles and new variables.
+It is possible to use B<B::Concise> outside of the B<O> framework, and
+by optionally providing new styles, and new variables within those
+styles. By doing so, you escape the compile-only operation of O; you
+can use both the perl debugger and B<B::Concise> simultaneously.
+
+=head2 Example
use B::Concise qw(set_style add_callback);
set_style($format, $gotofmt, $treefmt);
@@ -1110,17 +1141,36 @@
);
B::Concise::compile(@options)->();
+=head2 set_style()
+
You can specify a style by calling the B<set_style> subroutine. If you
have a new variable in your style, or you want to change the value of an
existing variable, you will need to add a callback to specify the value
for that variable.
-This is done by calling B<add_callback> passing references to any
-callback subroutines. The subroutines are called in the same order as
-they are added. Each subroutine is passed four parameters. These are a
-reference to a hash, the keys of which are the names of the variables
-and the values of which are their values, the op, the level and the
-format.
+=head2 add_style()
+
+You can also create named styles by using B<add_style>, which takes an
+additional styleName argument, and registers that style for later
+selection via B::Concise::compile(). This is handy if you expect to
+use several styles iteratively.
+
+B<add_style> expects args as C<< ($styleName => @stylespec) >> or C<<
+($styleName => \@stylespec) >>, where @stylespec has 3 strings. It
+will also die if you attempt to re-add a known style, whether its
+standard or previously added by you.
+
+=head2 add_callback()
+
+By calling B<add_callback> and passing references to your callback
+subroutines, you can populate new variables See L<formatting
+specifications>, or alter the values of existing ones. These
+variables are then available for use in the style youve chosen.
+
+The subroutines are called in the same order as they are added. Each
+subroutine is passed four parameters. These are a reference to a
+hash, the keys of which are the names of the variables and the values
+of which are their values, the op, the level and the format.
To define your own variables, simply add them to the hash, or change
existing values if you need to. The level and format are passed in as
@@ -1128,10 +1178,15 @@
changed or even used.
To switch back to one of the standard styles like C<concise> or
-C<terse>, use C<set_style_standard>.
+C<terse>, use C<set_style_standard>, or pass the styleName into
+B::Concise::compile.
To see the output, call the subroutine returned by B<compile> in the
-same way that B<O> does.
+same way that B<O> does. B<walk_output> allows you to redirect that
+output to a file, or to any object that can print.
+
+ open (my $fh, '>', \$concise_output);
+ walk_output($fh);
=head1 AUTHOR
diff -ru bleadperl/ext/B/t/concise.t bleadconcise/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bleadconcise/ext/B/t/concise.t Wed Jan 7 22:17:19 2004
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 30;
require_ok("B::Concise");
@@ -35,3 +35,249 @@
);
like($out, qr/print/, "-exec option with //=");
+
+######## NEW TESTS ########
+
+B::Concise->import(qw(set_style add_callback add_style walk_output));
+my @stylespec;
+
+# test walk_output argument checking
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts Handle $foo");
+}
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string", [], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects bad Handle $foo");
+}
+$@=''; # clear the fail for next test
+
+{ # any object that can print should be ok for walk_output
+ package Hugo;
+ sub new { my $foo = bless {} };
+ sub print { CORE::print @_ }
+}
+$foo = new Hugo;
+eval { walk_output($foo) };
+is ($@, '', "walk_output() accepts obj that can print");
+
+$@='';
+eval { add_style ('junk_B' => @stylespec) };
+like ($@, 'expecting 3 format args, or array-ref of same',
+ "add_style detects insufficient args");
+
+$@='';
+eval { add_style ('junk_A' => [@stylespec]) };
+like ($@, 'expecting 3 format args, or array-ref of same',
+ "add_style detects insufficient [args]");
+
+@stylespec = (0,0,0); # right length, invalid values
+
+$@='';
+eval { add_style ('junk' => [@stylespec]) };
+is ($@, '', "add_style accepts args (stylename => arrayref)");
+
+$@='';
+eval { add_style (junk => @stylespec) };
+like ($@, qr/style 'junk' already exists, choose a new name/,
+ "add_style correctly disallows re-adding same style-name" );
+
+# test new arg-checks on set_style
+
+$@='';
+eval { set_style (@stylespec) };
+is ($@, '', "set_style accepts 3 style-format args");
+
+@stylespec = (); # bad style
+
+eval { set_style (@stylespec) };
+like ($@, qr/expecting 3 style-format args/,
+ "set_style rejects bad style-format args");
+
+
+
+=head1 test use of B::Concise outside O framework
+
+following tests set_style, add_callback, and the machinery that calls
+them. The new style adds a #nextrel item, which is not particularly
+useful as it stands, but is enough to test with.
+
+Also tests walk_output function, whereby output from B::Concise is
+written to the provided 'filehandle'. The feature allows easier
+capture and manipulation of Concise output, and is leveraged here to
+compare 3 different styles, which are set 2 different ways.
+
+=cut
+
+sub test_this {
+ # canonical example from pod
+ $a = $b + 42;
+}
+
+
+sub setup {
+ # encapsulated setup for B::Concise testing, as outlined in POD
+
+ # define a style closely related to default,
+ # but which adds a (useless) new item
+ @stylespec =
+ ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ . "(x(;~=>#nextrel)x)\n" # new 'variable' used here
+
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+ # set that style
+ set_style (@stylespec);
+
+ # now re-add the above style, giving it a (new) name.
+ add_style ( "relative", @stylespec );
+
+ # and this callback populates the new variable '#nextrel'
+ add_callback
+ ( sub {
+ my ($h, $op, $level, $format) = @_;
+
+ $h->{nextnum} = '-';
+ $n = $op->next;
+ $h->{nextnum} = $n->seq unless ref $n eq 'B::NULL';
+
+ $rel = $h->{nextnum} - $h->{seqnum};
+ #print "nextnum-seqnum: $h->{nextnum} - $h->{seqnum} = $rel\n";
+
+ $rel = ($rel>0) ? "+$rel" : "-$rel";
+ $rel = 'na' unless $h->{nextnum} > 0 and $h->{seqnum} > 0;
+ $h->{nextrel} = $rel;
+ });
+
+}
+
+my ($s1,$s2,$s3);
+
+SKIP: {
+ eval "require 5.008";
+ skip("IO to \scalar requires 5.008 ", 9) if $@;
+
+ is ($@, '', "use outside O framework $@"); # announce
+
+ # set up 'filehandles' for testing walk_output()
+ open(my $f1, '>', \$s1);
+ open(my $f2, '>', \$s2);
+ open(my $f3, '>', \$s3);
+
+ is ($@, '', "open to \scalar $@"); # in case no PERLIO
+
+# invoke setup above
+ setup();
+ is ($@, '', "setup called set_style, add_style, add_callback $@");
+
+ walk_output($f1);
+ is ($@, '', "walk_output to opened \scalar $@");
+ # default style - should be style set above
+ B::Concise::compile('test_this')->();
+
+ walk_output($f2);
+ # use concise style
+ B::Concise::compile('-concise','test_this')->();
+
+ walk_output($f3);
+ # use new, named style
+ B::Concise::compile('-relative','test_this')->();
+
+ is ($@, '', "3 calls to B::Concise::compile, wo errs $@");
+
+#print "$s1\n$s2\n$s3\n";
+
+ ok ($s1, "preset style output non-empty");
+ ok ($s2, "concise style output non-empty");
+ ok ($s3, "named style output non-empty");
+
+ is ($s1, $s3, "preset and named styles are same");
+ isnt ($s2, $s3, "concise and named styles are different");
+
+=head2 #nextrel item
+
+The following test demonstrates the potential usefulness of #nextrel,
+hopefully well enough to elicit constructive suggestions wrt how to do
+it.
+
+The test, as currently written, is quite dependent upon sequence
+numbers; this is likely somewhat brittle wrt multiple platforms, and
+entirely dependent upon previous statements.
+
+By putting the code under test in a subroutine, and naming that
+routine as the one to be walked, I was able to eliminate the previous
+statements, and thus stabilize the numbering done by B::Concise, but
+that will not work in the general case.
+
+=cut
+
+my $ref = <<'EORef';
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(main -\d+ concise.t:\d+) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t3] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <#> gvsv[*a] s ->6
+EORef
+
+ # fixup the cut-paste ref-data for use as Regexp
+ $ref =~ s/([\[\]()*.\$\@\#])/\\$1/g; # manual \Q (doesnt escape '+')
+
+ # this test is probably somewhat brittle, despite the qr//
+ #eval "use re 'debug'";
+ like ($s2, qr{^$ref$}ms, "matches against hardcoded reference output");
+
+} # SKIP
+
+
+__END__
+
+# these are interesting, but they dont add much
+# in the way of insight. maybe later..
+
+SKIP: {
+ use Config;
+ #use lib $Config::Config{sitelib};
+
+ BEGIN {
+ my $path = $Config::Config{sitelib};
+ print "libpth: $path\n";
+ $path =~ s|5.9.0||;
+ @nearpaths = <$path*>;
+ print "nearpth: @nearpaths\n";
+ }
+ use lib @nearpaths;
+
+ eval "use String::Approx 'amatch'";
+ skip("no String::Approx, $@", 1) if $@;
+
+ print "compare: $s1, $s2\n";
+
+ my @matches = amatch($s1, [qw/ I50 D50 /], $s2);
+ ok(1, "String::Approx match: @matches");
+
+ $@='';
+ eval "use Text::Levenshtein 'distance'";
+ skip("no Text::Levenshtein $@", 1) if $@;
+
+ @matches = distance($s1, $s2);
+ ok(1, "Levenshtein distance: @matches");
+
+ use Text::PhraseDistance 'pdistance';
+ @dist = pdistance ($s1,$s2,join('','a'..'z'),\&distance);
+ print "dist: @dist\n";
+
+}
+
+ |
From nick.ing-simmons@elixent.com<hv@crypt.org> writes:
And another (more OOish) way is not to check, and just get message
|
From nick.ing-simmons@elixent.comJim Cromie <jcromie@divsol.com> writes:
"Without perlio" means -Uuseperlio as perl build time, and IO is stdio The \$scalar trick won't work in that case.
|
From jcromie@divsol.comNick Ing-Simmons wrote:
This Latest revision DOES NOT remove the check, instead it adds another old error: Can't locate object method "concise" via package "B::NULL" new error: [jimc@harpo concise]$ perl outside.pl -exec Not_There [jimc@harpo concise]$ perl outside.pl Not_There The 'problem' with this is that the new die() happens too soon for the I had coded to catch the error, and then add the "Possible...", but I IE - formerly ... $> perl outside.pl Not_There main::Not_There: The "Possible bad function name" attempts to explain the cause of the error; So, Im unsure whats the best $@ report, it currently includes both the concise_subref(basic, \&main::Not_There) failed: $@ 2 new tests reflect this new check. I suppose I could now rip out all the extra die()s, since theyre not ASIDE: that outside.pl script is not part of the patch - I didnt see a thanks. |
From jcromie@divsol.comInline Patchdiff -ru -x '*.o' bleadperl/ext/B/B/Concise.pm bleadconcise/ext/B/B/Concise.pm
--- bleadperl/ext/B/B/Concise.pm Thu Aug 14 02:02:53 2003
+++ bleadconcise/ext/B/B/Concise.pm Sat Jan 10 15:01:21 2004
@@ -14,10 +14,11 @@
use Exporter (); # use #5
-our $VERSION = "0.57";
+our $VERSION = "0.58_01";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main);
+ concise_subref concise_cv concise_main
+ add_style walk_output);
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
@@ -57,6 +58,22 @@
sub set_style {
($format, $gotofmt, $treefmt) = @_;
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle,@args) = @_;
+
+ die "style '$newstyle' already exists, choose a new name"
+ if exists $style{$newstyle};
+
+ if (@args == 1 and ref $args[0] eq 'ARRAY' and @{$args[0]} == 3) {
+ $style{$newstyle} = $args[0];
+ }
+ elsif (@args == 3) {
+ $style{$newstyle} = [@args];
+ }
+ else { die "expecting 3 format args, or array-ref of same\n" }
}
sub set_style_standard {
@@ -68,9 +85,21 @@
push @callbacks, @_;
}
+my $walkHandle = \*STDOUT; # all prints below should use this
+
+sub walk_output {
+ $walkHandle = shift;
+ my $iotype = ref $walkHandle;
+ die "expecting argument/object that can print"
+ unless $iotype eq 'GLOB' or $iotype and $walkHandle->can('print');
+}
+
sub concise_subref {
- my($order, $subref) = @_;
- concise_cv_obj($order, svref_2object($subref));
+ my($order, $subref, $name) = @_;
+ my $cv = svref_2object($subref);
+ die "Possible bad function name ($name)\n"
+ if class($cv->START) eq "NULL";
+ concise_cv_obj($order, $cv, $name);
}
# This should have been called concise_subref, but it was exported
@@ -78,7 +107,7 @@
sub concise_cv { concise_subref(@_); }
sub concise_cv_obj {
- my ($order, $cv) = @_;
+ my ($order, $cv, $name) = @_;
$curcv = $cv;
sequence($cv->START);
if ($order eq "exec") {
@@ -86,7 +115,7 @@
} elsif ($order eq "basic") {
walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
} else {
- print tree($cv->ROOT, 0)
+ print $walkHandle tree($cv->ROOT, 0)
}
}
@@ -99,7 +128,7 @@
walk_exec(main_start);
} elsif ($order eq "tree") {
return if class(main_root) eq "NULL";
- print tree(main_root, 0);
+ print $walkHandle tree(main_root, 0);
} elsif ($order eq "basic") {
return if class(main_root) eq "NULL";
walk_topdown(main_root,
@@ -116,7 +145,7 @@
pop @cv_s; # skip the CHECK block that calls us
}
for my $cv (@cv_s) {
- print "$name $i:\n";
+ print $walkHandle "$name $i:\n";
$i++;
concise_cv_obj($order, $cv);
}
@@ -194,14 +223,14 @@
B::end_av->ARRAY : ());
} else {
$objname = "main::" . $objname unless $objname =~ /::/;
- print "$objname:\n";
- eval "concise_subref(\$order, \\&$objname)";
+ print $walkHandle "$objname:\n";
+ eval "concise_subref(\$order, \\&$objname, \$objname)";
die "concise_subref($order, \\&$objname) failed: $@" if $@;
}
}
}
if (!@args or $do_main) {
- print "main program:\n" if $do_main;
+ print $walkHandle "main program:\n" if $do_main;
concise_main($order);
}
}
@@ -597,14 +626,15 @@
}
sub B::OP::concise {
- my($op, $level) = @_;
+ my($op, $level, $fh) = @_;
+ $fh = $walkHandle unless $fh;
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $gotofmt, $level+1);
+ print $fh fmt_line($h, $gotofmt, $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $format);
+ print $fh concise_op($op, $level, $format);
}
# B::OP::terse (see Terse.pm) now just calls this
@@ -1095,11 +1125,16 @@
=head1 Using B::Concise outside of the O framework
-It is possible to extend B<B::Concise> by using it outside of the B<O>
-framework and providing new styles and new variables.
+You can use B<B::Concise> directly, and thereby avoid the compile-only
+operation of O. This allows you, for example, to use the debugger to
+step through B::Concise::compile() itself. When you do this, you can
+alter Concise output by optionally providing new styles, and new
+variables within those styles.
+
+=head2 example: Altering Concise Output
use B::Concise qw(set_style add_callback);
- set_style($format, $gotofmt, $treefmt);
+ set_style($your_format, $your_gotofmt, $your_treefmt);
add_callback
(
sub
@@ -1110,17 +1145,36 @@
);
B::Concise::compile(@options)->();
+=head2 set_style()
+
You can specify a style by calling the B<set_style> subroutine. If you
have a new variable in your style, or you want to change the value of an
existing variable, you will need to add a callback to specify the value
for that variable.
-This is done by calling B<add_callback> passing references to any
-callback subroutines. The subroutines are called in the same order as
-they are added. Each subroutine is passed four parameters. These are a
-reference to a hash, the keys of which are the names of the variables
-and the values of which are their values, the op, the level and the
-format.
+=head2 add_style()
+
+You can also create named styles by using B<add_style>, which takes an
+additional styleName argument, and registers that style for later
+selection via B::Concise::compile(). This is handy if you expect to
+use several styles iteratively.
+
+B<add_style> expects args as C<< ($styleName => @stylespec) >> or C<<
+($styleName => \@stylespec) >>, where @stylespec has 3 strings. It
+will also die if you attempt to re-add a known style, whether its
+standard or previously added by you.
+
+=head2 add_callback()
+
+By calling B<add_callback> and passing references to your callback
+subroutines, you can populate new variables See L<formatting
+specifications>, or alter the values of existing ones. These
+variables are then available for use in the style youve chosen.
+
+The subroutines are called in the same order as they are added. Each
+subroutine is passed four parameters. These are a reference to a
+hash, the keys of which are the names of the variables and the values
+of which are their values, the op, the level and the format.
To define your own variables, simply add them to the hash, or change
existing values if you need to. The level and format are passed in as
@@ -1128,10 +1182,33 @@
changed or even used.
To switch back to one of the standard styles like C<concise> or
-C<terse>, use C<set_style_standard>.
+C<terse>, use C<set_style_standard>, or pass the styleName into
+B::Concise::compile.
+
+=head2 Running and Getting Output
+
+To get the output, call the subroutine returned by B<compile>, it will
+print to STDOUT. In addition to the style-options, you can pass one
+or more function names to B<compile>, the function it returns will
+traverse both in order. B<walk_output> allows you to redirect that
+output to a file, or to any object that can print.
+
+ open (my $fh, '>', \$concise_output);
+ walk_output($fh);
+ B::Concise::compile('-concise','funcName')->();
+ print "Concise Results: $concise_output\n";
+
+B<compile> will die as follows you if you've asked for a non-existent
+function. (wrapped here for clarity)
+
+ main::junk:
+ concise_subref(basic, \&main::junk) failed: \
+ Possible bad function name (main::junk)
+
+=head1 CAVEATS
-To see the output, call the subroutine returned by B<compile> in the
-same way that B<O> does.
+This module issues no warnings, all errors are fatal. Use eval to
+prevent premature death.
=head1 AUTHOR
diff -ru -x '*.o' bleadperl/ext/B/t/concise.t bleadconcise/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bleadconcise/ext/B/t/concise.t Sat Jan 10 13:26:31 2004
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 31;
require_ok("B::Concise");
@@ -35,3 +35,260 @@
);
like($out, qr/print/, "-exec option with //=");
+
+######## NEW TESTS ########
+
+use Config;
+B::Concise->import(qw(set_style add_callback add_style walk_output));
+my @stylespec;
+
+# test walk_output argument checking
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts Handle $foo");
+}
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string", [], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects bad Handle $foo");
+}
+$@=''; # clear the fail for next test
+
+{ # any object that can print should be ok for walk_output
+ package Hugo;
+ sub new { my $foo = bless {} };
+ sub print { CORE::print @_ }
+}
+$foo = new Hugo; # his comment led to this test
+eval { walk_output($foo) };
+is ($@, '', "walk_output() accepts obj that can print");
+
+$@='';
+eval { add_style ('junk_B' => @stylespec) };
+like ($@, 'expecting 3 format args, or array-ref of same',
+ "add_style detects insufficient args");
+
+$@='';
+eval { add_style ('junk_A' => [@stylespec]) };
+like ($@, 'expecting 3 format args, or array-ref of same',
+ "add_style detects insufficient [args]");
+
+@stylespec = (0,0,0); # right length, invalid values
+
+$@='';
+eval { add_style ('junk' => [@stylespec]) };
+is ($@, '', "add_style accepts args (stylename => arrayref)");
+
+$@='';
+eval { add_style (junk => @stylespec) };
+like ($@, qr/style 'junk' already exists, choose a new name/,
+ "add_style correctly disallows re-adding same style-name" );
+
+# test new arg-checks on set_style
+
+$@='';
+eval { set_style (@stylespec) };
+is ($@, '', "set_style accepts 3 style-format args");
+
+@stylespec = (); # bad style
+
+eval { set_style (@stylespec) };
+like ($@, qr/expecting 3 style-format args/,
+ "set_style rejects bad style-format args");
+
+
+
+=head1 test use of B::Concise outside O framework
+
+following tests set_style, add_callback, and the machinery that calls
+them. The new style adds a #nextrel item, which is not particularly
+useful as it stands, but is enough to test with.
+
+Also tests walk_output function, whereby output from B::Concise is
+written to the provided 'filehandle'. The feature allows easier
+capture and manipulation of Concise output, and is leveraged here to
+compare 3 different styles, which are set 2 different ways.
+
+=cut
+
+sub test_this {
+ # canonical example from pod
+ $a = $b + 42;
+}
+
+
+sub setup {
+ # encapsulated setup for B::Concise testing, as outlined in POD
+
+ # define a style closely related to default,
+ # but which adds a (useless) new item
+ @stylespec =
+ ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ . "(x(;~=>#nextrel)x)\n" # new 'variable' used here
+
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+ # set that style
+ set_style (@stylespec);
+
+ # now re-add the above style, giving it a (new) name.
+ add_style ( "relative", @stylespec );
+
+ # and this callback populates the new variable '#nextrel'
+ add_callback
+ ( sub {
+ my ($h, $op, $level, $format) = @_;
+
+ $h->{nextnum} = '-';
+ $n = $op->next;
+ $h->{nextnum} = $n->seq unless ref $n eq 'B::NULL';
+
+ $rel = $h->{nextnum} - $h->{seqnum};
+ #print "nextnum-seqnum: $h->{nextnum} - $h->{seqnum} = $rel\n";
+
+ $rel = ($rel>0) ? "+$rel" : "-$rel";
+ $rel = 'na' unless $h->{nextnum} > 0 and $h->{seqnum} > 0;
+ $h->{nextrel} = $rel;
+ });
+
+}
+
+my ($s1,$s2,$s3); # 3 target strings for write to \SCALAR
+
+SKIP: {
+ eval "require 5.008";
+ skip("IO to \SCALAR requires 5.008 ", 11) if $@;
+ skip("IO to \SCALAR requires PerlIO", 11)
+ unless $Config::Config{useperlio};
+
+ is ($@, '', "\Uuse outside O framework $@"); # Announce - no test
+
+ # set up 'filehandles' for testing walk_output()
+ open(my $f1, '>', \$s1);
+ open(my $f2, '>', \$s2);
+ open(my $f3, '>', \$s3);
+
+# invoke setup above
+ setup();
+ is ($@, '', "setup called set_style, add_style, add_callback $@");
+
+ walk_output($f1);
+ is ($@, '', "walk_output to opened \scalar $@");
+ # default style - should be style set above
+ B::Concise::compile('test_this')->();
+
+ walk_output($f2);
+ # use concise style
+ B::Concise::compile('-concise','test_this')->();
+
+ walk_output($f3);
+ # use new, named style
+ B::Concise::compile('-relative','test_this')->();
+
+ is ($@, '', "3 calls to B::Concise::compile, wo errs $@");
+
+#print "$s1\n$s2\n$s3\n";
+
+ ok ($s1, "preset style output non-empty");
+ ok ($s2, "concise style output non-empty");
+ ok ($s3, "named style output non-empty");
+
+ is ($s1, $s3, "preset and named styles are same");
+ isnt ($s2, $s3, "concise and named styles are different");
+
+=head2 #nextrel item
+
+The following test demonstrates the potential usefulness of #nextrel,
+hopefully well enough to elicit constructive suggestions wrt how to do
+it.
+
+The test, as currently written, is quite dependent upon sequence
+numbers; this is likely somewhat brittle wrt multiple platforms, and
+entirely dependent upon previous statements.
+
+By putting the code under test in a subroutine, and naming that
+routine as the one to be walked, I was able to avoid extraneous
+opcodes, and thus stabilize the sequence numbering done by B::Concise,
+but that will not work in the general case.
+
+=cut
+
+my $ref = <<'EORef';
+main::test_this:
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(main -\d+ concise.t:\d+) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t3] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <#> gvsv[*a] s ->6
+EORef
+
+ # fixup the cut-paste ref-data for use as Regexp
+ $ref =~ s/([\[\]()*.\$\@\#])/\\$1/g; # manual \Q (doesnt escape '+')
+
+ # this test is probably somewhat brittle, despite the qr//
+ #eval "use re 'debug'";
+ like ($s2, qr/^$ref$/ms, "matches against hardcoded reference output");
+
+} # SKIP
+
+# walk_output(\*STDOUT); # not much to see here..
+
+eval { B::Concise::compile('-concise','non_existent_function')->() };
+like ($@, qr/Possible bad function name \(main::non_existent_function\)/,
+ "'-concise' reports non-existent-function properly");
+
+eval { B::Concise::compile('-exec','non_existent_function')->() };
+like ($@, qr/Possible bad function name \(main::non_existent_function\)/,
+ "'-exec' reports non-existent-function properly");
+
+__END__
+
+# these are interesting, but they dont add much
+# in the way of insight. maybe later..
+
+SKIP: {
+ use Config;
+ #use lib $Config::Config{sitelib};
+
+ BEGIN {
+ my $path = $Config::Config{sitelib};
+ print "libpth: $path\n";
+ $path =~ s|5.9.0||;
+ @nearpaths = <$path*>;
+ print "nearpth: @nearpaths\n";
+ }
+ use lib @nearpaths;
+
+ eval "use String::Approx 'amatch'";
+ skip("no String::Approx, $@", 1) if $@;
+
+ print "compare: $s1, $s2\n";
+
+ my @matches = amatch($s1, [qw/ I50 D50 /], $s2);
+ ok(1, "String::Approx match: @matches");
+
+ $@='';
+ eval "use Text::Levenshtein 'distance'";
+ skip("no Text::Levenshtein $@", 1) if $@;
+
+ @matches = distance($s1, $s2);
+ ok(1, "Levenshtein distance: @matches");
+
+ use Text::PhraseDistance 'pdistance';
+ @dist = pdistance ($s1,$s2,join('','a'..'z'),\&distance);
+ print "dist: @dist\n";
+
+}
+
+ |
From @pjcjOn Sat, Jan 10, 2004 at 04:02:56PM -0700, Jim Cromie wrote: Just a couple of apostrophic doc nits:
it's
you've -- |
From smcc@mit.edu
JC> Nick Ing-Simmons wrote: NI-S> And another (more OOish) way is not to check, and just get That's also my usual tendency, but I'd just chalk it up to implementor JC> This Latest revision DOES NOT remove the check, instead it adds JC> old error: JC> Can't locate object method "concise" via package "B::NULL" JC> new error: JC> [jimc@harpo concise]$ perl outside.pl -exec Not_There JC> [...] It seems to me that the "Possible" is excessively cautious: if the I've added some more comments on other topics inline in the patch. JC> diff -ru -x '*.o' bleadperl/ext/B/B/Concise.pm bleadconcise/ext/B/B/Concise.pm Please just increment by cents in whatever version eventually gets JC> our @ISA = qw(Exporter); Did you add a call to concise with a $fh argument somewhere else I JC> if ($order eq "exec" and Could you just pick one of these calling styles? It seems silly to JC> +will also die if you attempt to re-add a known style, whether its JC> +specifications>, or alter the values of existing ones. These This phrasing seems a bit alarmist to me: all of the things that cause =head2 Errors None of the above programming interfaces have error codes; they will JC> Could you think of a more future-proof description than "NEW" to JC> + I would be in favor of physically omitting them. Textual approximate JC> +SKIP: { -- Stephen |
From jcromie@divsol.comStephen McCamant wrote:
OK. While cleaning up, I added the ability to run compile() on \&subname, With \&sub args, the $funcname on 1st line of output Also, I found a bug where callback args were not per docs. Note also that I added another arg to callback invocation. I also added B::Concise::_clr_seq(), which resets the sequence. Rest below can be summarized by "OK, all suggestions accepted, acted upon", our $VERSION = "0.58";
Nope. that was 1st whack. now harmonized with other uses.
OK. only C<< ($styleName => @stylespec) >> now
Fixed. along with aphostrophe fixes from Paul
now changed to =head2 Errors, and reworded, extended
:-} now says 0.58 TESTS
Gone. I can play with them elsewhere.
thnaks |
From jcromie@divsol.comInline Patchdiff -ru -x '*.o' bleadperl/ext/B/B/Concise.pm bleadconcise/ext/B/B/Concise.pm
--- bleadperl/ext/B/B/Concise.pm Thu Aug 14 02:02:53 2003
+++ bleadconcise/ext/B/B/Concise.pm Mon Jan 12 17:05:06 2004
@@ -14,10 +14,11 @@
use Exporter (); # use #5
-our $VERSION = "0.57";
+our $VERSION = "0.58";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main);
+ concise_subref concise_cv concise_main
+ add_style walk_output);
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
@@ -54,23 +55,44 @@
my $curcv;
my $cop_seq_base;
my @callbacks;
+my $stylename;
sub set_style {
($format, $gotofmt, $treefmt) = @_;
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle,@args) = @_;
+ die "style '$newstyle' already exists, choose a new name"
+ if exists $style{$newstyle};
+ die "expecting 3 style-format args\n" unless @args == 3;
+ $style{$newstyle} = [@args];
}
sub set_style_standard {
- my($name) = @_;
- set_style(@{$style{$name}});
+ ($stylename) = @_;
+ die "err: style '$stylename' unknown" unless exists $style{$stylename};
+ set_style(@{$style{$stylename}});
}
sub add_callback {
push @callbacks, @_;
}
+my $walkHandle = \*STDOUT; # all prints below should use this
+
+sub walk_output {
+ $walkHandle = shift;
+ my $iotype = ref $walkHandle;
+ die "expecting argument/object that can print"
+ unless $iotype eq 'GLOB' or $iotype and $walkHandle->can('print');
+}
+
sub concise_subref {
- my($order, $subref) = @_;
- concise_cv_obj($order, svref_2object($subref));
+ my($order, $coderef) = @_;
+ die "err: not a coderef: $coderef\n" unless ref $coderef eq 'CODE';
+ concise_cv_obj($order, svref_2object($coderef));
}
# This should have been called concise_subref, but it was exported
@@ -80,13 +102,14 @@
sub concise_cv_obj {
my ($order, $cv) = @_;
$curcv = $cv;
+ die "err: coderef has no START\n" if class($cv->START) eq "NULL";
sequence($cv->START);
if ($order eq "exec") {
walk_exec($cv->START);
} elsif ($order eq "basic") {
walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
} else {
- print tree($cv->ROOT, 0)
+ print $walkHandle tree($cv->ROOT, 0);
}
}
@@ -99,7 +122,7 @@
walk_exec(main_start);
} elsif ($order eq "tree") {
return if class(main_root) eq "NULL";
- print tree(main_root, 0);
+ print $walkHandle tree(main_root, 0);
} elsif ($order eq "basic") {
return if class(main_root) eq "NULL";
walk_topdown(main_root,
@@ -116,7 +139,7 @@
pop @cv_s; # skip the CHECK block that calls us
}
for my $cv (@cv_s) {
- print "$name $i:\n";
+ print $walkHandle "$name $i:\n";
$i++;
concise_cv_obj($order, $cv);
}
@@ -168,7 +191,7 @@
} elsif ($o eq "-littleendian") {
$big_endian = 0;
} elsif (exists $style{substr($o, 1)}) {
- set_style(@{$style{substr($o, 1)}});
+ set_style(@{$style{$stylename = substr($o, 1)}});
} else {
warn "Option $o unrecognized";
}
@@ -193,15 +216,25 @@
B::end_av->isa("B::AV") ?
B::end_av->ARRAY : ());
} else {
- $objname = "main::" . $objname unless $objname =~ /::/;
- print "$objname:\n";
- eval "concise_subref(\$order, \\&$objname)";
- die "concise_subref($order, \\&$objname) failed: $@" if $@;
+ # convert function names to subrefs
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Concise::compile($objname)\n";
+ $objref = $objname;
+ } else {
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ die "err: unknown function ($objname)\n"
+ unless *{$objname}{CODE};
+ $objref = \&$objname;
+ }
+ concise_subref($order, $objref);
}
}
}
if (!@args or $do_main) {
- print "main program:\n" if $do_main;
+ print $walkHandle "main program:\n" if $do_main;
concise_main($order);
}
}
@@ -261,6 +294,12 @@
my %sequence_num;
my $seq_max = 1;
+sub _clr_seq {
+ # reset the sequence
+ %sequence_num = ();
+ $seq_max = 1;
+}
+
sub seq {
my($op) = @_;
return "-" if not exists $sequence_num{$$op};
@@ -592,7 +631,8 @@
$h{label} = $labels{$op->seq};
$h{typenum} = $op->type;
$h{noise} = $linenoise[$op->type];
- $_->(\%h, $op, \$format, \$level) for @callbacks;
+ #$_->(\%h, $op, \$format, \$level) for @callbacks;
+ $_->(\%h, $op, \$level, \$format, $stylename) for @callbacks;
return fmt_line(\%h, $format, $level);
}
@@ -601,10 +641,10 @@
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $gotofmt, $level+1);
+ print $walkHandle fmt_line($h, $gotofmt, $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $format);
+ print $walkHandle concise_op($op, $level, $format);
}
# B::OP::terse (see Terse.pm) now just calls this
@@ -1095,11 +1135,16 @@
=head1 Using B::Concise outside of the O framework
-It is possible to extend B<B::Concise> by using it outside of the B<O>
-framework and providing new styles and new variables.
+You can use B<B::Concise> directly, and thereby avoid the compile-only
+operation of O. This allows you, for example, to use the debugger to
+step through B::Concise::compile() itself. When you do this, you can
+alter Concise output by optionally providing new styles, and new
+variables within those styles.
+
+=head2 example: Altering Concise Output
use B::Concise qw(set_style add_callback);
- set_style($format, $gotofmt, $treefmt);
+ set_style($your_format, $your_gotofmt, $your_treefmt);
add_callback
(
sub
@@ -1110,17 +1155,39 @@
);
B::Concise::compile(@options)->();
-You can specify a style by calling the B<set_style> subroutine. If you
-have a new variable in your style, or you want to change the value of an
-existing variable, you will need to add a callback to specify the value
-for that variable.
-
-This is done by calling B<add_callback> passing references to any
-callback subroutines. The subroutines are called in the same order as
-they are added. Each subroutine is passed four parameters. These are a
-reference to a hash, the keys of which are the names of the variables
-and the values of which are their values, the op, the level and the
-format.
+=head2 set_style()
+
+You can specify a style by calling the B<set_style> subroutine. If
+you have a new variable in your style, or you want to change the value
+of an existing variable, you will need to add a callback to specify
+the value for that variable.
+
+set_style() has 1 drawback, it doesnt update the current-style.
+Its better to use add_style(), set_style_standard().
+
+=head2 add_style()
+
+You can also create named styles by using B<add_style>, which takes an
+additional styleName argument, and registers that style for later
+selection via B::Concise::compile(). This is handy if you expect to
+use several styles iteratively.
+
+B<add_style> expects 4 arguments; ie C<< ($styleName => @stylespec)
+>>, where @stylespec has 3 strings. It will die if you attempt to
+re-add a known style, whether it's standard or previously added by
+you.
+
+=head2 add_callback()
+
+By calling B<add_callback> and passing references to your callback
+subroutines, you can populate new variables (see L<formatting
+specifications>), or alter the values of existing ones. These
+variables are then available for use in the style you've chosen.
+
+The subroutines are called in the same order as they are added. Each
+subroutine is passed four parameters. These are a reference to a
+hash, the keys of which are the names of the variables and the values
+of which are their values, the op, the level and the format.
To define your own variables, simply add them to the hash, or change
existing values if you need to. The level and format are passed in as
@@ -1128,13 +1195,58 @@
changed or even used.
To switch back to one of the standard styles like C<concise> or
-C<terse>, use C<set_style_standard>.
+C<terse>, use C<set_style_standard>, or pass the styleName into
+B::Concise::compile.
+
+=head2 Running and Getting Output
+
+To get the output, call the subroutine returned by B<compile>, it will
+print to STDOUT. In addition to the style-options, you can pass one
+or more function names or subroutine references to B<compile>, the
+function it returns will traverse both in order. B<walk_output>
+allows you to redirect that output to a file, or to any object that
+can print.
+
+ open (my $fh, '>', \$concise_output);
+ walk_output($fh);
+ B::Concise::compile('-concise','funcName', \&anonsub)->();
+ print "Concise Results: $concise_output\n";
+
+The 1st line of the output is either the function-name, or a
+pseudo-equivalent for subroutine references.
+
+=head2 B::Concise::_clr_seq()
+
+This function (not exportable) lets you reset the sequence numbers, in
+case thats useful to you. See concise.t for a possible usage.
+
+=head2 Errors
+
+All detected errors, (invalid arguments, internal errors, etc) are
+resolved with a die($message). Use an eval if you wish to catch these
+errors and continue processing.
+
+In particular, B<compile> will die as follows if you've asked for a
+non-existent function-name, a non-existent coderef, or a non-CODE
+reference.
+
+calling B::Concise::compile('nonExistent')->()
+ main::nonExistent:
+ err: unknown function (main::nonExistent)
+
+calling B::Concise::compile(\&nonExistent)->()
+ B::Concise::compile(CODE(0x81f12d4))
+ err: coderef has no START
+
+calling B::Concise::compile([])->()
+ B::Concise::compile(ARRAY(0x812df3c))
+ err: not a coderef: ARRAY(0x812df3c)
-To see the output, call the subroutine returned by B<compile> in the
-same way that B<O> does.
+In 2nd example, the coderef is autovivified by taking a reference to
+it, but is caught because there is no code there.
=head1 AUTHOR
-Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
+Stephen McCamant, E<< smcc@CSUA.Berkeley.EDU >>.
=cut
diff -ru -x '*.o' bleadperl/ext/B/t/concise.t bleadconcise/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bleadconcise/ext/B/t/concise.t Mon Jan 12 18:07:49 2004
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 5;
+plan tests => 38;
require_ok("B::Concise");
@@ -35,3 +35,337 @@
);
like($out, qr/print/, "-exec option with //=");
+
+######## 0.58 TESTS ########
+
+use Config;
+B::Concise->import(qw(set_style set_style_standard add_callback
+ add_style walk_output));
+my @stylespec;
+
+# test walk_output argument checking
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts Handle $foo");
+}
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string", [], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects bad Handle $foo");
+}
+$@=''; # clear the fail for next test
+
+{ # any object that can print should be ok for walk_output
+ package Hugo;
+ sub new { my $foo = bless {} };
+ sub print { CORE::print @_ }
+}
+$foo = new Hugo; # his comment led to this test
+eval { walk_output($foo) };
+is ($@, '', "walk_output() accepts obj that can print");
+
+$@='';
+eval { add_style ('junk_B' => @stylespec) };
+like ($@, 'expecting 3 style-format args', "add_style detects insufficient args");
+
+@stylespec = (0,0,0); # right length, invalid values
+
+$@='';
+eval { add_style ('junk' => @stylespec) };
+is ($@, '', "add_style accepts args: stylename => 3-arg-array");
+
+$@='';
+eval { add_style (junk => @stylespec) };
+like ($@, qr/style 'junk' already exists, choose a new name/,
+ "add_style correctly disallows re-adding same style-name" );
+
+# test new arg-checks on set_style
+
+$@='';
+eval { set_style (@stylespec) };
+is ($@, '', "set_style accepts 3 style-format args");
+
+@stylespec = (); # bad style
+
+eval { set_style (@stylespec) };
+like ($@, qr/expecting 3 style-format args/,
+ "set_style rejects bad style-format args");
+
+
+
+=head1 test use of B::Concise outside O framework
+
+following tests set_style, add_callback, and the machinery that calls
+them. The new style adds a #nextrel item, which is not particularly
+useful as it stands, but is enough to test with.
+
+Also tests walk_output function, whereby output from B::Concise is
+written to the provided 'filehandle'. The feature allows easier
+capture and manipulation of Concise output, and is leveraged here to
+compare 3 different styles, which are set 2 different ways.
+
+=head2 Concise Output Test
+
+We test the concise output against a hardcoded reference string. This
+test, being a textual comparison, is by nature sensitive to minor
+format changes, including those irrelevant to human readers.
+
+To make the test somewhat more robust, 2 techniques are used. 1st, we
+run compile() on a subroutine, which eliminates the sequence
+variations which would otherwize be caused by surrounding code. 2nd,
+the reference string is converted into a Regexp so that the ref-data
+is independent of line-numbers.
+
+Note however that the sequence numbers are checked literally, as they
+are central to the operation of the optree, which is represented in
+'basic' mode.
+
+This approach has its limits, which the "Anon-Sub vs Anon-Sub test"
+illustrates.
+
+The 1st problem is 'corrected' by calling B::Concise::_clr_seq() to
+reset the sequence numbers. The 2nd problem is that the 'nextstate'
+op is printed with line numbers in its private data, and these cause a
+naive comparison of 2 equivalent anonymous subroutines to fail. More
+on this follows.
+
+=head2 Relative Output
+
+setup() below exersizes the outside-O-framework support by creating a
+new '-relative' style, and using it. This style uses a new variable
+'#nextrel', which is populated by a callback to relative().
+
+'#nextrel' started as an attempt to replace '#next' with something
+that displayed +/-N lines to jump for the next opcode. It doesnt work
+cuz Concise emits 1 line at a time, and doesnt have a post-output
+massage stage. It was a dumb idea anyway, exec mode is more
+appropriate for this. But it makes a good test.
+
+The callback function C<relative()> that populates '#nextrel' also
+uses the new $style parameter passed to callbacks in v0.58. This
+addition allows callbacks to act in style specific ways. While this
+might not be a wise thing for users to do generally, Perl generally
+'gives you enough rope'.
+
+Anyway, relative() also alters nextstate ops by setting '#arg'='' when
+$style is 'relative'. This causes nextstate ops to render without the
+op-specific stuff, ie the line number info. When combined with
+sequence resetting via _clr_seq(), and stripping of the 1st line of
+the result (the function announcement line), 2 equivalent anonymous
+subroutines can be compile()d, and the respective results will be 'eq'
+
+=cut
+
+sub test_this {
+ # canonical example from pod
+ $a = $b + 42;
+}
+
+# almost-text reference data. (note the \d+ where line numbers belong)
+my $ref = <<'EORef';
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(main -\d+ concise.t:\d+) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t3] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <#> gvsv[*a] s ->6
+EORef
+
+# fixup the above ref-string for use as Regexp below
+$ref =~ s/([\[\]()*.\$\@\#])/\\$1/g; # manual \Q (doesnt escape '+')
+
+my $label = "main::test_this:\n";
+
+sub setup {
+ # encapsulated setup for B::Concise testing, as outlined in POD
+
+ # define a style closely related to default,
+ # but which adds a (useless) new item
+ @stylespec =
+ ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ . "(x(;~=>#nextrel)x)\n" # new 'variable' used here
+
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+
+ set_style (@stylespec);
+
+ # now re-add the above style, giving it a (new) name.
+ add_style ( "relative", @stylespec );
+
+ # set that style
+ set_style_standard ( "relative" );
+
+ # and this callback populates the new variable '#nextrel'
+ add_callback
+ ( sub {
+ my ($h, $op, $level, $format, $style) = @_;
+
+ #print "LEVEL: $$level STYLE: $style FORMAT: $$format";
+
+ $h->{nextnum} = '-';
+ $n = $op->next;
+ $h->{nextnum} = $n->seq unless ref $n eq 'B::NULL';
+
+ $rel = $h->{nextnum} - $h->{seqnum};
+ $rel = ($rel>0) ? "+$rel" : "-$rel";
+ $rel = 'na' unless $h->{nextnum} > 0 and $h->{seqnum} > 0;
+ $h->{nextrel} = $rel;
+
+ # this fixup supresses source-line numbers,
+ # simplifying comparison of 2 asubs.
+ $h->{arg} = '' if $style =~ /relative/ and $h->{name} eq 'nextstate';
+ });
+
+}
+
+my ($s1,$s2,$s3,$s4); # 3 target strings for write to \SCALAR
+my ($f1,$f2,$f3,$f4); # 3 filehandles for same
+
+my $dontskip; # set in 1st SKIP block, reused in 2nd
+SKIP: {
+ eval "require 5.008";
+ skip("IO to \SCALAR requires 5.008 ", 11) if $@;
+ skip("IO to \SCALAR requires PerlIO", 11)
+ unless $Config::Config{useperlio};
+ $dontskip = 1;
+
+ is ($@, '', "\Uuse outside O framework $@"); # Announce - no test
+
+ # set up 'filehandles' for testing walk_output()
+ open($f1, '>', \$s1);
+ open($f2, '>', \$s2);
+ open($f3, '>', \$s3);
+
+ # invoke setup routine above
+ setup();
+ is ($@, '', "setup called set_style, add_style, add_callback $@");
+
+ walk_output($f1);
+ is ($@, '', "walk_output to opened \scalar $@");
+ # default style - should be style set above
+ B::Concise::compile('test_this')->();
+
+ walk_output($f2);
+ # use concise style
+ B::Concise::compile('-concise','test_this')->();
+
+ walk_output($f3);
+ # use new, named style
+ B::Concise::compile('-relative','test_this')->();
+
+ is ($@, '', "3 calls to B::Concise::compile, wo errs $@");
+
+#print "$s1\n$s2\n$s3\n";
+
+ ok ($s1, "preset style output non-empty");
+ ok ($s2, "concise style output non-empty");
+ ok ($s3, "named style output non-empty");
+
+ is ($s1, $s3, "preset and named styles are same");
+ isnt ($s2, $s3, "concise and named styles are different");
+
+ # this test is probably somewhat brittle, despite the qr//
+ # it also fails when run in the debugger.
+ # eval "use re 'debug'"; # this line works, despite comment above
+ like ($s2, qr/^$label$ref$/, "named function vs reference data");
+
+} # SKIP
+
+# walk_output(\*STDOUT); # not much to see here..
+
+eval { B::Concise::compile('-concise','non_existent_function')->() };
+like ($@, qr/unknown function \(main::non_existent_function\)/,
+ "'-concise' reports non-existent-function properly");
+
+eval { B::Concise::compile('-exec','non_existent_function')->() };
+like ($@, qr/unknown function \(main::non_existent_function\)/,
+ "'-exec' reports non-existent-function properly");
+
+SKIP: {
+ skip("cannot do IO to \\SCALAR", 7) unless $dontskip;
+ $@ = '';
+ open($f4, '>', \$s4);
+ walk_output($f4);
+
+ # pass a subroutine ref directly
+ B::Concise::compile('-basic', \&test_this)->();
+ is ($@, '', "B::Concise::compile(\\&func)");
+
+ $label = "B::Concise::compile\\(CODE\\(0x[0-9a-fA-F]+\\)\\)\n";
+ like ($s4, qr/^$label$ref$/, "subroutine ref vs hardcoded reference data");
+ close ($f4);
+
+ $s4 = '';
+ open($f4, '>', \$s4);
+ walk_output($f4);
+
+ # reset the sequence-numbers that Concise gives the ops
+ B::Concise::_clr_seq();
+ # pass an anonymous sub
+ B::Concise::compile('-basic', sub{ $a=$b+42 })->();
+ is ($@, '', "B::Concise::compile(sub{...})");
+
+ # without the call to _clr_seq, this test would fail; sequence
+ # numbers wouldnt match reference. Thats cuz the sub is different
+ # code (different addresses), so the ops get new numbers.
+
+ like ($s4, qr/$ref$/, "anonymous subroutine vs hardcoded reference data");
+
+ # test against a bogus autovifified subref.
+ # in debugger, it would look like:
+ # 1 CODE(0x84840cc)
+ # -> &CODE(0x84840cc) in ???
+ my $coderef = \&$dontskip;
+ eval { B::Concise::compile('-basic', $coderef)->() };
+ like ($@, qr/^err: coderef has no START/,
+ "compile detects CODE-ref w/o actual code");
+
+ # these are edge-cases, Concise has no code which *explicitly*
+ # handles them, but theyre seen as non-CODE-refs
+ foreach my $ref ([], {}) {
+ my $typ = ref $ref;
+ eval { B::Concise::compile('-basic', $ref)->() };
+ like ($@, qr/^err: not a coderef: $typ/,
+ "compile detects $typ-ref where expecting subref");
+ }
+
+ # Anon-Sub vs Anon-Sub test
+ # test for equivalence of 2 anonymous subs
+ $s1 = '';
+ open($f1, '>', \$s1);
+ walk_output($f1);
+
+ # reset the sequence-numbers that Concise gives the ops
+ B::Concise::_clr_seq();
+ # pass an anonymous sub
+ B::Concise::compile('-relative', sub{ $a=$b+42 })->();
+
+ $s2 = '';
+ open($f2, '>', \$s2);
+ walk_output($f2);
+
+ # reset the sequence-numbers that Concise gives the ops
+ B::Concise::_clr_seq();
+ # pass an anonymous sub
+ $DB::single = 1;
+ B::Concise::compile('-relative', sub{ $a=$b+42 })->();
+
+ # remove the 1st line from each.
+ $s1 =~ s/^([^\n]+\n)//;
+ $s2 =~ s/^([^\n]+\n)//;
+ is ($s1, $s2, "equivalent anonymous subroutines");
+
+}
+
+__END__ |
From jcromie@divsol.comfolks, I picked this back up recently, I think it now incorporates all comments In the interest of full disclosure, theres (at least) a couple of maybes 1. some regexp match failures under debugger (only). these may expose a bug, and also suggests that $> ./perl -d -Ilib ext/B/t/concise.t ... 2. Above output shows how my 'announcement' line displays an anonymous sub. [jimc@harpo bleadperl]$ perl -MO=Concise,foo -e 'sub foo {1}; foo' whereas bleadperl doesnt produce an announcement line for an anonymous sub. [jimc@harpo bleadperl]$ perl -MO=Concise -e 'sub {1}' the question here is - whether I should revert the asub announce, 3. 'extra' arg I think its cuz of a flawed set of style-formats, or cuz of a prob with That said, I did add a 5th arg to the callback, namely the current $> ./perl -Ilib ext/B/t/concise.t Foo ok 46 - suppressed all but 3 lines of output exec-scope: B::Concise::compile(CODE(0x8275d84)) |
From jcromie@divsol.comInline Patchdiff -ru bleadperl/ext/B/B/Concise.pm bcons/ext/B/B/Concise.pm
--- bleadperl/ext/B/B/Concise.pm Tue Feb 24 18:55:24 2004
+++ bcons/ext/B/B/Concise.pm Wed Mar 17 11:26:23 2004
@@ -14,10 +14,11 @@
use Exporter (); # use #5
-our $VERSION = "0.59";
+our $VERSION = "0.60";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(set_style set_style_standard add_callback
- concise_subref concise_cv concise_main);
+ concise_subref concise_cv concise_main
+ add_style walk_output);
# use #6
use B qw(class ppname main_start main_root main_cv cstring svref_2object
@@ -55,23 +56,54 @@
my $curcv;
my $cop_seq_base;
my @callbacks;
+my $stylename;
sub set_style {
($format, $gotofmt, $treefmt) = @_;
+ die "expecting 3 style-format args\n" unless @_ == 3;
+}
+
+sub add_style {
+ my ($newstyle,@args) = @_;
+ die "style '$newstyle' already exists, choose a new name"
+ if exists $style{$newstyle};
+ die "expecting 3 style-format args\n" unless @args == 3;
+ $style{$newstyle} = [@args];
}
sub set_style_standard {
- my($name) = @_;
- set_style(@{$style{$name}});
+ ($stylename) = @_;
+ die "err: style '$stylename' unknown" unless exists $style{$stylename};
+ set_style(@{$style{$stylename}});
}
sub add_callback {
push @callbacks, @_;
}
+# output handle, used with all Concise-output printing
+our $walkHandle = \*STDOUT; # public for your convenience
+
+sub walk_output { # updates $walkHandle
+ my $handle = shift;
+ if (ref $handle eq 'SCALAR') {
+ # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
+ open my $tmp, '>', $handle; # but cant re-set an existing filehandle
+ $walkHandle = $tmp; # so use my $tmp as intermediate var
+ return;
+ }
+ $walkHandle = $handle;
+ my $iotype = ref $walkHandle;
+ die "expecting argument/object that can print"
+ unless $iotype eq 'GLOB' or $iotype and $walkHandle->can('print');
+}
+
sub concise_subref {
- my($order, $subref) = @_;
- concise_cv_obj($order, svref_2object($subref));
+ my($order, $coderef) = @_;
+ my $codeobj = svref_2object($coderef);
+ #print "concise_subref $codeobj\n";
+ die "err: not a coderef: $coderef\n" unless ref $codeobj eq 'B::CV';#CODE';
+ concise_cv_obj($order, $codeobj);
}
# This should have been called concise_subref, but it was exported
@@ -81,13 +113,14 @@
sub concise_cv_obj {
my ($order, $cv) = @_;
$curcv = $cv;
+ die "err: coderef has no START\n" if class($cv->START) eq "NULL";
sequence($cv->START);
if ($order eq "exec") {
walk_exec($cv->START);
} elsif ($order eq "basic") {
walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
} else {
- print tree($cv->ROOT, 0)
+ print $walkHandle tree($cv->ROOT, 0);
}
}
@@ -100,7 +133,7 @@
walk_exec(main_start);
} elsif ($order eq "tree") {
return if class(main_root) eq "NULL";
- print tree(main_root, 0);
+ print $walkHandle tree(main_root, 0);
} elsif ($order eq "basic") {
return if class(main_root) eq "NULL";
walk_topdown(main_root,
@@ -117,7 +150,7 @@
pop @cv_s; # skip the CHECK block that calls us
}
for my $cv (@cv_s) {
- print "$name $i:\n";
+ print $walkHandle "$name $i:\n";
$i++;
concise_cv_obj($order, $cv);
}
@@ -169,7 +202,8 @@
} elsif ($o eq "-littleendian") {
$big_endian = 0;
} elsif (exists $style{substr($o, 1)}) {
- set_style(@{$style{substr($o, 1)}});
+ $stylename = substr($o, 1);
+ set_style(@{$style{$stylename}});
} else {
warn "Option $o unrecognized";
}
@@ -194,15 +228,25 @@
B::end_av->isa("B::AV") ?
B::end_av->ARRAY : ());
} else {
- $objname = "main::" . $objname unless $objname =~ /::/;
- print "$objname:\n";
- eval "concise_subref(\$order, \\&$objname)";
- die "concise_subref($order, \\&$objname) failed: $@" if $@;
+ # convert function names to subrefs
+ my $objref;
+ if (ref $objname) {
+ print $walkHandle "B::Concise::compile($objname)\n";
+ $objref = $objname;
+ } else {
+ $objname = "main::" . $objname unless $objname =~ /::/;
+ print $walkHandle "$objname:\n";
+ no strict 'refs';
+ die "err: unknown function ($objname)\n"
+ unless *{$objname}{CODE};
+ $objref = \&$objname;
+ }
+ concise_subref($order, $objref);
}
}
}
if (!@args or $do_main) {
- print "main program:\n" if $do_main;
+ print $walkHandle "main program:\n" if $do_main;
concise_main($order);
}
}
@@ -262,6 +306,12 @@
my %sequence_num;
my $seq_max = 1;
+sub reset_sequence {
+ # reset the sequence
+ %sequence_num = ();
+ $seq_max = 1;
+}
+
sub seq {
my($op) = @_;
return "-" if not exists $sequence_num{$$op};
@@ -362,17 +412,21 @@
}
sub fmt_line {
- my($hr, $fmt, $level) = @_;
- my $text = $fmt;
+ my($hr, $text, $level) = @_;
+ return '' if $hr->{SKIP}; # another way to suppress lines of output
+
$text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
- $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+ $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
+
$text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
$text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
$text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
$text =~ s/#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
$text =~ s/#([a-zA-Z]+)/$hr->{$1}/eg;
$text =~ s/[ \t]*~+[ \t]*/ /g;
- return $text;
+ chomp $text;
+ return "$text\n" if $text;
+ return $text; # suppress empty lines
}
my %priv;
@@ -604,7 +658,8 @@
$h{label} = $labels{$$op};
$h{typenum} = $op->type;
$h{noise} = $linenoise[$op->type];
- $_->(\%h, $op, \$format, \$level) for @callbacks;
+
+ $_->(\%h, $op, \$format, \$level, $stylename) for @callbacks;
return fmt_line(\%h, $format, $level);
}
@@ -613,10 +668,10 @@
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
"addr" => sprintf("%#x", $$lastnext)};
- print fmt_line($h, $gotofmt, $level+1);
+ print $walkHandle fmt_line($h, $gotofmt, $level+1);
}
$lastnext = $op->next;
- print concise_op($op, $level, $format);
+ print $walkHandle concise_op($op, $level, $format);
}
# B::OP::terse (see Terse.pm) now just calls this
@@ -694,7 +749,7 @@
# a little code at the end of the module, and compute the base sequence
# number for the user's program as being a small offset later, so all we
# have to worry about are changes in the offset.
-
+
# When you say "perl -MO=Concise -e '$a'", the output should look like:
# 4 <@> leave[t1] vKP/REFC ->(end)
@@ -1031,7 +1086,7 @@
Whether or not the op is statically defined. This flag is used by the
B::C compiler backend and indicates that the op should not be freed.
-
+
=item B<#sibaddr>
The address of the OP's next youngest sibling, in hexidecimal.
@@ -1101,43 +1156,133 @@
=head1 Using B::Concise outside of the O framework
-It is possible to extend B<B::Concise> by using it outside of the B<O>
-framework and providing new styles and new variables.
+You can use B<B::Concise>, and call compile() directly, thereby
+avoiding the compile-only operation of O. For example, you could use
+the debugger to step through B::Concise::compile() itself.
+
+When doing so, you can alter Concise output by providing new output
+styles, and optionally by adding callback routines which populate new
+variables that may be rendered as part of those styles. For all
+following sections, please review L</FORMATTING SPECIFICATIONS>, the
+info is quite pertenent here.
+
+=head2 example: Altering Concise Output
use B::Concise qw(set_style add_callback);
- set_style($format, $gotofmt, $treefmt);
+ set_style($your_format, $your_gotofmt, $your_treefmt);
add_callback
- (
- sub
- {
- my ($h, $op, $level, $format) = @_;
+ ( sub {
+ my ($h, $op, $format, $level, $stylename) = @_;
$h->{variable} = some_func($op);
}
- );
+ );
B::Concise::compile(@options)->();
-You can specify a style by calling the B<set_style> subroutine. If you
-have a new variable in your style, or you want to change the value of an
-existing variable, you will need to add a callback to specify the value
-for that variable.
-
-This is done by calling B<add_callback> passing references to any
-callback subroutines. The subroutines are called in the same order as
-they are added. Each subroutine is passed four parameters. These are a
-reference to a hash, the keys of which are the names of the variables
-and the values of which are their values, the op, the level and the
-format.
+=head2 set_style()
+
+B<set_style> accepts 3 args, and updates the 3 components of
+output-style (basic-exec, goto, tree). It has one usage drawback, it
+doesnt update the current-style, thus its better to use add_style()
+and/or set_style_standard().
+
+=head2 set_style_standard($name)
+
+This restores one of the standard styles: terse, concise, linenoise,
+debug, env, into effect. It also accepts stylenames previously
+defined with add_style().
+
+=head2 add_style()
+
+This sub accepts newStyleName, and 3 style-args (as above); and
+creates, registers, and selects the newly named style. Its an error
+to re-add a style, call set_style_standard() to switch between several
+styles.
+
+=head2 add_callback()
+
+If your newly minted styles refer to any #variables (see ref above),
+you'll need to define a callback subroutine that will populate (or
+modify) those variables. These variables 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
+parameters.
+
+ 1. A hashref, containing the variable names & values which are
+ populated into the report-line for the Op
+ 2. the Op, a B<B::OP> object
+ 3. a ref to the format-string
+ 4. the formatting (indent) level
+ 5. the selected stylename
To define your own variables, simply add them to the hash, or change
existing values if you need to. The level and format are passed in as
references to scalars, but it is unlikely that they will need to be
changed or even used.
+=head2 running B::Concise::compile
+
+B<compile> accepts options as described above in L</OPTIONS>, and
+arguments, which are either coderefs, or subroutine names refering to
+code stored in the symbol table.
+
+compile() constructs and returns a coderef, which when invoked, scans
+the optree, and prints the results to STDOUT. Once you have the
+coderef, you may change style; thereafter the coderef renders in the
+new style.
+
+B<walk_output> lets you change the print destination from STDOUT to
+another open filehandle, or into a string passed as a ref. This makes
+it easier to capture output.
+
+ walk_output(\my $buf);
+ B::Concise::compile('-concise','funcName', \&aSubRef)->();
+ print "Concise Results: $buf\n";
+
+For each subroutine visited, the opcode info is preceded by a single
+line containing either the subroutine name or the stringified coderef.
+
+The 1st line of the output is either the function-name, or the
+stringified subroutine references.
+
To switch back to one of the standard styles like C<concise> or
-C<terse>, use C<set_style_standard>.
+C<terse>, call C<set_style_standard>, or pass the styleName into
+B::Concise::compile (as done above).
+
+=head2 B::Concise::reset_sequence()
+
+This function (not exported) lets you reset the sequence numbers (note
+that theyre arbitrary, human readable). Its purpose is mostly to
+support testing, ie to compare the concise output from 2 identical
+anonymous subroutines (but different instances). Without the reset,
+Concise sees that theyre separate optrees, and generates different
+sequence numbers in the output.
+
+=head2 Errors
+
+All detected errors, (invalid arguments, internal errors, etc) are
+resolved with a die($message). Use an eval if you wish to catch these
+errors and continue processing.
+
+In particular, B<compile> will die as follows if you've asked for a
+non-existent function-name, a non-existent coderef, or a non-CODE
+reference.
+
+calling B::Concise::compile('nonExistent')->()
+ main::nonExistent:
+ err: unknown function (main::nonExistent)
+
+calling B::Concise::compile(\&nonExistent)->()
+ B::Concise::compile(CODE(0x81f12d4))
+ err: coderef has no START
+
+calling B::Concise::compile([])->()
+ B::Concise::compile(ARRAY(0x812df3c))
+ err: not a coderef: ARRAY(0x812df3c)
-To see the output, call the subroutine returned by B<compile> in the
-same way that B<O> does.
+In 2nd example, the coderef is autovivified by taking a reference to
+it, but is caught because there is no code there.
=head1 AUTHOR
diff -ru bleadperl/ext/B/t/concise.t bcons/ext/B/t/concise.t
--- bleadperl/ext/B/t/concise.t Tue Feb 4 14:17:24 2003
+++ bcons/ext/B/t/concise.t Tue Mar 16 17:29:11 2004
@@ -6,7 +6,9 @@
require './test.pl';
}
-plan tests => 5;
+ use diagnostics;
+
+plan tests => 46;
require_ok("B::Concise");
@@ -35,3 +37,434 @@
);
like($out, qr/print/, "-exec option with //=");
+
+######## 0.60 TESTS ########
+
+use Config; # used for perlio check
+B::Concise->import(qw(set_style set_style_standard add_callback
+ add_style walk_output));
+my @stylespec;
+
+########## test walk_output argument checking
+
+# test that walk_output accepts a HANDLE arg
+foreach my $foo (\*STDOUT, \*STDERR) {
+ eval { walk_output($foo) };
+ is ($@, '', "walk_output() accepts Handle $foo");
+}
+
+# test that walk_output rejects non-HANDLE args
+foreach my $foo (undef, 0, "string", [], {}) {
+ eval { walk_output($foo) };
+ isnt ($@, '', "walk_output() rejects bad Handle");
+}
+$@=''; # clear the fail for next test
+
+{ # any object that can print should be ok for walk_output
+ package Hugo;
+ sub new { my $foo = bless {} };
+ sub print { CORE::print @_ }
+}
+my $foo = new Hugo; # his comment led to this test
+eval { walk_output($foo) };
+is ($@, '', "walk_output() accepts obj that can print");
+
+# now test a ref to scalar
+eval { walk_output(\my $junk) };
+is ($@, '', "walk_output() accepts ref-to-empty-scalar");
+
+$junk = "non-empty";
+eval { walk_output(\$junk) };
+is ($@, '', "walk_output() accepts ref-to-non-empty-scalar");
+
+######## test add_style
+
+$@='';
+eval { add_style ('junk_B' => @stylespec) };
+like ($@, 'expecting 3 style-format args', "add_style rejects insufficient args");
+
+@stylespec = (0,0,0); # right length, invalid values
+
+$@='';
+eval { add_style ('junk' => @stylespec) };
+is ($@, '', "add_style accepts args: stylename => 3-arg-array");
+
+$@='';
+eval { add_style (junk => @stylespec) };
+like ($@, qr/style 'junk' already exists, choose a new name/,
+ "add_style correctly disallows re-adding same style-name" );
+
+# test new arg-checks on set_style
+
+$@='';
+eval { set_style (@stylespec) };
+is ($@, '', "set_style accepts 3 style-format args");
+
+@stylespec = (); # bad style
+
+eval { set_style (@stylespec) };
+like ($@, qr/expecting 3 style-format args/,
+ "set_style rejects bad style-format args");
+
+
+=head2 Concise Output Test
+
+We test the Concise output vs a hardcoded reference string, using a
+canonical 'sub{$a=$b+42}' code sample. This test, being a textual
+comparison, is by nature sensitive to minor format changes, including
+those irrelevant to human readers.
+
+The test is made somewhat more robust by using 2 techniques. 1st, we
+run compile() on a subroutine, which eliminates the sequence
+variations which would otherwize be caused by surrounding code. 2nd,
+the reference string is converted into a Regexp so that the ref-data
+is independent of line-numbers.
+
+Note however that the sequence numbers are checked literally, as they
+are central to the proper ordering of opcodes. This approach has its
+limits, which the "Anon-Sub vs Anon-Sub test" below illustrates.
+
+The 1st problem is 'corrected' by calling B::Concise::reset_sequence()
+to reset the sequence numbers. The 2nd problem is that the
+'nextstate' op is printed with line numbers (from this file) in its
+private data. The Regexp test handles this with \d+.
+
+ and these cause a
+naive comparison of 2 equivalent anonymous subroutines to fail. More
+on this follows.
+
+=head2 Relative Output
+
+setup() below exersizes the outside-O-framework support by creating a
+new '-relative' style, and using it. This style uses a new variable
+'#nextrel', which is populated by a callback to relative().
+
+'#nextrel' started as a *naive* attempt to replace '#next' with
+something that displayed +/-N lines to jump for the next opcode. It
+doesnt work cuz Concise emits 1 line at a time, and doesnt have a
+post-output massaging stage. It was a dumb idea anyway, exec mode is
+more appropriate for this. But it makes a good test of the features.
+
+The callback function populates '#nextrel', and also uses the new
+$style parameter passed to callbacks in v0.60. This addition allows
+callbacks to act in style specific ways. While this might not be a
+wise thing for users to do generally, Perl generally 'gives you enough
+rope'.
+
+Anyway, relative() also alters nextstate ops by setting '#arg'='' when
+$style is 'relative'. This causes nextstate ops to render without the
+op-specific stuff, ie the line number info. When combined with
+sequence resetting via reset_sequence(), and stripping of the 1st line of
+the result (the function announcement line), 2 equivalent anonymous
+subroutines can be compile()d, and the respective results will be 'eq'
+
+=cut
+
+sub test_this {
+ # canonical example from pod
+ $a = $b + 42;
+}
+
+# almost-text reference data. (note the \d+ where line numbers belong)
+my $ref = <<'EORef';
+7 <1> leavesub[1 ref] K/REFC,1 ->(end)
+- <@> lineseq KP ->7
+1 <;> nextstate(main -\d+ concise.t:\d+) v ->2
+6 <2> sassign sKS/2 ->7
+4 <2> add[t3] sK/2 ->5
+- <1> ex-rv2sv sK/1 ->3
+2 <#> gvsv[*b] s ->3
+3 <$> const[IV 42] s ->4
+- <1> ex-rv2sv sKRM*/1 ->6
+5 <#> gvsv[*a] s ->6
+EORef
+
+my $label = "main::test_this:\n"; # Concise announces the sub-name too
+
+# fixup the above ref-string for use as Regexp below
+$ref =~ s/([\[\]()*.\$\@\#])/\\$1/g; # manual \Q (doesnt escape '+')
+
+my @scopeops; # used in callback.
+
+sub setup {
+ # encapsulated setup for B::Concise testing, as outlined in POD
+
+ # define a style closely related to default,
+ # but which adds a (useless) new item
+ @stylespec =
+ ( "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ . "(x(;~=>#nextrel)x)\n" # new 'variable' used here
+
+ , " (*( )*) goto #nextrel\n"
+ , "(?(<#speq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+ # add the style, giving it a (new) name, and make it 'active'
+ add_style ( "relative", @stylespec );
+ set_style_standard ( "relative" );
+
+ # this callback populates the new variable '#nextrel' for
+ # 'relative' style, and adds style-specific handling for 'scope'
+ # style, which is added for test 46.
+ add_callback
+ ( sub {
+ my ($h, $op, $format, $level, $style) = @_;
+
+ no warnings 'numeric';
+ $h->{nextnum} = '-';
+ $n = $op->next;
+ $h->{nextnum} = $$n unless ref $n eq 'B::NULL';
+
+ $rel = $h->{nextnum} - $h->{seqnum};
+ $rel = ($rel>0) ? "+$rel" : "-$rel";
+ $rel = 'na' unless $h->{nextnum} > 0 and $h->{seqnum} > 0;
+ $h->{nextrel} = $rel;
+
+ # this fixup suppresses source-line numbers,
+ # simplifying comparison of 2 asubs.
+ $h->{arg} = 'FOO' if $style =~ /relative/ and $h->{name} eq 'nextstate';
+
+ if ($style eq 'scope') {
+ $$format="" unless grep { $h->{name} eq $_ } @scopeops;
+ }
+ });
+
+}
+
+##################
+
+my ($s1,$s2,$s3,$s4); # target strings for write to \SCALAR
+my ($f1,$f2,$f3,$f4); # filehandles which are opened to write to them
+
+my $dontskip; # set in 1st SKIP block, reused in 2nd
+SKIP: {
+ # this feels pedantic, since this is known CORE, >5.8.0
+ eval "require 5.008";
+ skip("IO to \\SCALAR requires 5.008 ", 11) if $@;
+ skip("IO to \\SCALAR requires PerlIO", 11)
+ unless $Config::Config{useperlio};
+ $dontskip = 1;
+
+ is ($@, '', "\Uuse outside O framework $@"); # Announce - no test
+
+ # set up 'filehandles' for testing walk_output()
+ open($f1, '>', \$s1);
+ open($f2, '>', \$s2);
+ open($f3, '>', \$s3);
+
+ # invoke setup routine above
+ setup();
+ is ($@, '', "setup called set_style, add_style, add_callback $@");
+
+ walk_output($f1);
+ is ($@, '', "walk_output to opened \\scalar $@");
+ # default style - should be style set above
+ B::Concise::compile('test_this')->();
+
+ walk_output($f2);
+ # use concise style
+ B::Concise::compile('-concise','test_this')->();
+
+ walk_output($f3);
+ # use new, named style
+ B::Concise::compile('-relative','test_this')->();
+
+ is ($@, '', "3 calls to B::Concise::compile, wo errs $@");
+
+ #print "OK: $s1\n$s2\n$s3\n";
+
+ ok ($s1, "preset style output non-empty");
+ ok ($s2, "concise style output non-empty");
+ ok ($s3, "named style output non-empty");
+
+ is ($s1, $s3, "preset and named styles are same");
+ isnt ($s2, $s3, "concise and named styles are different");
+
+ # this test is probably somewhat brittle, despite the qr//
+ # it also fails when run in the debugger.
+ # eval "use re 'debug'"; # this line works, despite comment above
+ like ($s2, qr/^$label$ref$/, "named function vs reference data");
+
+ # test output to a scalar
+ walk_output(\my $junk);
+ B::Concise::compile('-concise','test_this')->();
+ like ($junk, qr/^$label$ref$/, "output to string vs reference data");
+
+ # test output to an initialized scalar (re-initialized)
+ $junk = "START with:\n";
+ walk_output(\$junk);
+ B::Concise::compile('-concise','test_this')->();
+ like ($junk, qr/^$label$ref$/, "re-output to string vs reference data");
+
+} # SKIP
+
+# walk_output(\*STDOUT); # not much to see here..
+
+eval { B::Concise::compile('-concise','non_existent_function')->() };
+like ($@, qr/unknown function \(main::non_existent_function\)/,
+ "'-concise' reports non-existent-function properly");
+
+eval { B::Concise::compile('-exec','non_existent_function')->() };
+like ($@, qr/unknown function \(main::non_existent_function\)/,
+ "'-exec' reports non-existent-function properly");
+
+SKIP: {
+ skip("cannot do IO to \\SCALAR", 7) unless $dontskip;
+ $@ = '';
+ open($f4, '>', \$s4);
+ walk_output($f4);
+
+ # pass a subroutine ref directly
+ B::Concise::compile('-basic', \&test_this)->();
+ is ($@, '', "B::Concise::compile(\\&func)");
+
+ $label = "B::Concise::compile\\(CODE\\(0x[0-9a-fA-F]+\\)\\)\n";
+ like ($s4, qr/^$label$ref$/, "subroutine ref vs hardcoded reference data");
+ close ($f4);
+
+ $s4 = '';
+ open($f4, '>', \$s4);
+ walk_output($f4);
+
+ # reset the sequence-numbers that Concise gives the ops
+ B::Concise::reset_sequence();
+ # pass an anonymous sub
+ B::Concise::compile('-basic', sub{ $a=$b+42 })->();
+ is ($@, '', "B::Concise::compile(sub{...})");
+
+ # without the call to reset_sequence, this test would fail; sequence
+ # numbers wouldnt match reference. Thats cuz the sub is a different
+ # instance of the same code, so the ops get new numbers.
+
+ like ($s4, qr/$ref$/, "anonymous subroutine vs hardcoded reference data");
+
+ # test against a bogus autovivified subref.
+ # in debugger, it would look like:
+ # 1 CODE(0x84840cc)
+ # -> &CODE(0x84840cc) in ???
+ my $coderef = \&$dontskip;
+ eval { B::Concise::compile('-basic', $coderef)->() };
+ like ($@, qr/^err: coderef has no START/,
+ "compile detects CODE-ref w/o actual code");
+
+ # these are edge-cases, Concise has no code which *explicitly*
+ # handles them, but theyre seen as non-CODE-refs
+ foreach my $ref ([], {}) {
+ my $typ = ref $ref;
+ eval { B::Concise::compile('-basic', $ref)->() };
+ like ($@, qr/^err: not a coderef: $typ/,
+ "compile detects $typ-ref where expecting subref");
+ }
+
+ # Anon-Sub vs Anon-Sub test
+ # test for equivalence of 2 anonymous subs
+ $s1 = '';
+ open($f1, '>', \$s1);
+ walk_output($f1);
+
+ # reset the sequence-numbers that Concise gives the ops
+ B::Concise::reset_sequence();
+ # pass an anonymous sub
+ B::Concise::compile('-relative', sub{ $a=$b+42 })->();
+
+ $s2 = '';
+ open($f2, '>', \$s2);
+ walk_output($f2);
+
+ # reset the sequence-numbers that Concise gives the ops
+ B::Concise::reset_sequence();
+ # pass an anonymous sub
+ B::Concise::compile('-relative', sub{ $a=$b+42 })->();
+
+ # remove the 1st line from each.
+ $s1 =~ s/^([^\n]+\n)//;
+ $s2 =~ s/^([^\n]+\n)//;
+ is ($s1, $s2, "equivalent anonymous subroutines");
+
+ #################################
+ # test changing styles, output after compile
+
+ B::Concise::reset_sequence();
+ my $cfn = B::Concise::compile('-concise', sub{ $a=$b+42 });
+
+ walk_output(\my $foo);
+ $cfn->();
+ # already $label = "B::Concise::compile\\(CODE\\(0x[0-9a-fA-F]+\\)\\)\n";
+ like ($foo, qr/^$label$ref$/, "2stringout vs hardcoded reference data");
+ # print "concise:<$foo>\n";
+
+ # re-start collection into $foo
+ walk_output(\$foo);
+ set_style_standard('debug');
+ $cfn->();
+
+ # strip matching text, and test for remainder
+ $foo =~ s/($label)//;
+ # print "debug:<$foo>\n"; # print "label: $1\n";
+ my $dbgOpRx = qr<([A-Z]+\s+\(0x[0-9a-f]+\)\n
+ (?:\t(?:op_\w+)\t.*?\n)+
+ )>x;
+
+ # strip output text matching multiple opcodes
+ $foo =~ s/$dbgOpRx//mg;
+ is( $foo, '', 'output matched debug, changed after compile');
+ set_style_standard('concise');
+
+ #################################
+
+ # test that both subroutines are listed
+ B::Concise::reset_sequence();
+ $cfn = B::Concise::compile('-concise', 'test_this', sub{ $a=$b+42 });
+ walk_output(\$foo);
+ $cfn->();
+
+ my @lines = split(/\n/, $foo);
+ my $lines = @lines; # 2 part scalarize avoids split into @_
+ is ($lines, 22, "got 'enough' lines, looks like 2 subs scanned");
+
+=head1 'scope' style
+
+Here, we add a 'scope' style and excersize it. This 'style' is unlike
+usual usage; it uses the callback established by setup() above, which
+contains style-specific code that suppresses output when the style eq
+'scope' and the opcode is not one of the 4 scope-control opcodes given
+below.
+
+'scope' is used 2x below, once each in combination with exec and
+concise modes. The exec+scope combo is slightly odd in that it prints
+a 'goto' in the middle of the output - I dont know what to make of it,
+so I just put in a hack to print the output if the test is invoked
+with a cmdline arg:
+
+ ./perl -w -Ilib ext/B/t/concise.t 9
+
+=cut
+
+ @scopeops = qw( leavesub enter leave nextstate );
+ add_style
+ ( 'scope' # concise copy
+ , "#hyphseq2 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x) "
+ , " (*( )*) goto #seq\n"
+ , "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+ );
+
+ walk_output(\$foo);
+ B::Concise::reset_sequence();
+ B::Concise::compile('-concise', '-scope', sub{ $a=$b+42 })->();
+
+ @lines = split(/\n/, $foo);
+ $lines = @lines; # 2 part scalarize avoids split into @_
+ is ($lines, 3, "suppressed all but 3 lines of output");
+ print "con-scope: $foo\n" if @ARGV;
+
+ walk_output(\$foo);
+ B::Concise::reset_sequence();
+ B::Concise::compile('-exec', '-scope', sub{ $a=$b+42 })->();
+ B::Concise::compile('-concise', '-exec', sub{ $a=$b+42 })->();
+ print "exec-scope: $foo\n" if @ARGV;
+
+}
+
+__END__ |
From @rgsjim cromie wrote:
Thanks, I applied the Concise.pm part of your patch as change #22539. I didn't apply the test patch, because : The other day I added an optimisation that basically transforms So what I'd like is a new test file, let's say ext/B/t/optrees.t, that |
From jcromie@divsol.comRafael Garcia-Suarez wrote:
:-)
true - I never thought to test that. I can repackage tests 1-20, which BTW - if you still have the broken non-threaded test output, pls send to me.
Hey look - brittleness IS a feature ;-) is ($s1, $s2, "assign properly optimized away") BTW - theres another optimization yet to do. [jimc@harpo bleadperl]$ ./perl -MO=Concise -e 'my $foo=()'; our $foo=undef is also optimizable, though probly not worth it.
hmm - while t/lib/warnings/* looks somewhat daunting, ext/B/t/optweaks/{assign,sort,map-scalar,grep-boolean}.t thx, |
From @ysthOn Sat, Mar 20, 2004 at 12:36:56AM +0100, Rafael Garcia-Suarez <rgarciasuarez@free.fr> wrote:
If you look at op/split.t, there's a test there that "my ($a,$b) = split;" |
@Tux - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#24821 (status was 'resolved')
Searchable as RT24821$
The text was updated successfully, but these errors were encountered: