Skip to content
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

Closed
p5pRT opened this issue Jan 6, 2004 · 28 comments
Closed

enhancement patch for B::Concise #7018

p5pRT opened this issue Jan 6, 2004 · 28 comments

Comments

@p5pRT
Copy link

p5pRT commented Jan 6, 2004

Migrated from rt.perl.org#24821 (status was 'resolved')

Searchable as RT24821$

@p5pRT
Copy link
Author

p5pRT commented Jan 6, 2004

From jcromie@divsol.com

in case your mail browser doesnt inline the 1st attachment, heres the
highlites​:

The patch adds 3 things​:

1. B​::Concise​::walk_output($fh), with which you can send Concise output
  to a file, string (ala​: open(my $fh,'>',\$string)), etc.

2. B​::Concise​::add_style(), with which you can add a named style to
  those already available. This is mostly convenience, but it lets
  you register new styles, then use them like theyre built-in ( including
  naming them on the command-line, or as args to B​::Concise​::compile() )

3. Tests for above, inc test following pod recipe for using B​::Concise
outside O framework.
  Tested against bleadperl. all OK.

@p5pRT
Copy link
Author

p5pRT commented Jan 6, 2004

From jcromie@divsol.com

Created by jimc@harpo.jimc.earth

THIS IS AN ENHANCEMENT PATCH

The patch adds 3 things​:

1. B​::Concise​::walk_output($fh), with which you can send Concise output
  to a file, string (ala​: open(my $fh,'>',\$string)), etc.

2. B​::Concise​::add_style(), with which you can add a named style to
  those already available. This is mostly convenience, but it lets
  you register new styles, then use them like theyre built-in ( including
  naming them on the command-line, or as args to B​::Concise​::compile()

3. Tests for above. Tested against bleadperl. all OK.

Perl Info

Flags:
    category=core
    severity=low

This perlbug was built using Perl v5.6.2 - Tue Nov 25 15:06:47 MST 2003
It is being executed now by  Perl v5.8.2 - Sat Nov  8 17:00:46 MST 2003.

Site configuration information for perl v5.8.2:

Configured by jimc at Sat Nov  8 17:00:46 MST 2003.

Summary of my perl5 (revision 5.0 version 8 subversion 2) configuration:
  Platform:
    osname=linux, osvers=2.4.20-20.7, archname=i686-linux-thread-multi
    uname='linux harpo.jimc.earth 2.4.20-20.7 #1 mon aug 18 15:00:59 edt 2003 i686 unknown '
    config_args='-DDEBUGGING -Dusethreads -Dd_dosuid -Dd_semctl_semun -Di_db -Di_ndbm -Di_gdbm -Di_shadow -Di_syslog'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=define use5005threads=undef useithreads=define usemultiplicity=define
    useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I/usr/include/gdbm',
    optimize='-O2',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -fno-strict-aliasing -I/usr/local/include -I/usr/include/gdbm'
    ccversion='', gccversion='2.96 20000731 (Red Hat Linux 7.2 2.96-112.7.2)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
    libc=/lib/libc-2.2.4.so, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.2.4'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl v5.8.2:
    /usr/local/lib/perl5/5.8.2/i686-linux-thread-multi
    /usr/local/lib/perl5/5.8.2
    /usr/local/lib/perl5/site_perl/5.8.2/i686-linux-thread-multi
    /usr/local/lib/perl5/site_perl/5.8.2
    /usr/local/lib/perl5/site_perl/5.8.1/i686-linux-thread-multi
    /usr/local/lib/perl5/site_perl/5.8.1
    /usr/local/lib/perl5/site_perl/5.8.0
    /usr/local/lib/perl5/site_perl/5.6.2
    /usr/local/lib/perl5/site_perl
    .


Environment for perl v5.8.2:
    HOME=/home/jimc
    LANG=en_US
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/usr/local/bin:/bin:/usr/bin:/usr/bin/X11:/usr/local/bin:/usr/bin:/usr/X11R6/bin:/usr/java/j2sdk1.4.1_02/bin:/usr/local/mozilla:/home/jimc/bin:./bin:.:/usr/sbin:/sbin
    PERL_BADLANG (unset)
    SHELL=/bin/bash

@p5pRT
Copy link
Author

p5pRT commented Jan 6, 2004

From jcromie@divsol.com

Inline Patch
diff -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!");
+}
+

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From jcromie@divsol.com

Jim Cromie (via RT) wrote​:

# New Ticket Created by Jim Cromie
# Please include the string​: [perl #24821]
# in the subject line of all future correspondence about this issue.
# <URL​: http​://rt.perl.org/rt3/Ticket/Display.html?id=24821 >

in case your mail browser doesnt inline the 1st attachment, heres the
highlites​:

The patch adds 3 things​:

1. B​::Concise​::walk_output($fh), with which you can send Concise output
to a file, string (ala​: open(my $fh,'>',\$string)), etc.

2. B​::Concise​::add_style(), with which you can add a named style to
those already available. This is mostly convenience, but it lets
you register new styles, then use them like theyre built-in ( including
naming them on the command-line, or as args to B​::Concise​::compile() )

3. Tests for above, inc test following pod recipe for using B​::Concise
outside O framework.
Tested against bleadperl. all OK

this version supersedes previous, and adds POD,
and adds a SKIP​: block around tests which rely on open(my $fh, '>', \my
$scalar) for possible back-porting

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From jcromie@divsol.com

Inline Patch
diff -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!");
+}
+

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From @hvds

Jim Cromie <jcromie@​divsol.com> wrote​:
:+sub walk_output {
:+ $walkHandle = shift;
:+ my $iotype = ref $walkHandle;
:+ die "expecting GLOB, FILEHANDLE or IO​::* argument"
:+ unless $iotype eq 'GLOB' or $iotype =~ /^IO​::/;
:+}

This sets my alarm bells ringing​: if I have a 'Hugo​::File' that
inherits from an appropriate IO​::* module, this will fail to accept it.
I don't think we really have good mechanisms for checking this sort of
thing cleanly - perl6 is shaping up to be much better in that respect -
but one approach would be to check that $walkHandle->can() each of the
methods that you need it to support.

But the patch as a whole looks interesting, thank you. :)

Hugo

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From @ysth

On Tue, Jan 06, 2004 at 02​:49​:59AM -0000, Jim Cromie <perlbug-followup@​perl.org> wrote​:

--- 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
+# set up 'filehandles' for testing walk_output()
+my ($s1,$s2,$s3);
+open(my $f1, '>', \$s1);
+open(my $f2, '>', \$s2);
+open(my $f3, '>', \$s3);

Will those opens work without perlio? Do we care?

+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");

I think that like() is getting passed "" as the pattern to check, the *result* of a
match against $_; probably not what you intended. Even changed to use
qr//, I don't think you want the \Q, that will make your \d+ literal.
You need to go through and manually backslash all the $*()[].@​ chars.

+# 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!");
+}

Not sure exactly what that's for, but you may want instead​:
use Config;
use lib $Config​::Config{sitelib};

lib.pm is supposed to automatically also add the archname subdirectory
if it has stuff in it.

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From @pjcj

Jim Cromie said​:

3. Tests for above, inc test following pod recipe for using B​::Concise
outside O framework.

Thanks very much. Presumably I hadn't added any tests because you hadn't
added the framework for them yet. Yes, that must be it.

--
Paul Johnson - paul@​pjcj.net
http​://www.pjcj.net

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From jcromie@divsol.com

Paul Johnson via RT wrote​:

Jim Cromie said​:

3. Tests for above, inc test following pod recipe for using B​::Concise
outside O framework.

Thanks very much. Presumably I hadn't added any tests because you hadn't
added the framework for them yet. Yes, that must be it.

huh ?

Ok, youre Devel​::Cover Dude.
I see the following in your pod, but I dont see how it relates.
Could you elaborate ?

If the module does not use the t/*.t framework​:

=head1 ACKNOWLEDGEMENTS

Some code and ideas cribbed from​:

Devel​::OpProf
B​::Concise

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From jcromie@divsol.com

Yitzchak Scott-Thoennes via RT wrote​:

On Tue, Jan 06, 2004 at 02​:49​:59AM -0000, Jim Cromie <perlbug-followup@​perl.org> wrote​:

--- 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
+# set up 'filehandles' for testing walk_output()
+my ($s1,$s2,$s3);
+open(my $f1, '>', \$s1);
+open(my $f2, '>', \$s2);
+open(my $f3, '>', \$s3);

Will those opens work without perlio? Do we care?

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";
skip if $@​,
a bit superfluous for blead, but...

ALSO, Ive added $walkHandle->can('print'). to walk_output().
one issue remaining here is whether that should carp, and if so, should
it preserve the old
handle. But thats 'coddling' the user, and B​::Concise was never for
'beginners'

+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");

I think that like() is getting passed "" as the pattern to check, the *result* of a
match against $_; probably not what you intended. Even changed to use
qr//, I don't think you want the \Q, that will make your \d+ literal.
You need to go through and manually backslash all the $*()[].@​ chars.

Indeed - once I actually added the intended qr//, test broke.
now fixed in my working-copy. Thanks.

+# 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!");
+}

Not sure exactly what that's for, but you may want instead​:
use Config;
use lib $Config​::Config{sitelib};

lib.pm is supposed to automatically also add the archname subdirectory
if it has stuff in it.

It was mostly to test another way.
Since my 'relative' style added "=> \d+" to the end of each line,
String​::Approx would produce a predictable edit-distance between
relative and concise outputs.

I gave up when it became obvious that @​INC was heavily restricted in
core testing,
but left the test below __END__ to elicit feedback. Thanks for 'taking
the bait' ;-)
I will try your suggestion.

@p5pRT
Copy link
Author

p5pRT commented Jan 7, 2004

From @pjcj

On Wed, Jan 07, 2004 at 12​:40​:41PM -0700, Jim Cromie wrote​:

Paul Johnson via RT wrote​:

Jim Cromie said​:

3. Tests for above, inc test following pod recipe for using B​::Concise
outside O framework.

Thanks very much. Presumably I hadn't added any tests because you hadn't
added the framework for them yet. Yes, that must be it.

huh ?

Ok, youre Devel​::Cover Dude.
I see the following in your pod, but I dont see how it relates.
Could you elaborate ?

I wrote the code and docs for using B​::Concise outside of the O
framework, but I didn't write any tests, so I'm very glad that you did.

And yes, it was to help me writing Devel​::Cover.

--
Paul Johnson - paul@​pjcj.net
http​://www.pjcj.net

@p5pRT
Copy link
Author

p5pRT commented Jan 8, 2004

From jcromie@divsol.com

Jim Cromie wrote​:

http​://rt.perl.org/rt3/Ticket/Display.html?id=24821 >

The patch adds 3 things​:

1. B​::Concise​::walk_output($fh), with which you can send Concise output
to a file, string (ala​: open(my $fh,'>',\$string)), etc.

2. B​::Concise​::add_style(), with which you can add a named style to
those already available. This is mostly convenience, but it lets
you register new styles, then use them like theyre built-in (
including
naming them on the command-line, or as args to B​::Concise​::compile() )

3. Tests for above, inc test following pod recipe for using
B​::Concise outside O framework.
Tested against bleadperl. all OK

This version supersedes others.
I think it adequately addresses all suggestions made here (thanks for
those)​:

  1. walk_output() tests GLOB and ->can('print')
  2. regex test vs hardcoded string fixed.
  3. appears to just work with PERLIO=stdio
  4. String​::Approx etal tests were cleaned up to actually run, but
are still below __END__
  I didnt see enough value in them wrt what wrong distance
metric results would mean.
  the use lib @​nearpaths # are a bit hokey

other items
  5. added arg-ct tests to set_style, similar to those in add_style
  6. added =head2(s) into pod, my additions made the subject drift
without them.
  7. printing to walkHandle in a few more places.
  8. no comments yet on the pod, I'll *assume* thats a good thing.

[jimc@​harpo bleadconcise]$ PERLIO=stdio ./perl -Ilib ext/B/t/concise.t
1..30
ok 1 - require B​::Concise
ok 2 - Smallest OP sequence number
ok 3 - Second-smallest OP sequence number
ok 4 - Smallest COP sequence number
ok 5 - -exec option with //=
ok 6 - walk_output() accepts Handle GLOB(0x81478e4)
ok 7 - walk_output() accepts Handle GLOB(0x8147920)
ok 8 - walk_output() rejects bad Handle
ok 9 - walk_output() rejects bad Handle 0
ok 10 - walk_output() rejects bad Handle string
ok 11 - walk_output() rejects bad Handle ARRAY(0x81804c4)
ok 12 - walk_output() rejects bad Handle HASH(0x822f33c)
ok 13 - walk_output() accepts obj that can print
ok 14 - add_style detects insufficient args
ok 15 - add_style detects insufficient [args]
ok 16 - add_style accepts args (stylename => arrayref)
ok 17 - add_style correctly disallows re-adding same style-name
ok 18 - set_style accepts 3 style-format args
ok 19 - set_style rejects bad style-format args
ok 20 - use outside O framework
ok 21 - open to scalar
ok 22 - setup called set_style, add_style, add_callback
ok 23 - walk_output to opened scalar
ok 24 - 3 calls to B​::Concise​::compile, wo errs
ok 25 - preset style output non-empty
ok 26 - concise style output non-empty
ok 27 - named style output non-empty
ok 28 - preset and named styles are same
ok 29 - concise and named styles are different
ok 30 - matches against hardcoded reference output

@p5pRT
Copy link
Author

p5pRT commented Jan 8, 2004

From jcromie@divsol.com

Inline Patch
diff -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";
+
+}
+
+

@p5pRT
Copy link
Author

p5pRT commented Jan 8, 2004

From nick.ing-simmons@elixent.com

<hv@​crypt.org> writes​:

Jim Cromie <jcromie@​divsol.com> wrote​:
​:+sub walk_output {
​:+ $walkHandle = shift;
​:+ my $iotype = ref $walkHandle;
​:+ die "expecting GLOB, FILEHANDLE or IO​::* argument"
​:+ unless $iotype eq 'GLOB' or $iotype =~ /^IO​::/;
​:+}

This sets my alarm bells ringing​: if I have a 'Hugo​::File' that
inherits from an appropriate IO​::* module, this will fail to accept it.
I don't think we really have good mechanisms for checking this sort of
thing cleanly - perl6 is shaping up to be much better in that respect -
but one approach would be to check that $walkHandle->can() each of the
methods that you need it to support.

And another (more OOish) way is not to check, and just get message
like "cannot find method 'write' via Hugo​::File" or whatever.

But the patch as a whole looks interesting, thank you. :)

Hugo

@p5pRT
Copy link
Author

p5pRT commented Jan 8, 2004

From nick.ing-simmons@elixent.com

Jim Cromie <jcromie@​divsol.com> writes​:

Yitzchak Scott-Thoennes via RT wrote​:

On Tue, Jan 06, 2004 at 02​:49​:59AM -0000, Jim Cromie <perlbug-followup@​perl.org> wrote​:

--- 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
+# set up 'filehandles' for testing walk_output()
+my ($s1,$s2,$s3);
+open(my $f1, '>', \$s1);
+open(my $f2, '>', \$s2);
+open(my $f3, '>', \$s3);

Will those opens work without perlio? Do we care?

when I ran following, the above code worked. Should it have failed ?

PERLIO=stdio ./perl -Ilib ext/B/t/concise.t

"Without perlio" means -Uuseperlio as perl build time, and IO is stdio
as in perl < 5.7.

The \$scalar trick won't work in that case.
I don't think we care - beyond skiping the tests if such a perl is used.

BTW, in 2nd version (patch.concise3) I added a SKIP​: {eval "use 5.008";
skip if $@​,
a bit superfluous for blead, but...

ALSO, Ive added $walkHandle->can('print'). to walk_output().
one issue remaining here is whether that should carp, and if so, should
it preserve the old
handle. But thats 'coddling' the user, and B​::Concise was never for
'beginners'

+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");

I think that like() is getting passed "" as the pattern to check, the *result* of a
match against $_; probably not what you intended. Even changed to use
qr//, I don't think you want the \Q, that will make your \d+ literal.
You need to go through and manually backslash all the $*()[].@​ chars.

Indeed - once I actually added the intended qr//, test broke.
now fixed in my working-copy. Thanks.

+# 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!");
+}

Not sure exactly what that's for, but you may want instead​:
use Config;
use lib $Config​::Config{sitelib};

lib.pm is supposed to automatically also add the archname subdirectory
if it has stuff in it.

It was mostly to test another way.
Since my 'relative' style added "=> \d+" to the end of each line,
String​::Approx would produce a predictable edit-distance between
relative and concise outputs.

I gave up when it became obvious that @​INC was heavily restricted in
core testing,
but left the test below __END__ to elicit feedback. Thanks for 'taking
the bait' ;-)
I will try your suggestion.

@p5pRT
Copy link
Author

p5pRT commented Jan 10, 2004

From jcromie@divsol.com

Nick Ing-Simmons wrote​:

<hv@​crypt.org> writes​:

Jim Cromie <jcromie@​divsol.com> wrote​:
​:+sub walk_output {

This sets my alarm bells ringing​: if I have a 'Hugo​::File' that
inherits from an appropriate IO​::* module, this will fail to accept it.

And another (more OOish) way is not to check, and just get message
like "cannot find method 'write' via Hugo​::File" or whatever.

This Latest revision DOES NOT remove the check, instead it adds another
error-check,
which more explicitly explains the error that confused me initially, and
started me down
this pedantic path.

old error​:

Can't locate object method "concise" via package "B​::NULL"

new error​:

[jimc@​harpo concise]$ perl outside.pl -exec Not_There
main​::Not_There​:
concise_subref(exec, \&main​::Not_There) failed​: Possible bad function
name (main​::Not_There)

[jimc@​harpo concise]$ perl outside.pl Not_There
main​::Not_There​:
concise_subref(basic, \&main​::Not_There) failed​: Possible bad function
name (main​::Not_There)

The 'problem' with this is that the new die() happens too soon for the
actual error
to occur, so I cant be absolutely sure about the cause, or of the nature
of the eventual
failure.

I had coded to catch the error, and then add the "Possible...", but I
wasnt thrilled with it;
it was asymetrical wrt where errors were caught in the 2 modes.

IE - formerly ...

$> perl outside.pl Not_There

main​::Not_There​:
Possible bad function name (main​::Not_There) causing (Can't locate
object method "concise" via package "B​::NULL" at
/home/jimc/perl.cpan/concise/B/Concise.pm line 117.
) at /home/jimc/perl.cpan/concise/B/Concise.pm line 231.

The "Possible bad function name" attempts to explain the cause of the error;
since B​::Concise is a relatively sharp knife, I chose not to hide the
original $@​

So, Im unsure whats the best $@​ report, it currently includes both the
outer and inner $@​

  concise_subref(basic, \&main​::Not_There) failed​: $@​

2 new tests reflect this new check.
ok 30 - '-concise' reports non-existent-function properly
ok 31 - '-exec' reports non-existent-function properly

I suppose I could now rip out all the extra die()s, since theyre not
mysterious
compared to the 'concise' via B​::NULLone, but your comment sounded more
observational than 'concerned'. In any case, I think that earlier,
more explicit
warnings are better, despite the false comfort that some may infer from
them.

ASIDE​: that outside.pl script is not part of the patch - I didnt see a
place for it,
and it just follows the pod recipe anyway.

thanks.

@p5pRT
Copy link
Author

p5pRT commented Jan 10, 2004

From jcromie@divsol.com

Inline Patch
diff -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";
+
+}
+
+

@p5pRT
Copy link
Author

p5pRT commented Jan 10, 2004

From @pjcj

On Sat, Jan 10, 2004 at 04​:02​:56PM -0700, Jim Cromie wrote​:

Just a couple of apostrophic doc nits​:

+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

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 youve chosen.

you've

--
Paul Johnson - paul@​pjcj.net
http​://www.pjcj.net

@p5pRT
Copy link
Author

p5pRT commented Jan 11, 2004

From smcc@mit.edu

"JC" == Jim Cromie <jcromie@​divsol.com> writes​:

JC> Nick Ing-Simmons wrote​:

NI-S> And another (more OOish) way is not to check, and just get
NI-S> message like "cannot find method 'write' via Hugo​::File" or
NI-S> whatever.

That's also my usual tendency, but I'd just chalk it up to implementor
laziness (notice a distinct lack of any error checking elsewhere in
Concise).

JC> This Latest revision DOES NOT remove the check, instead it adds
JC> another error-check, which more explicitly explains the error that
JC> confused me initially, and started me down this pedantic path.

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> main​::Not_There​:
JC> concise_subref(exec, \&main​::Not_There) failed​: Possible bad function
JC> name (main​::Not_There)

JC> [...]

It seems to me that the "Possible" is excessively cautious​: if the
user asks for a function by name, and that function doesn't exist,
that's the problem, and we should just give up immediately. I think
the check could go before printing the sub name, for instance.

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
JC> --- bleadperl/ext/B/B/Concise.pm Thu Aug 14 02​:02​:53 2003
JC> +++ bleadconcise/ext/B/B/Concise.pm Sat Jan 10 15​:01​:21 2004
JC> @​@​ -14,10 +14,11 @​@​
JC>
JC> use Exporter (); # use #5
JC>
JC> -our $VERSION = "0.57";
JC> +our $VERSION = "0.58_01";

Please just increment by cents in whatever version eventually gets
applied. If Concise gets another 40 patches, it will be high time to
declare 1.0 anyway.

JC> our @​ISA = qw(Exporter);
JC> our @​EXPORT_OK = qw(set_style set_style_standard add_callback
JC> - concise_subref concise_cv concise_main);
JC> + concise_subref concise_cv concise_main
JC> + add_style walk_output);
JC>
JC> [...]
JC>
JC> sub B​::OP​::concise {
JC> - my($op, $level) = @​_;
JC> + my($op, $level, $fh) = @​_;
JC> + $fh = $walkHandle unless $fh;

Did you add a call to concise with a $fh argument somewhere else I
missed? Since many other places use the global $walkHandle
unconditionally, it seems cleaner to just do that here too.

JC> if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
JC> my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
JC> "addr" => sprintf("%#x", $$lastnext)};
JC> - print fmt_line($h, $gotofmt, $level+1);
JC> + print $fh fmt_line($h, $gotofmt, $level+1);
JC> }
JC> $lastnext = $op->next;
JC> - print concise_op($op, $level, $format);
JC> + print $fh concise_op($op, $level, $format);
JC> }
JC>
JC> # B​::OP​::terse (see Terse.pm) now just calls this
JC> @​@​ -1095,11 +1125,16 @​@​
JC>
JC> =head1 Using B​::Concise outside of the O framework
JC>
JC> -It is possible to extend B<B​::Concise> by using it outside of the B<O>
JC> -framework and providing new styles and new variables.
JC> +You can use B<B​::Concise> directly, and thereby avoid the compile-only
JC> +operation of O. This allows you, for example, to use the debugger to
JC> +step through B​::Concise​::compile() itself. When you do this, you can
JC> +alter Concise output by optionally providing new styles, and new
JC> +variables within those styles.
JC> +
JC> +=head2 example​: Altering Concise Output
JC>
JC> use B​::Concise qw(set_style add_callback);
JC> - set_style($format, $gotofmt, $treefmt);
JC> + set_style($your_format, $your_gotofmt, $your_treefmt);
JC> add_callback
JC> (
JC> sub
JC> @​@​ -1110,17 +1145,36 @​@​
JC> );
JC> B​::Concise​::compile(@​options)->();
JC>
JC> +=head2 set_style()
JC> +
JC> You can specify a style by calling the B<set_style> subroutine. If you
JC> have a new variable in your style, or you want to change the value of an
JC> existing variable, you will need to add a callback to specify the value
JC> for that variable.
JC>
JC> -This is done by calling B<add_callback> passing references to any
JC> -callback subroutines. The subroutines are called in the same order as
JC> -they are added. Each subroutine is passed four parameters. These are a
JC> -reference to a hash, the keys of which are the names of the variables
JC> -and the values of which are their values, the op, the level and the
JC> -format.
JC> +=head2 add_style()
JC> +
JC> +You can also create named styles by using B<add_style>, which takes an
JC> +additional styleName argument, and registers that style for later
JC> +selection via B​::Concise​::compile(). This is handy if you expect to
JC> +use several styles iteratively.
JC> +
JC> +B<add_style> expects args as C<< ($styleName => @​stylespec) >> or C<<
JC> +($styleName => \@​stylespec) >>, where @​stylespec has 3 strings. It

Could you just pick one of these calling styles? It seems silly to
have both.

JC> +will also die if you attempt to re-add a known style, whether its
JC> +standard or previously added by you.
JC> +
JC> +=head2 add_callback()
JC> +
JC> +By calling B<add_callback> and passing references to your callback
JC> +subroutines, you can populate new variables See L<formatting
  ^
Punctuation here? --/

JC> +specifications>, or alter the values of existing ones. These
JC> +variables are then available for use in the style youve chosen.
JC> +
JC> +The subroutines are called in the same order as they are added. Each
JC> +subroutine is passed four parameters. These are a reference to a
JC> +hash, the keys of which are the names of the variables and the values
JC> +of which are their values, the op, the level and the format.
JC>
JC> To define your own variables, simply add them to the hash, or change
JC> existing values if you need to. The level and format are passed in as
JC> @​@​ -1128,10 +1182,33 @​@​
JC> changed or even used.
JC>
JC> To switch back to one of the standard styles like C<concise> or
JC> -C<terse>, use C<set_style_standard>.
JC> +C<terse>, use C<set_style_standard>, or pass the styleName into
JC> +B​::Concise​::compile.
JC> +
JC> +=head2 Running and Getting Output
JC> +
JC> +To get the output, call the subroutine returned by B<compile>, it will
JC> +print to STDOUT. In addition to the style-options, you can pass one
JC> +or more function names to B<compile>, the function it returns will
JC> +traverse both in order. B<walk_output> allows you to redirect that
JC> +output to a file, or to any object that can print.
JC> +
JC> + open (my $fh, '>', \$concise_output);
JC> + walk_output($fh);
JC> + B​::Concise​::compile('-concise','funcName')->();
JC> + print "Concise Results​: $concise_output\n";
JC> +
JC> +B<compile> will die as follows you if you've asked for a non-existent
JC> +function. (wrapped here for clarity)
JC> +
JC> + main​::junk​:
JC> + concise_subref(basic, \&main​::junk) failed​: \
JC> + Possible bad function name (main​::junk)
JC> +
JC> +=head1 CAVEATS
JC>
JC> -To see the output, call the subroutine returned by B<compile> in the
JC> -same way that B<O> does.
JC> +This module issues no warnings, all errors are fatal. Use eval to
JC> +prevent premature death.

This phrasing seems a bit alarmist to me​: all of the things that cause
dying are things the programmer should be able to prevent in the
course of writing correct code (e.g. passing something that's not a
filehandle). How about​:

=head2 Errors

None of the above programming interfaces have error codes; they will
die() on invalid arguments.

JC>
JC> =head1 AUTHOR
JC>
JC> diff -ru -x '*.o' bleadperl/ext/B/t/concise.t bleadconcise/ext/B/t/concise.t
JC> --- bleadperl/ext/B/t/concise.t Tue Feb 4 14​:17​:24 2003
JC> +++ bleadconcise/ext/B/t/concise.t Sat Jan 10 13​:26​:31 2004
JC> @​@​ -6,7 +6,7 @​@​
JC> require './test.pl';
JC> }
JC>
JC> -plan tests => 5;
JC> +plan tests => 31;
JC>
JC> require_ok("B​::Concise");
JC>
JC> @​@​ -35,3 +35,260 @​@​
JC> );
JC>
JC> like($out, qr/print/, "-exec option with //=");
JC> +
JC> +######## NEW TESTS ########

Could you think of a more future-proof description than "NEW" to
describe the tests that go under this line?

JC> +
JC> [...]
JC> +
JC> +eval { B​::Concise​::compile('-exec','non_existent_function')->() };
JC> +like ($@​, qr/Possible bad function name \(main​::non_existent_function\)/,
JC> + "'-exec' reports non-existent-function properly");
JC> +
JC> +__END__
JC> +
JC> +# these are interesting, but they dont add much
JC> +# in the way of insight. maybe later..

I would be in favor of physically omitting them. Textual approximate
matching doesn't strike me as a good basis for a regression test, and
tests relying on third party modules would also be a lot of trouble.

JC> +SKIP​: {
  ...
JC> + eval "use String​::Approx 'amatch'";
  ...
JC> + eval "use Text​::Levenshtein 'distance'";
  ...
JC> +}

-- Stephen

@p5pRT
Copy link
Author

p5pRT commented Jan 13, 2004

From jcromie@divsol.com

Stephen McCamant wrote​:

It seems to me that the "Possible" is excessively cautious​:

OK. While cleaning up, I added the ability to run compile() on \&subname,
which complements the more command-line oriented 'subname'.

With \&sub args, the $funcname on 1st line of output
is replaced by *B​::Concise​::compile(CODE(......))*, as
I thought a bare 'CODE(0x84ca04c)' would be unhelpful.
Im open to either
  1 - stripping this 'announcement line',
  2 - stripping the 0x..... part which makes asub vs asub comparisons
  more tedious than it needs to be
  3 - making this user-settable (kinda overkill)

Also, I found a bug where callback args were not per docs.
  #$_->(\%h, $op, \$format, \$level) for @​callbacks;
  $_->(\%h, $op, \$level, \$format, $stylename) for @​callbacks;

Note also that I added another arg to callback invocation.
It allows callbacks to act in style specific ways. While this might
not be a wise thing for users to do generally, Perl generally
'gives them enough rope'. I used it in the last test to remove
line-number differences from op-nextstate, which allows me
to compare 2 equivalent anonymous subroutines, and report them
as such. More explanation is in the pod in concise.t

I also added B​::Concise​::_clr_seq(), which resets the sequence.
This is also necessary for the asub vs asub test.

Rest below can be summarized by "OK, all suggestions accepted, acted upon",
along with attached patch.

our $VERSION = "0.58";

JC> sub B​::OP​::concise {
JC> - my($op, $level) = @​_;
JC> + my($op, $level, $fh) = @​_;
JC> + $fh = $walkHandle unless $fh;

Did you add a call to concise with a $fh argument somewhere else

Nope. that was 1st whack. now harmonized with other uses.

Could you just pick one of these calling styles? It seems silly to
have both.

OK. only C<< ($styleName => @​stylespec) >> now

                                           ^

Punctuation here? --/

Fixed. along with aphostrophe fixes from Paul

JC> +=head1 CAVEATS

now changed to =head2 Errors, and reworded, extended

JC> +######## NEW TESTS ########

Could you think of a more future-proof description than "NEW" to
describe the tests that go under this line?

:-} now says 0.58 TESTS

JC> +# these are interesting, but they dont add much
JC> +# in the way of insight. maybe later..

I would be in favor of physically omitting them.

Gone. I can play with them elsewhere.

-- Stephen

thnaks
--jimc

@p5pRT
Copy link
Author

p5pRT commented Jan 13, 2004

From jcromie@divsol.com

Inline Patch
diff -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__

@p5pRT
Copy link
Author

p5pRT commented Mar 17, 2004

From jcromie@divsol.com

folks,

I picked this back up recently, I think it now incorporates all comments
from this thread started 1/6/04, plus a few off-list suggestions.

In the interest of full disclosure, theres (at least) a couple of maybes
in here​:

1. some regexp match failures under debugger (only).

  these may expose a bug, and also suggests that
  stringifying a structure (an optree in this case) then
string-matching it against something else
  is not robust generally. In this case, I hope its enough.

  $> ./perl -d -Ilib ext/B/t/concise.t

...
not ok 43 - 2stringout vs hardcoded reference data
# Failed at ext/B/t/concise.t line 394
# got 'B​::Concise​::compile(CODE(0x85c98ac))
# 7 <1> leavesub[2 refs] K/REFC,1 ->(end)
# - <@​> lineseq KP ->7
# 1 <;> dbstate(main -803 concise.t​:389) 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
# '
# expected /(?-xism​:^B​::Concise​::compile\(CODE\(0x[0-9a-fA-F]+\)\)
# 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
# $)/

2. Above output shows how my 'announcement' line displays an anonymous sub.
  its close to this analogous form (from bleadperl, unmodified)

[jimc@​harpo bleadperl]$ perl -MO=Concise,foo -e 'sub foo {1}; foo'
main​::foo​:
3 <1> leavesub[1 ref] K/REFC,1 ->(end)
- <@​> lineseq KP ->3
1 <;> nextstate(main 1 -e​:1) v ->2
2 <$> const[IV 1] s ->3
-e syntax OK

whereas bleadperl doesnt produce an announcement line for an anonymous sub.

[jimc@​harpo bleadperl]$ perl -MO=Concise -e 'sub {1}'
6 <@​> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 2 -e​:1) v ->3
5 <1> refgen vK/1 ->6
- <1> ex-list lKRM ->5
3 <0> pushmark sRM ->4
4 <$> anoncode[CV ] lRM ->5
-e syntax OK

the question here is - whether I should revert the asub announce,
and if not, should I simplify it -
  get rid of () parens. A space would be visually less cluttered.
  and/or get rid of the stringified "$coderef". I put it there to
disambiguate between 2 reports.

3. 'extra' arg
  if invoked with extra arg, last test prints output directly.
  I stuffed this in cuz I didnt grok why the 'goto -' lines were
printed in -exec mode
  and I wanted to flag it to y'all.

I think its cuz of a flawed set of style-formats, or cuz of a prob with
my callback,
and *not* cuz of a bug I added to B​::Concise.

That said, I did add a 5th arg to the callback, namely the current
$stylename.
This allows any callback to do style-specific stuff, albeit in a
slightly hackish way.
It seemed overkill/incompatible to rework the callback dispatch itself
to pay heed to the
stylename. So I chose to 'give em the rope', maybe theyll pull a car
out of a ditch.

$> ./perl -Ilib ext/B/t/concise.t Foo

ok 46 - suppressed all but 3 lines of output
con-scope​: B​::Concise​::compile(CODE(0x81b5088))
7 <1> leavesub[1 ref] K/REFC,1 ->(end)
1 <;> nextstate(main -464 concise.t​:455) v ->2

exec-scope​: B​::Concise​::compile(CODE(0x8275d84))
  goto -
1 <;> nextstate(main -463 concise.t​:464) v
7 <1> leavesub[1 ref] K/REFC,1
B​::Concise​::compile(CODE(0x8283fac))
  goto -
8 <;> nextstate(main -462 concise.t​:465) v
9 <#> gvsv[*b] s
a <$> const[IV 42] s
b <2> add[t3] sK/2
c <#> gvsv[*a] s
d <2> sassign sKS/2
e <1> leavesub[1 ref] K/REFC,1

@p5pRT
Copy link
Author

p5pRT commented Mar 17, 2004

From jcromie@divsol.com

Inline Patch
diff -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__

@p5pRT
Copy link
Author

p5pRT commented Mar 19, 2004

From @rgs

jim cromie wrote​:

I picked this back up recently, I think it now incorporates all comments
from this thread started 1/6/04, plus a few off-list suggestions.

Thanks, I applied the Concise.pm part of your patch as change #22539.

I didn't apply the test patch, because :
1. you probably missed the fact that Concise returns different output
with threaded and unthreaded perls
2. you gave me an idea for a Grand Plan.

The other day I added an optimisation that basically transforms
  my $x = undef;
into
  my $x;
but I didn't add a test for it, because I didn't knew how to do it.
Thus, if we then modify the optree building in a way that breaks this
optimisation, this will go unnoticed, and this is not a good thing.
But your patch to B​::Concise gives a tool to test such things.

So what I'd like is a new test file, let's say ext/B/t/optrees.t, that
lists code snippets and expected optrees in a way perhaps inspired by
the things under t/lib/warnings/*, in a way that it's easy to add new
stuff ; that takes into account perl configuration differences
(useithreads for example) ; and in which in the future we would add
regression tests for optree optimisations. (@​x = sort @​x in place comes
to mind as well.) What do you think about this ?

@p5pRT
Copy link
Author

p5pRT commented Mar 20, 2004

From jcromie@divsol.com

Rafael Garcia-Suarez wrote​:

jim cromie wrote​:

I picked this back up recently, I think it now incorporates all comments
from this thread started 1/6/04, plus a few off-list suggestions.

Thanks, I applied the Concise.pm part of your patch as change #22539.

:-)

I didn't apply the test patch, because :
1. you probably missed the fact that Concise returns different output
with threaded and unthreaded perls

true - I never thought to test that. I can repackage tests 1-20, which
dont
actually run compile, and so wouldnt see any threading diffs.
I could also try to rewrite 21-46 to be thread-independent, it may be as
simple
as having 2 versions of ref-text.

BTW - if you still have the broken non-threaded test output, pls send to me.
Ill have to build a non-threaded blead anyway, but it will help dispell my
fear that concise-nothreads.t & concise-threads.t might be needed for 21-46

2. you gave me an idea for a Grand Plan.

The other day I added an optimisation that basically transforms
my $x = undef;
into
my $x;
but I didn't add a test for it, because I didn't knew how to do it.
Thus, if we then modify the optree building in a way that breaks this
optimisation, this will go unnoticed, and this is not a good thing.
But your patch to B​::Concise gives a tool to test such things.

Hey look - brittleness IS a feature ;-)
For this, I suppose that its better to have false positives than false
negatives.
But actually, this test is actually more robust than comparing to a
ref-string.

  is ($s1, $s2, "assign properly optimized away")

BTW - theres another optimization yet to do.
I'll see if I can follow your optimization patch.

[jimc@​harpo bleadperl]$ ./perl -MO=Concise -e 'my $foo=()';
6 <@​> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 1 -e​:1) v ->3
5 <2> sassign vKS/2 ->6
3 <0> stub sP ->4
4 <0> padsv[$foo​:1,2] sRM*/LVINTRO ->5
-e syntax OK

our $foo=undef is also optimizable, though probly not worth it.
(approx once per script, highly unlikely inside a subroutine
  -might even warrant a warning, under use warnings 'paranoid')

So what I'd like is a new test file, let's say ext/B/t/optrees.t, that
lists code snippets and expected optrees in a way perhaps inspired by
the things under t/lib/warnings/*, in a way that it's easy to add new
stuff ; that takes into account perl configuration differences
(useithreads for example) ; and in which in the future we would add
regression tests for optree optimisations. (@​x = sort @​x in place comes
to mind as well.) What do you think about this ?

hmm - while t/lib/warnings/* looks somewhat daunting,
is this a crude but reasonable starting point ?

  ext/B/t/optweaks/{assign,sort,map-scalar,grep-boolean}.t

thx,
jimc

@p5pRT
Copy link
Author

p5pRT commented Mar 21, 2004

From @ysth

On Sat, Mar 20, 2004 at 12​:36​:56AM +0100, Rafael Garcia-Suarez <rgarciasuarez@​free.fr> wrote​:

jim cromie wrote​:

I picked this back up recently, I think it now incorporates all comments
from this thread started 1/6/04, plus a few off-list suggestions.

Thanks, I applied the Concise.pm part of your patch as change #22539.

I didn't apply the test patch, because :
1. you probably missed the fact that Concise returns different output
with threaded and unthreaded perls
2. you gave me an idea for a Grand Plan.

The other day I added an optimisation that basically transforms
my $x = undef;
into
my $x;
but I didn't add a test for it, because I didn't knew how to do it.
Thus, if we then modify the optree building in a way that breaks this
optimisation, this will go unnoticed, and this is not a good thing.
But your patch to B​::Concise gives a tool to test such things.

So what I'd like is a new test file, let's say ext/B/t/optrees.t, that
lists code snippets and expected optrees in a way perhaps inspired by
the things under t/lib/warnings/*, in a way that it's easy to add new
stuff ; that takes into account perl configuration differences
(useithreads for example) ; and in which in the future we would add
regression tests for optree optimisations. (@​x = sort @​x in place comes
to mind as well.) What do you think about this ?

If you look at op/split.t, there's a test there that "my ($a,$b) = split;"
uses a default limit of 3. It might be better to add additional capability
to test.pl to make that kind of testing easier.

@p5pRT
Copy link
Author

p5pRT commented Jan 5, 2005

@Tux - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
None yet
Projects
None yet
Development

No branches or pull requests

1 participant