[Jifty-commit] r5711 - in B-Utils: . t

Jifty commits jifty-commit at lists.jifty.org
Wed Aug 13 09:06:59 EDT 2008


Author: clkao
Date: Wed Aug 13 09:06:58 2008
New Revision: 5711

Added:
   B-Utils/SIGNATURE
   B-Utils/t/00signature.t
   B-Utils/t/01pod.t
   B-Utils/t/03yaml.t
   B-Utils/t/10use.t
   B-Utils/t/11export.t
   B-Utils/t/20all_starts.t
   B-Utils/t/21all_roots.t
   B-Utils/t/22anon_subs.t
   B-Utils/t/30parent.t
   B-Utils/t/31oldname.t
   B-Utils/t/32kids.t
   B-Utils/t/33ancestors.t
   B-Utils/t/34descendants.t
   B-Utils/t/35siblings.t
   B-Utils/t/36previous.t
   B-Utils/t/37stringify.t
   B-Utils/t/40walk.t
   B-Utils/t/41walkfilt.t
   B-Utils/t/42all.t
   B-Utils/t/43allfilt.t
   B-Utils/t/44optrep.t
   B-Utils/t/50carp.t
   B-Utils/t/51croak.t
Removed:
   B-Utils/t/02basic.t
Modified:
   B-Utils/Changes
   B-Utils/MANIFEST
   B-Utils/META.yml
   B-Utils/Makefile.PL
   B-Utils/README
   B-Utils/lib/B/Utils.pm

Log:
import B::Utils 0.05_09

Modified: B-Utils/Changes
==============================================================================
--- B-Utils/Changes	(original)
+++ B-Utils/Changes	Wed Aug 13 09:06:58 2008
@@ -1,5 +1,62 @@
 Revision history for Perl extension B::Utils.
 
+0.05_09 Sat Apr 6 16:09:.. CEST 2008
+    - Allow for nested disjunctions in opgrep patterns.
+
+0.05_08 Sat Apr 5 22:58:.. CEST 2008
+    - I-am-a-muppet.
+    - Removed spurious use of Data::Compare.
+
+0.05_07 Tue Apr 4 18:15:.. CEST 2008
+    - opgrep() can now capture sub-ops so if you plan to
+      extract information from or modify a deeply nested
+      op-tree, you don't have to do the tree-walking
+      yourself.
+
+0.05_06 Tue Apr 3 18:15:.. CEST 2008
+    - Add the as_opgrep_pattern() method to B::OP for
+      dumping op trees as patterns for matching with opgrep.
+    - Add warnings.
+    - Documentation fixes.
+
+0.05_05 Tue Apr  1 18:15:.. CEST 2008
+    - Fix POD error and update README.
+
+0.05_04 Tue Apr  1 18:10:.. CEST 2008
+    - Fix bug in opgrep() alternations.
+    - Add the "kids" keyword to the opgrep syntax.
+    - Add the "dump" keyword to the opgrep syntax for debugging.
+    - Fixed the Change log (yes, this file) for the last
+      version since the comment on an opgrep() change was
+      incorrect.
+
+0.05_03 Sun Mar 30 11:13:.. CEST 2008
+    - Fix various bugs in opgrep(). Did that work in 0.05_02 at all?
+    - Introduce op_or() to match one of many possible conditions.
+    - Add a longer example to opgrep() documentation.
+    - Fix POD markup.
+    - Add a clear license statement to the docs.
+    - Use a string as version -- otherwise it might not be flagged
+      as a development release!
+
+0.05_02 Thu Dec  1 ..:..:.. ... 2005
+    - ->parent works for all tests now.
+    - Added more tests.
+
+0.05_01 Fri Oct 28 23:00:00 CST 2005
+    - Added tests. That's the focus of my work right now.
+    - opgrep() now acceps \@conditions
+      assertions may be code references
+    - Lots of changes to ->parent. This is in progress. It fails when
+      the parent of a node does not exist in the execution pathway of
+      a program. The unused null() ops rooting some conditionals, etc.
+
+      This function fails tests.
+    - Added a function recalc_sub_cache so anon_subs, all_starts, and
+      all_roots' cache of functions can be cleared.
+    - Added functions ->siblings, ->ancestors, ->descendants, and
+      _uniq_ops.
+
 0.05 Thu Nov 25 22:23:00 CST 2004
     - My birthday
     - Fixed infinite loop in ->parent

Modified: B-Utils/MANIFEST
==============================================================================
--- B-Utils/MANIFEST	(original)
+++ B-Utils/MANIFEST	Wed Aug 13 09:06:58 2008
@@ -3,5 +3,28 @@
 Makefile.PL
 MANIFEST			This list of files
 README
-t/02basic.t
+SIGNATURE
+t/00signature.t
+t/01pod.t
+t/03yaml.t
+t/10use.t
+t/11export.t
+t/20all_starts.t
+t/21all_roots.t
+t/22anon_subs.t
+t/30parent.t
+t/31oldname.t
+t/32kids.t
+t/33ancestors.t
+t/34descendants.t
+t/35siblings.t
+t/36previous.t
+t/37stringify.t
+t/40walk.t
+t/41walkfilt.t
+t/42all.t
+t/43allfilt.t
+t/44optrep.t
+t/50carp.t
+t/51croak.t
 META.yml                                 Module meta-data (added by MakeMaker)

Modified: B-Utils/META.yml
==============================================================================
--- B-Utils/META.yml	(original)
+++ B-Utils/META.yml	Wed Aug 13 09:06:58 2008
@@ -1,10 +1,13 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
-name:         B-Utils
-version:      0.05
-version_from: lib/B/Utils.pm
-installdirs:  site
-requires:
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.21_02
+--- #YAML:1.0
+name:                B-Utils
+version:             0.05_09
+abstract:            Helper functions for op tree manipulation
+license:             perl
+author:              
+    - Joshua b. Jore <jjore at cpan.org>
+generated_by:        ExtUtils::MakeMaker version 6.42
+distribution_type:   module
+requires:     
+meta-spec:
+    url:     http://module-build.sourceforge.net/META-spec-v1.3.html
+    version: 1.3

Modified: B-Utils/Makefile.PL
==============================================================================
--- B-Utils/Makefile.PL	(original)
+++ B-Utils/Makefile.PL	Wed Aug 13 09:06:58 2008
@@ -1,11 +1,9 @@
 use ExtUtils::MakeMaker;
-# See lib/ExtUtils/MakeMaker.pm for details of how to influence
-# the contents of the Makefile that is written.
 WriteMakefile(
-    'NAME'		=> 'B::Utils',
-    'VERSION_FROM'	=> 'lib/B/Utils.pm', # finds $VERSION
-    'PREREQ_PM'		=> {}, # e.g., Module::Name => 1.1
-    ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
-      (ABSTRACT_FROM => 'lib/B/Utils.pm', # retrieve abstract from module
-       AUTHOR     => 'Joshua b. Jore <jjore at cpan.org>') : ()),
+    NAME          => 'B::Utils',
+    VERSION_FROM  => 'lib/B/Utils.pm',
+    PREREQ_PM     => {},
+    ABSTRACT_FROM => 'lib/B/Utils.pm',
+    AUTHOR        => 'Joshua b. Jore <jjore at cpan.org>',
+    LICENSE => 'perl',
 );

Modified: B-Utils/README
==============================================================================
--- B-Utils/README	(original)
+++ B-Utils/README	Wed Aug 13 09:06:58 2008
@@ -1,101 +1,296 @@
-B/Utils version 0.05
-====================
-
 NAME
     B::Utils - Helper functions for op tree manipulation
 
-What's new in this version:
-    * Took over from Simon Cozens
-    * Added null()
-    * Fixed ->parent
-
-    walkoptree_simple($op, \&callback, [$data])
-       The "B" module provides various functions to walk the op tree, but
-       they're all rather difficult to use, requiring you to inject methods
-       into the "B::OP" class. This is a very simple op tree walker with
-       more expected semantics.
-
-       All the "walk" functions set "B::Utils::file" and "B::Utils::line" to
-       the appropriate values of file and line number in the program being
-       examined.
-
-    walkoptree_filtered($op, \&filter, \&callback, [$data])
-       This is much the same as "walkoptree_simple", but will only call the
-       callback if the "filter" returns true. The "filter" is passed the op
-       in question as a parameter; the "opgrep" function is fantastic for
-       building your own filters.
-
-    walkallops_simple(\&callback, [$data])
-       This combines "walkoptree_simple" with "all_roots" and "anon_subs" to
-       examine every op in the program. "$B::Utils::sub" is set to the
-       subroutine name if you're in a subroutine, "__MAIN__" if you're in
-       the main program and "__ANON__" if you're in an anonymous subroutine.
-
-    walkallops_filtered(\&filter, \&callback, [$data])
-       Same as above, but filtered.
-
-    carp(@args)
-    croak(@args)
-       Warn and die, respectively, from the perspective of the position of
-       the op in the program. Sounds complicated, but it's exactly the kind
-       of error reporting you expect when you're grovelling through an op
-       tree.
-
-    opgrep(\%conditions, @ops)
-       Returns the ops which meet the given conditions. The conditions
-       should be specified like this:
-
-           @barewords = opgrep(
-                               { name => "const", private => OPpCONST_BARE },
-                               @ops
-                              );
-
-       You can specify alternation by giving an arrayref of values:
-
-           @svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
-
-       And you can specify inversion by making the first element of the
-       arrayref a "!". (Hint: if you want to say "anything", say "not
-       nothing": "["!"]")
-
-       You may also specify the conditions to be matched in nearby ops.
-
-           walkallops_filtered(
-               sub { opgrep( {name => "exec", 
-                              next => {
-                                        name    => "nextstate",
-                                        sibling => { name => [qw(! exit warn die)] }
-                                      }
-                             }, @_)},
-               sub { 
-                     carp("Statement unlikely to be reached"); 
-                     carp("\t(Maybe you meant system() when you said exec()?)\n");
-               }
-           )
-
-       Get that?
-
-       Here are the things that can be tested:
-
-               name targ type seq flags private pmflags pmpermflags
-               first other last sibling next pmreplroot pmreplstart pmnext
-
-INSTALLATION
-
-To install this module type the following:
-
-   perl Makefile.PL
-   make
-   make test
-   make install
-
-DEPENDENCIES
-
-This module does *not* require anything that's not in core.
-
-COPYRIGHT AND LICENCE
-
-AL & GPL. You know the score.
+VERSION
+    0.05_07 - This is a dev version and is part of an effort to add tests,
+    functionality, and merge a fork from Module::Info.
+
+SYNOPSIS
+      use B::Utils;
+
+OP METHODS
+    "$op->oldname"
+        Returns the name of the op, even if it is currently optimized to
+        null. This helps you understand the stucture of the op tree.
+
+    "$op->kids"
+        Returns an array of all this op's non-null children, in order.
+
+    "$op->parent"
+        Returns the parent node in the op tree, if possible. Currently
+        "possible" means "if the tree has already been optimized"; that is,
+        if we're during a "CHECK" block. (and hence, if we have valid "next"
+        pointers.)
+
+        In the future, it may be possible to search for the parent before we
+        have the "next" pointers in place, but it'll take me a while to
+        figure out how to do that.
+
+    "$op->ancestors"
+        Returns all parents of this node, recursively. The list is ordered
+        from younger/closer parents to older/farther parents.
+
+    "$op->descendants"
+        Returns all children of this node, recursively. The list is
+        unordered.
+
+    "$op->siblings"
+        Returns all younger siblings of this node. The list is ordered from
+        younger/closer siblings to older/farther siblings.
+
+    "$op->previous"
+        Like " $op->next ", but not quite.
+
+    "$op->stringify"
+        Returns a nice stringification of an opcode.
+
+    "$op->as_opgrep_pattern(%options)"
+        From the op tree it is called on, "as_opgrep_pattern()" generates a
+        data structure suitable for use as a condition pattern for the
+        "opgrep()" function described below in detail. *Beware*: When using
+        such generated patterns, there may be false positives: The pattern
+        will most likely not match *only* the op tree it was generated from
+        since by default, not all properties of the op are reproduced.
+
+        You can control which properties of the op to include in the pattern
+        by passing named arguments. The default behaviour is as if you
+        passed in the following options:
+
+          my $pattern = $op->as_opgrep_pattern(
+            attributes          => [qw(name flags)],
+            max_recursion_depth => undef,
+          );
+
+        So obviously, you can set "max_recursion_depth" to a number to limit
+        the maximum depth of recursion into the op tree. Setting it to 0
+        will limit the dump to the current op.
+
+        "attributes" is a list of attributes to include in the produced
+        pattern. The attributes that can be checked against in this way are
+
+          name targ type seq flags private pmflags pmpermflags.
+
+EXPORTABLE FUNCTIONS
+    "all_starts"
+    "all_roots"
+        Returns a hash of all of the starting ops or root ops of optrees,
+        keyed to subroutine name; the optree for main program is simply
+        keyed to "__MAIN__".
+
+        Note: Certain "dangerous" stashes are not scanned for subroutines:
+        the list of such stashes can be found in @B::Utils::bad_stashes.
+        Feel free to examine and/or modify this to suit your needs. The
+        intention is that a simple program which uses no modules other than
+        "B" and "B::Utils" would show no addition symbols.
+
+        This does not return the details of ops in anonymous subroutines
+        compiled at compile time. For instance, given
+
+            $a = sub { ... };
+
+        the subroutine will not appear in the hash. This is just as well,
+        since they're anonymous... If you want to get at them, use...
+
+    "anon_subs"
+        This returns an array of hash references. Each element has the keys
+        "start" and "root". These are the starting and root ops of all of
+        the anonymous subroutines in the program.
+
+    "recalc_sub_cache"
+        If PL_sub_generation has changed or you have some other reason to
+        want to force the re-examination of the optrees, everywhere, call
+        this function.
+
+    "walkoptree_simple($op, \&callback, [$data])"
+        The "B" module provides various functions to walk the op tree, but
+        they're all rather difficult to use, requiring you to inject methods
+        into the "B::OP" class. This is a very simple op tree walker with
+        more expected semantics.
+
+        All the "walk" functions set $B::Utils::file, $B::Utils::line, and
+        $B::Utils::sub to the appropriate values of file, line number, and
+        sub name in the program being examined.
+
+    "walkoptree_filtered($op, \&filter, \&callback, [$data])"
+        This is much the same as "walkoptree_simple", but will only call the
+        callback if the "filter" returns true. The "filter" is passed the op
+        in question as a parameter; the "opgrep" function is fantastic for
+        building your own filters.
+
+    "walkallops_simple(\&callback, [$data])"
+        This combines "walkoptree_simple" with "all_roots" and "anon_subs"
+        to examine every op in the program. $B::Utils::sub is set to the
+        subroutine name if you're in a subroutine, "__MAIN__" if you're in
+        the main program and "__ANON__" if you're in an anonymous
+        subroutine.
+
+    "walkallops_filtered(\&filter, \&callback, [$data])"
+        Same as above, but filtered.
+
+    "opgrep(\%conditions, @ops)"
+        Returns the ops which meet the given conditions. The conditions
+        should be specified like this:
+
+            @barewords = opgrep(
+                                { name => "const", private => OPpCONST_BARE },
+                                @ops
+                               );
+
+        where the first argument to "opgrep()" is the condition to be
+        matched against the op structure. We'll henceforth refer to it as an
+        op-pattern.
+
+        You can specify alternation by giving an arrayref of values:
+
+            @svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
+
+        And you can specify inversion by making the first element of the
+        arrayref a "!". (Hint: if you want to say "anything", say "not
+        nothing": "["!"]")
+
+        You may also specify the conditions to be matched in nearby ops as
+        nested patterns.
+
+            walkallops_filtered(
+                sub { opgrep( {name => "exec",
+                               next => {
+                                         name    => "nextstate",
+                                         sibling => { name => [qw(! exit warn die)] }
+                                       }
+                              }, @_)},
+                sub {
+                      carp("Statement unlikely to be reached");
+                      carp("\t(Maybe you meant system() when you said exec()?)\n");
+                }
+            )
+
+        Get that?
+
+        Here are the things that can be tested in this way:
+
+                name targ type seq flags private pmflags pmpermflags
+                first other last sibling next pmreplroot pmreplstart pmnext
+
+        Additionally, you can use the "kids" keyword with an array reference
+        to match the result of a call to "$op->kids()". An example use is
+        given in the documentation for "op_or" below.
+
+        For debugging, you can have many properties of an op that is
+        currently being matched against a given condition dumped to STDERR
+        by specifying "dump =" 1> in the condition's hash reference.
+
+        If you match a complex condition against an op tree, you may want to
+        extract a specific piece of information from the tree if the
+        condition matches. This normally entails manually walking the tree a
+        second time down to the op you wish to extract, investigate or
+        modify. Since this is tedious duplication of code and information,
+        you can specify a special property in the pattern of the op you wish
+        to extract to capture the sub-op of interest. Example:
+
+          my ($result) = opgrep(
+            { name => "exec",
+              next => { name    => "nextstate",
+                        sibling => { name => [qw(! exit warn die)]
+                                     capture => "notreached",
+                                   },
+                      }
+            },
+            $root_op
+          );
+  
+          if ($result) {
+            my $name = $result->{notreached}->name; # result is *not* the root op
+            carp("Statement unlikely to be reached (op name: $name)");
+            carp("\t(Maybe you meant system() when you said exec()?)\n");
+          }
+  
+        While the above is a terribly contrived example, consider the win
+        for a deeply nested pattern or worse yet, a pattern with many
+        disjunctions. If a "capture" property is found anywhere in the op
+        pattern, "opgrep()" returns an unblessed hash reference on success
+        instead of the tested op. You can tell them apart using
+        Scalar::Util's "blessed()". That hash reference contains all
+        captured ops plus the tested root up as the hash entry
+        "$result->{op}". Note that you cannot use this feature with
+        "walkoptree_filtered" since that function was specifically
+        documented to pass the tested op itself to the callback.
+
+    "opgrep( \@conditions, @ops )"
+        Same as above, except that you don't have to chain the conditions
+        yourself. If you pass an array-ref, opgrep will chain the conditions
+        for you using "next". The conditions can either be strings (taken as
+        op-names), or hash-refs, with the same testable conditions as given
+        above.
+
+    "op_or( @conditions )"
+        Unlike the chaining of conditions done by "opgrep" itself if there
+        are multiple conditions, this function creates a disjunction
+        ("$cond1 || $cond2 || ...") of the conditions and returns a
+        structure (hash reference) that can be passed to opgrep as a single
+        condition.
+
+        Example:
+
+          my $sub_structure = {
+            name => 'helem',
+            first => { name => 'rv2hv', },
+            'last' => { name => 'const', },
+          };
+  
+          my @ops = opgrep( {
+              name => 'leavesub',
+              first => {
+                name => 'lineseq',
+                kids => [,
+                  { name => 'nextstate', },
+                  op_or(
+                    {
+                      name => 'return',
+                      first => { name => 'pushmark' },
+                      last => $sub_structure,
+                    },
+                    $sub_structure,
+                  ),
+                ],
+              },
+          }, $op_obj );
+
+        This example matches the code in a typical simplest-possible
+        accessor method (albeit not down to the last bit):
+
+          sub get_foo { $_[0]->{foo} }
+
+        But by adding an alternation we can also match optional op layers.
+        In this case, we optionally match a return statement, so the
+        following implementation is also recognized:
+
+          sub get_foo { return $_[0]->{foo} }
+
+        Essentially, this is syntactic sugar for the following structure
+        recognized by "opgrep()":
+
+          { disjunction => [@conditions] }
+
+    "carp(@args)"
+    "croak(@args)"
+        Warn and die, respectively, from the perspective of the position of
+        the op in the program. Sounds complicated, but it's exactly the kind
+        of error reporting you expect when you're grovelling through an op
+        tree.
+
+  EXPORT
+    None by default.
+
+AUTHOR
+    Originally written by Simon Cozens, "simon at cpan.org" Maintained by
+    Joshua ben Jore, "jjore at cpan.org"
+
+    Contributions from Mattia Barbon, Jim Cromie, and Steffen Mueller.
+
+LICENSE
+    This module is free software; you can redistribute it and/or modify it
+    under the same terms as Perl itself.
 
-Copyright (C) 2004 Joshua b. Jore
+SEE ALSO
+    B, B::Generate.
 

Added: B-Utils/SIGNATURE
==============================================================================
--- (empty file)
+++ B-Utils/SIGNATURE	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,52 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.55.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+    % cpansign -v
+
+It will check each file's integrity, as well as the signature's
+validity.  If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 0a47fe148032575c96627d1b91a107d42b8a4481 Changes
+SHA1 2a8b5e8c35e3f79c9ea79d1e86fbb762a9ccff62 MANIFEST
+SHA1 ae96be621bacf8f6788bd33c04dd86e9c3af6b2d META.yml
+SHA1 f793b05c6a5b858641040d2e150f11da8308aba5 Makefile.PL
+SHA1 5c5aed3d4af4e53417aaad66df45958aa45430f1 README
+SHA1 f6bdcb133a61832b5d62b9f74dca37d940b875f2 lib/B/Utils.pm
+SHA1 e6fb7473239581c7ba91a4bfaec36abbbd00529d t/00signature.t
+SHA1 695f7f50926b1eec073ad55f5775b0b95c25c9ea t/01pod.t
+SHA1 2da105f0257e2f3560bda6a7325ac8d8a7e22157 t/03yaml.t
+SHA1 b03154048869abc8852d654470c3c21ff8cab91d t/10use.t
+SHA1 fd3877d8323a58493dbb139769f508433e79ebe0 t/11export.t
+SHA1 4d8d3cf567cd92ed5b338ac5a55d69d8e5d99503 t/20all_starts.t
+SHA1 85e97c73052bea1796bed93e7709bbc480c6e0e1 t/21all_roots.t
+SHA1 68c6831247a613853bc7dc41a4a6e54268ccf5de t/22anon_subs.t
+SHA1 6c2cf60cc7fe8a7162a9f79f5d1520cccd9ce1b3 t/30parent.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/31oldname.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/32kids.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/33ancestors.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/34descendants.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/35siblings.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/36previous.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/37stringify.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/40walk.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/41walkfilt.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/42all.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/43allfilt.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/44optrep.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/50carp.t
+SHA1 eded214935bfe2f87c3539ca997436653034b9d8 t/51croak.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.6 (GNU/Linux)
+
+iD8DBQFH+QEXZCuimE51gxcRAuoxAKDJ0VeeCALtCgAEZaOwJqgB9LlZkgCfe6eV
+BReG8FIouAGymk/BrFyi9C8=
+=RUXl
+-----END PGP SIGNATURE-----

Modified: B-Utils/lib/B/Utils.pm
==============================================================================
--- B-Utils/lib/B/Utils.pm	(original)
+++ B-Utils/lib/B/Utils.pm	Wed Aug 13 09:06:58 2008
@@ -3,74 +3,390 @@
 use 5.006;
 use strict;
 use warnings;
-use vars '$DEBUG';
-our @EXPORT_OK = qw(all_starts all_roots anon_subs
-                    walkoptree_simple walkoptree_filtered
-                    walkallops_simple walkallops_filtered
-                    carp croak
-                    opgrep
-                   );
-sub import {
-  my $pack = shift;
-  my @exports = @_;
-  my $caller = caller;
-  my %EOK = map {$_ => 1} @EXPORT_OK;
-  for (@exports) {
-    unless ($EOK{$_}) {
-      require Carp;
-      Carp::croak(qq{"$_" is not exported by the $pack module});
-    }
-    no strict 'refs';
-    *{"$caller\::$_"} = \&{"$pack\::$_"};
-  }
+use vars qw( $VERSION @EXPORT_OK %EXPORT_TAGS
+    @bad_stashes $TRACE_FH $file $line $sub );
+
+use subs (
+    qw( all_starts all_roots anon_sub recalc_sub_cache ),
+    qw( walkoptree_simple walkoptree_filtered ),
+    qw( walkallops_simple walkallops_filtered ),
+    qw( opgrep op_or ),
+    qw( croak carp )
+);
+
+use Scalar::Util qw( weaken blessed );
+
+=head1 NAME
+
+B::Utils - Helper functions for op tree manipulation
+
+=head1 VERSION
+
+0.05_09 - This is a dev version and
+  is part of an effort to add tests,
+  functionality, and merge a fork
+  from Module::Info.
+
+=cut
+
+$VERSION = '0.05_09';
+
+=head1 SYNOPSIS
+
+  use B::Utils;
+
+=cut
+
+use B qw( OPf_KIDS main_start main_root walksymtable class main_cv ppname );
+
+use Exporter ();
+ at EXPORT_OK = qw(all_starts all_roots anon_subs
+    walkoptree_simple walkoptree_filtered
+    walkallops_simple walkallops_filtered
+    recalc_sub_cache
+    opgrep op_or );
+%EXPORT_TAGS = ( all => \@EXPORT_OK );
+*import      = \&Exporter::import;
+
+ at bad_stashes
+    = qw(B Carp Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base);
+
+use List::Util qw( shuffle );
+
+BEGIN {
+
+    # Fake up a TRACE constant and set $TRACE_FH
+    BEGIN { $^W = 0 }
+    no warnings;
+    eval 'sub TRACE () {' . ( 0 + $ENV{B_UTILS_TRACE} ) . '}';
+    die $@ if $@;
+    $TRACE_FH ||= \*STDOUT;
 }
+sub TRUE ()  { !!1 }
+sub FALSE () { !!0 }
 
-our $VERSION = '0.05';
+=head1 OP METHODS
 
-use B qw(main_start main_root walksymtable class OPf_KIDS);
+=over 4
 
-my (%starts, %roots, @anon_subs);
+=cut
+
+# The following functions have been removed because it turns out that
+# this breaks stuff like B::Concise which depends on ops lacking
+# methods they wouldn't normally have.
+#
+# =pod
+#
+# =item C<$op-E<gt>first>
+#
+# =item C<$oo-E<gt>last>
+#
+# =item C<$op-E<gt>other>
+#
+# Normally if you call first, last or other on anything which is not an
+# UNOP, BINOP or LOGOP respectivly it will die.  This leads to lots of
+# code like:
+#
+#     $op->first if $op->can('first');
+#
+# B::Utils provides every op with first, last and other methods which
+# will simply return nothing if it isn't relevent.
+#
+# =cut
+#
+# sub B::OP::first { $_[0]->can("SUPER::first") ? $_[0]->SUPER::first() : () }
+# sub B::OP::last  { $_[0]->can("SUPER::last")  ? $_[0]->SUPER::last()  : () }
+# sub B::OP::other { $_[0]->can("SUPER::other") ? $_[0]->SUPER::other() : () }
+
+=item C<$op-E<gt>oldname>
 
-our @bad_stashes = qw(B Carp Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base);
+Returns the name of the op, even if it is currently optimized to null.
+This helps you understand the stucture of the op tree.
 
-sub null {
+=cut
+
+sub B::OP::oldname {
+    my $op   = shift;
+    my $name = $op->name;
+    my $targ = $op->targ;
+
+    # This is a an operation which *used* to be a real op but was
+    # optimized away. Fetch the old value and ignore the leading pp_.
+
+    # I forget why the original pp # is located in the targ field.
+    return $name eq 'null' && $targ
+        ? substr( ppname($targ), 3 )
+        : $name;
+
+}
+
+=item C<$op-E<gt>kids>
+
+Returns an array of all this op's non-null children, in order.
+
+=cut
+
+sub B::OP::kids {
     my $op = shift;
-    class( $op ) eq 'NULL';
+    return unless defined wantarray;
+
+    my @kids;
+    if ( class($op) eq "LISTOP" ) {
+        @kids = $op->first;
+        push @kids, $kids[-1]->sibling while $kids[-1]->can('sibling');
+        pop @kids
+            if 'NULL' eq class( $kids[-1] );
+
+        ### Assert: $op->children == @kids
+    }
+    else {
+        @kids = (
+            ( $op->can('first') ? $op->first : () ),
+            ( $op->can('last')  ? $op->last  : () ),
+            ( $op->can('other') ? $op->other : () )
+        );
+    }
+    return @kids;
 }
 
-{ my $_subsdone=0;
-sub _init { # To ensure runtimeness.
-    return if $_subsdone;
-    %starts = ( '__MAIN__' =>  main_start() );
-    %roots  = ( '__MAIN__' =>  main_root()  );
-    walksymtable(\%main::, 
-                '_push_starts', 
-                sub { 
-                    return if scalar grep {$_[0] eq $_."::"} @bad_stashes;   
-                    1;
-                }, # Do not eat our own children!
-                '');
-    push @anon_subs, { root => $_->ROOT, start => $_->START} 
-        for grep { class($_) eq "CV" } B::main_cv->PADLIST->ARRAY->ARRAY;
-    $_subsdone=1;
+=item C<$op-E<gt>parent>
+
+Returns the parent node in the op tree, if possible. Currently
+"possible" means "if the tree has already been optimized"; that is, if
+we're during a C<CHECK> block. (and hence, if we have valid C<next>
+pointers.)
+
+In the future, it may be possible to search for the parent before we
+have the C<next> pointers in place, but it'll take me a while to
+figure out how to do that.
+
+=cut
+
+sub B::OP::parent {
+    my $op     = shift;
+    my $parent = $op->_parent_impl( $op, "" );
+
+    $parent;
 }
+
+sub B::NULL::_parent_impl { }
+
+sub B::OP::_parent_impl {
+    my ( $op, $target, $cx ) = @_;
+
+    return if $cx =~ /\b$$op\b/;
+
+    for ( $op->kids ) {
+        if ( $$_ == $$target ) {
+            return $op;
+        }
+    }
+
+    return (
+        $op->sibling->_parent_impl( $target, "$cx$$op S " )
+            || (
+              $cx =~ /^(?:\d+ S )*(?:\d+ N )*$/
+            ? $op->next->_parent_impl( $target, "$cx$$op N " )
+            : ()
+            )
+            || (
+              $op->can('first')
+            ? $op->first->_parent_impl( $target, "$cx$$op F " )
+            : ()
+            )
+    );
 }
 
-=head1 NAME
+=item C<$op-E<gt>ancestors>
 
-B::Utils - Helper functions for op tree manipulation
+Returns all parents of this node, recursively. The list is ordered
+from younger/closer parents to older/farther parents.
 
-=head1 SYNOPSIS
+=cut
 
-  use B::Utils;
+sub B::OP::ancestors {
+    my @nodes = shift;
+
+    my $parent;
+    push @nodes, $parent while $parent = $nodes[-1]->parent;
+    shift @nodes;
+
+    return @nodes;
+}
+
+=item C<$op-E<gt>descendants>
+
+Returns all children of this node, recursively. The list is unordered.
+
+=cut
+
+sub B::OP::descendants {
+    my $node = shift;
+    my @nodes;
+    walkoptree_simple( $node,
+        sub { push @nodes, $_ if ${ $_[0] } != $$node } );
+    return shuffle @nodes;
+}
+
+=item C<$op-E<gt>siblings>
+
+Returns all younger siblings of this node. The list is ordered from
+younger/closer siblings to older/farther siblings.
+
+=cut
+
+sub B::OP::siblings {
+    my @siblings = shift;
+
+    my $sibling;
+    push @siblings, $sibling while $sibling = $siblings[-1]->can('sibling');
+    shift @siblings;
+    pop @siblings if 'NULL' eq class $siblings[-1];
+
+    return @siblings;
+}
+
+=item C<$op-E<gt>previous>
+
+Like C< $op-E<gt>next >, but not quite.
 
-=head1 DESCRIPTION
+=cut
+
+## sub B::OP::previous {
+##     return unless defined wantarray;
+##
+##     my $target = shift;
+##
+##     my $start = $target;
+##     my (%deadend, $search);
+##     $search = sub {
+##         my $node = $_[0];
+##
+##         unless ( defined $node ) {
+##             # If I've been asked to search nothing, just return. The
+##             # ->parent call might do this to me.
+##             return FALSE;
+##         }
+##         elsif ( exists $deadend{$node} ) {
+##             # If this node has been seen already, try again as its
+##             # parent.
+##             return $search->( $node->parent );
+##         }
+##         elsif ( eval { ${$node->next} == $$target } ) {
+##             return $node;
+##         }
+##
+##         # When searching the children, do it in reverse order because
+##         # pointers back up are more likely to be farther down the
+##         # stack. This works without reversing but I can avoid some
+##         # work by ordering the work this way.
+##         my @kids = reverse $node->kids;
+##
+##         # Search this node's direct children for the ->next pointer
+##         # that points to this node.
+##         eval { ${$_->can('next')} == $$target } and return $_->next
+##           for @kids;
+##
+##         # For each child, check it for a match.
+## 	my $found;
+##         $found = $search->($_) and return $found
+##           for @kids;
+##
+##         # Not in this subtree.
+##         $deadend{$node} = TRUE;
+##         return FALSE;
+##     };
+##
+##     my $next = $target;
+##     while ( eval { $next = $next->next } ) {
+## 	my $result;
+##         $result = $search->( $next )
+##           and return $result;
+##     }
+##
+##     return FALSE;
+## }
+
+=item C<$op-E<gt>stringify>
+
+Returns a nice stringification of an opcode.
+
+=cut
+
+sub B::OP::stringify {
+    my $op = shift;
+
+    return sprintf "%s-%s=(0x%07x)", $op->name, class($op), $$op;
+}
+
+=item C<$op-E<gt>as_opgrep_pattern(%options)>
+
+From the op tree it is called on, C<as_opgrep_pattern()>
+generates a data structure suitable for use as a condition pattern
+for the C<opgrep()> function described below in detail.
+I<Beware>: When using such generated patterns, there may be
+false positives: The pattern will most likely not match I<only>
+the op tree it was generated from since by default, not all properties
+of the op are reproduced.
+
+You can control which properties of the op to include in the pattern
+by passing named arguments. The default behaviour is as if you
+passed in the following options:
+
+  my $pattern = $op->as_opgrep_pattern(
+    attributes          => [qw(name flags)],
+    max_recursion_depth => undef,
+  );
+
+So obviously, you can set C<max_recursion_depth> to a number to
+limit the maximum depth of recursion into the op tree. Setting
+it to C<0> will limit the dump to the current op.
+
+C<attributes> is a list of attributes to include in the produced
+pattern. The attributes that can be checked against in this way
+are 
+
+  name targ type seq flags private pmflags pmpermflags.
 
-These functions make it easier to manipulate the op tree.
+=cut
+
+sub B::OP::as_opgrep_pattern {
+  my $op = shift;
+  my $opt = (@_ == 1 and ref($_[0]) eq 'HASH') ? shift() : {@_};
+
+  my $attribs = $opt->{attributes};
+  $attribs ||= [qw(name flags)];
+  
+  my $pattern = {};
+  foreach my $attr (@$attribs) {
+    $pattern->{$attr} = $op->$attr() if $op->can($attr);
+  }
 
-=head1 FUNCTIONS
+  my $recursion_limit = $opt->{max_recursion_depth};
+  if ( (not defined $recursion_limit or $recursion_limit > 0)
+       and ref($op)
+       and $$op
+       and $op->flags & OPf_KIDS
+  ) {
+    $opt->{max_recursion_depth}-- if defined $recursion_limit;
+
+    $pattern->{kids} = [
+      map { $_->as_opgrep_pattern($opt) } $op->kids()
+    ];
+  }
 
-=over 3
+  # reset the option structure in case we got a hash ref passed in.
+  $opt->{max_recursion_depth} = $recursion_limit
+    if exists $opt->{max_recursion_depth};
+
+  return $pattern;
+}
+
+=back
+
+=head1 EXPORTABLE FUNCTIONS
+
+=over 4
 
 =item C<all_starts>
 
@@ -79,279 +395,244 @@
 Returns a hash of all of the starting ops or root ops of optrees, keyed
 to subroutine name; the optree for main program is simply keyed to C<__MAIN__>.
 
-B<Note>: Certain "dangerous" stashes are not scanned for subroutines: 
-the list of such stashes can be found in C<@B::Utils::bad_stashes>. Feel
-free to examine and/or modify this to suit your needs. The intention is
-that a simple program which uses no modules other than C<B> and
-C<B::Utils> would show no addition symbols.
+B<Note>: Certain "dangerous" stashes are not scanned for subroutines:
+the list of such stashes can be found in
+C<@B::Utils::bad_stashes>. Feel free to examine and/or modify this to
+suit your needs. The intention is that a simple program which uses no
+modules other than C<B> and C<B::Utils> would show no addition
+symbols.
 
 This does B<not> return the details of ops in anonymous subroutines
-compiled at compile time. For instance, given 
+compiled at compile time. For instance, given
 
     $a = sub { ... };
 
-the subroutine will not appear in the hash. This is just as well, since
-they're anonymous... If you want to get at them, use...
+the subroutine will not appear in the hash. This is just as well,
+since they're anonymous... If you want to get at them, use...
+
+=cut
+
+my ( %starts, %roots );
+sub all_starts { _init_sub_cache(); wantarray ? %starts : \%starts }
+sub all_roots  { _init_sub_cache(); wantarray ? %roots  : \%roots }
 
-=item C<anon_subs()>
+=item C<anon_subs>
 
 This returns an array of hash references. Each element has the keys
-"start" and "root". These are the starting and root ops of all of
-the anonymous subroutines in the program.
+"start" and "root". These are the starting and root ops of all of the
+anonymous subroutines in the program.
 
 =cut
 
-sub all_starts { _init(); return %starts; }
-sub all_roots  { _init(); return %roots; }
-sub anon_subs { _init(); return @anon_subs }
+my @anon_subs;
+sub anon_subs { _init_sub_cache(); wantarray ? @anon_subs : \@anon_subs }
 
-sub B::GV::_push_starts {
-    my $name = $_[0]->STASH->NAME."::".$_[0]->SAFENAME;
-    return unless ${$_[0]->CV};
-    my $cv = $_[0]->CV;
+=item C<recalc_sub_cache>
 
-    if ($cv->PADLIST->can("ARRAY") and $cv->PADLIST->ARRAY and $cv->PADLIST->ARRAY->can("ARRAY")) {
-        push @anon_subs, { root => $_->ROOT, start => $_->START} 
-            for grep { class($_) eq "CV" } $cv->PADLIST->ARRAY->ARRAY;
-    }
-    return unless ${$cv->START} and ${$cv->ROOT};
-    $starts{$name} = $cv->START;
-    $roots{$name} = $cv->ROOT;
-};
+If PL_sub_generation has changed or you have some other reason to want
+to force the re-examination of the optrees, everywhere, call this
+function.
 
-sub B::SPECIAL::_push_starts{}
+=cut
 
-=item C<< $op->oldname >>
+my $subs_cached = FALSE;
 
-Returns the name of the op, even if it is currently optimized to null.
-This helps you understand the stucture of the op tree.
+sub recalc_sub_cache {
+    $subs_cached = FALSE;
 
-=cut
+    %starts = %roots = @anon_subs = ();
 
-sub B::OP::oldname {
-    return substr(B::ppname($_[0]->targ),3) if $_[0]->name eq "null" and $_[0]->targ;
-    return $_[0]->name;
+    _init_sub_cache();
+    return;
 }
 
-=item C<< $op->kids >>
+sub _init_sub_cache {
 
-Returns an array of all this op's non-null children, in order.
+    # Allow this function to be run only once.
+    return if $subs_cached;
 
-=cut
+    %starts = ( __MAIN__ => main_start() );
+    %roots  = ( __MAIN__ => main_root() );
 
-sub B::OP::kids {
-    my $op = shift;
-    my @rv;
-    if (class($op) eq "LISTOP") { 
-        $op = $op->first;
-        push @rv, $op while $op->can("sibling") and $op = $op->sibling and $$op;
-        return @rv;
-    }
-    push @rv, $op->first if $op->can("first") and $op->first and ${$op->first};
-    push @rv, $op->last if $op->can("last") and $op->last and ${$op->last};
-    push @rv, $op->other if $op->can("other") and $op->other and ${$op->other};
-    return @rv;
-}
-
-=item C<< $op->parent >>
-
-Returns the parent node in the op tree, if possible. Currently "possible" means
-"if the tree has already been optimized"; that is, if we're during a C<CHECK>
-block. (and hence, if we have valid C<next> pointers.)
-
-In the future, it may be possible to search for the parent before we have the
-C<next> pointers in place, but it'll take me a while to figure out how to do
-that.
+    # Through the magic of B::'s ugly callback system, %starts and
+    # %roots will be populated.
+    walksymtable(
+        \%main::,
+        _B_Utils_init_sub_cache => sub {
+
+            # Do not eat our own children!
+            $_[0] eq "$_\::" && return FALSE for @bad_stashes;
+
+            return TRUE;
+        },
+        ''
+    );
+
+    # Some sort of file-scoped anonymous code refs are found here. In
+    # general, when a function has anonymous functions, they can be
+    # found in the scratchpad.
+    push @anon_subs,
+        map( (
+            'CV' eq class($_)
+            ? { root  => $_->ROOT,
+                start => $_->START
+                }
+            : ()
+        ),
+        main_cv()->PADLIST->ARRAY->ARRAY );
 
-=cut
+    $subs_cached = TRUE;
+    return;
+}
 
-sub B::OP::parent {
-    my $target = shift;
-    printf( "parent %s %s=(0x%07x)\n",
-	    B::class( $target),
-	    $target->oldname,
-	    $$target )
-	if $DEBUG;
-
-    die "I'm not sure how to do this yet. I'm sure there is a way. If you know, please email me."
-        if (!$target->seq);
-
-    my (%deadend, $search_kids);
-    $search_kids = sub {
-        my $node = shift || return undef;
-	
-	printf( "Searching from %s %s=(0x%07x)\n",
-		class($node)||'?',
-		$node->oldname,
-		$$node )
-	    if $DEBUG;
-		
-        # Go up a level if we've got stuck, and search (for the same
-        # $target) from a higher vantage point.
-        if ( exists $deadend{ $node } )
-	{
-	    printf( "   search parent %s %s=(0x%07x)\n",
-		    B::class( $node ),
-		    $node->oldname,
-		    $$node )
-		if $DEBUG;
-	    return $search_kids->( $node->parent );
-	}
-	
-        # Test the immediate children, but only children we haven't visited
-	# already.
-	my @new_kids = ( grep !$deadend{ $_ },
-			 $node->kids );
-	if ( scalar grep $$_ == $$target, @new_kids )
-	{
-	    return $node;
-	}
-	
-        # Recurse and examine each child, in turn.
-	print( "   search kids\n"
-	       . join( "",
-		       map sprintf( "      %s %s=(0x%07x)\n",
-				    B::class( $_ ),
-				    $_->oldname,
-				    $$_ ),
-		       @new_kids ) )
-	    if $DEBUG and @new_kids;
-	
-	for ( @new_kids )
-	{
-	    my $x = $search_kids->( $_ );
-	    return $x if $x;
-	}
-	
-        # Not in this subtree.
-        $deadend{$node}++;
-        return undef;
-    };
-    my $start = $target;
-    
-    # Skip to the farthest sibling and make a list of each with the most
-    # recent at the beginning of the list.
-    
-    # I am planning ahead for the day when it turns out that the parent
-    # cannot be found in the last sibling somewhere. Maybe it is just a
-    # null? I would like to be able to back track up the tree to find a
-    # ->next node that will bring us to northeast of (or even better,
-    # directly to) the parent.
-    my @siblings = $start;
-    while ( $start and
-	    ${$start->sibling} )
-    {
-	$start = $start->sibling;
-	unshift @siblings, $start;
-	printf( "->sibling %s %s=(0x%07x)\n",
-		class($start)||'null',
-		$start->oldname,
-		$$start )
-	    if $DEBUG;
-    }
-    
-    # Now search each sibling as noted from above.
-    for $start ( @siblings )
+sub B::GV::_B_Utils_init_sub_cache {
+
+    # This is a callback function called from B::Utils::_init via
+    # B::walksymtable.
+
+    my $gv = shift;
+    my $cv = $gv->CV;
+
+    # If the B::CV object is a pointer to nothing, ignore it.
+    return unless $$cv;
+
+    # Simon was originally using $gv->SAFENAME but I don't think
+    # that's a "correct" decision because then oddly named functions
+    # can't be disambiguated. If a function were actually named ^G, I
+    # couldn't tell it apart from one named after the control
+    # character ^G.
+    my $name = $gv->STASH->NAME . "::" . $gv->NAME;
+
+    # When does a CV not fulfill ->ARRAY->ARRAY? Some time during
+    # initialization?
+    if (    $cv->can('PADLIST')
+        and $cv->PADLIST->can('ARRAY')
+        and $cv->PADLIST->ARRAY->can('ARRAY') )
     {
-	my $next = $start;
-	while ( $$next )
-	{
-	    printf( "->next %s %s=(0x%07x)\n",
-		    B::class( $next ),
-		    $next->oldname,
-		    $$next )
-		if $DEBUG;
-	
-	    my $result = $search_kids->( $next );
-	    return $result if $result;
-	}
-	continue
-	{
-	    $next = $next->next;
-	}
-    }
-    
-    # Having reached here... I give up?
-    undef;
-}
-
-=item C<< $op->previous >>
-
-Like C<< $op->next >>, but not quite.
+        push @anon_subs,
+            map( (
+                'CV' eq class($_)
+                ? { root  => $_->ROOT,
+                    start => $_->START
+                    }
+                : ()
+            ),
+            $cv->PADLIST->ARRAY->ARRAY );
+    }
 
-=cut
+    return unless ( ( my $start = $cv->START )
+        and ( my $root = $cv->ROOT ) );
+
+    $starts{$name} = $start;
+    $roots{$name}  = $root;
 
-sub B::OP::previous {
-    my $target = shift;
-    my $start = $target;
-    my (%deadend, $search);
-    $search = sub {
-        my $node = shift || die;
-        return $search->(find_parent($node)) if exists $deadend{$node};
-        return $node if $node->{next}==$target;
-        # Recurse
-        my $x;
-        ($_->next == $target and return $_) for $node->kids;
-        defined($x = $search->($_)) and return $x for $node->{kids};
- 
-        # Not in this subtree.
-        $deadend{$node}++;
-        return undef;
-   };
-   my $result;
-   $result = $search->($start) and return $result
-        while $start = $start->next;
+    #    return TRUE;
+    return;
 }
 
-=item walkoptree_simple($op, \&callback, [$data])
+# sub B::SPECIAL::_B_Utils_init_sub_cache {
+#
+#     # This is a callback function called from B::Utils::_init via
+#     # B::walksymtable.
+#
+#     # JJ: I'm not sure why this callback function exists.
+#
+#     return TRUE;
+# }
+
+=item C<walkoptree_simple($op, \&callback, [$data])>
 
 The C<B> module provides various functions to walk the op tree, but
 they're all rather difficult to use, requiring you to inject methods
 into the C<B::OP> class. This is a very simple op tree walker with
 more expected semantics.
 
-All the C<walk> functions set C<B::Utils::file> and C<B::Utils::line>
-to the appropriate values of file and line number in the program
-being examined.
+All the C<walk> functions set C<$B::Utils::file>, C<$B::Utils::line>,
+and C<$B::Utils::sub> to the appropriate values of file, line number,
+and sub name in the program being examined.
 
 =cut
 
-our ($file, $line) = ("__none__",0);
+$file = '__none__';
+$line = 0;
+$sub  = undef;
 
 sub walkoptree_simple {
-    my ($op, $callback, $data) = @_;
-    ($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
-    $callback->($op,$data);
-    if ($$op && ($op->flags & OPf_KIDS)) {
-        my $kid;
-        for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
-            walkoptree_simple($kid, $callback, $data);
-        }
+    $file = '__none__';
+    $line = 0;
+
+    &_walkoptree_simple;
+
+    return TRUE;
+}
+
+sub _walkoptree_simple {
+    my ( $op, $callback, $data ) = @_;
+
+    if ( ref $op and $op->isa("B::COP") ) {
+        $file = $op->file;
+        $line = $op->line;
+    }
+
+    $callback->( $op, $data );
+    if (    ref $op
+        and $$op
+        and $op->flags & OPf_KIDS )
+    {
+        _walkoptree_simple( $_, $callback, $data ) for $op->kids;
     }
+
+    return;
+
 }
 
-=item walkoptree_filtered($op, \&filter, \&callback, [$data])
+=item C<walkoptree_filtered($op, \&filter, \&callback, [$data])>
 
 This is much the same as C<walkoptree_simple>, but will only call the
-callback if the C<filter> returns true. The C<filter> is passed the 
-op in question as a parameter; the C<opgrep> function is fantastic 
+callback if the C<filter> returns true. The C<filter> is passed the
+op in question as a parameter; the C<opgrep> function is fantastic
 for building your own filters.
 
 =cut
 
 sub walkoptree_filtered {
-    my ($op, $filter, $callback, $data) = @_;
-    ($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
-    $callback->($op,$data) if $filter->($op);
-    if ($$op && ($op->flags & OPf_KIDS)) {
-        my $kid;
-        for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
-            walkoptree_filtered($kid, $filter, $callback, $data);
+    $file = '__none__';
+    $line = 0;
+
+    &_walkoptree_filtered;
+
+    return TRUE;
+}
+
+sub _walkoptree_filtered {
+    my ( $op, $filter, $callback, $data ) = @_;
+
+    if ( $op->isa("B::COP") ) {
+        $file = $op->file;
+        $line = $op->line;
+    }
+
+    $callback->( $op, $data ) if $filter->($op);
+
+    if (    ref $op
+        and $$op
+        and $op->flags & OPf_KIDS )
+    {
+
+        my $kid = $op->first;
+        while ( ref $kid
+            and $$kid )
+        {
+            _walkoptree_filtered( $kid, $filter, $callback, $data );
+
+            $kid = $kid->sibling;
         }
     }
+
+    return TRUE;
 }
 
-=item walkallops_simple(\&callback, [$data])
+=item C<walkallops_simple(\&callback, [$data])>
 
 This combines C<walkoptree_simple> with C<all_roots> and C<anon_subs>
 to examine every op in the program. C<$B::Utils::sub> is set to the
@@ -360,137 +641,430 @@
 
 =cut
 
-our $sub;
-
 sub walkallops_simple {
-    my ($callback, $data) = @_;
+    $sub = undef;
+
+    &_walkallops_simple;
+
+    return TRUE;
+}
+
+sub _walkallops_simple {
+    my ( $callback, $data ) = @_;
+
     _init();
-    for $sub (keys %roots) {
-        walkoptree_simple($roots{$sub}, $callback, $data);
-    }
+
+    walkoptree_simple( $_, $callback, $data ) for values %roots;
+
     $sub = "__ANON__";
-    for (@anon_subs) {
-        walkoptree_simple($_->{root}, $callback, $data);
-    }
+    walkoptree_simple( $_->{root}, $callback, $data ) for @anon_subs;
+
+    return TRUE;
 }
 
-=item walkallops_filtered(\&filter, \&callback, [$data])
+=item C<walkallops_filtered(\&filter, \&callback, [$data])>
 
 Same as above, but filtered.
 
 =cut
 
 sub walkallops_filtered {
-    my ($filter, $callback, $data) = @_;
-    _init();
-    for $sub (keys %roots) {
-        walkoptree_filtered($roots{$sub}, $filter, $callback, $data);
-    }
-    $sub = "__ANON__";
-    for (@anon_subs) {
-        walkoptree_filtered($_->{root}, $filter, $callback, $data);
-    }
+    $sub = undef;
+
+    &_walkallops_filterd;
+
+    return TRUE;
 }
 
-=item carp(@args) 
+sub _walkallops_filtered {
+    my ( $filter, $callback, $data ) = @_;
 
-=item croak(@args) 
+    _init();
 
-Warn and die, respectively, from the perspective of the position of the op in
-the program. Sounds complicated, but it's exactly the kind of error reporting
-you expect when you're grovelling through an op tree.
+    walkoptree_filtered( $_, $filter, $callback, $data ) for values %roots;
 
-=cut
+    $sub = "__ANON__";
 
-sub _preparewarn {
-    my $args = join '', @_;
-    $args = "Something's wrong " unless $args;
-    $args .= " at $file line $line.\n" unless substr($args, length($args) -1) eq "\n";
-}
+    walkoptree_filtered( $_->{root}, $filter, $callback, $data )
+        for @anon_subs;
 
-sub carp  (@) { CORE::die(preparewarn(@_)) }
-sub croak (@) { CORE::warn(preparewarn(@_)) }
+    return TRUE;
+}
 
-=item opgrep(\%conditions, @ops)
+=item C<opgrep(\%conditions, @ops)>
 
-Returns the ops which meet the given conditions. The conditions should be
-specified like this:
+Returns the ops which meet the given conditions. The conditions should
+be specified like this:
 
     @barewords = opgrep(
                         { name => "const", private => OPpCONST_BARE },
                         @ops
                        );
 
+where the first argument to C<opgrep()> is the condition to be matched against the
+op structure. We'll henceforth refer to it as an op-pattern.
+
 You can specify alternation by giving an arrayref of values:
 
     @svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
 
-And you can specify inversion by making the first element of the arrayref
-a "!". (Hint: if you want to say "anything", say "not nothing": C<["!"]>)
+And you can specify inversion by making the first element of the
+arrayref a "!". (Hint: if you want to say "anything", say "not
+nothing": C<["!"]>)
 
-You may also specify the conditions to be matched in nearby ops.
+You may also specify the conditions to be matched in nearby ops as nested patterns.
 
     walkallops_filtered(
-        sub { opgrep( {name => "exec", 
+        sub { opgrep( {name => "exec",
                        next => {
                                  name    => "nextstate",
                                  sibling => { name => [qw(! exit warn die)] }
                                }
                       }, @_)},
-        sub { 
-              carp("Statement unlikely to be reached"); 
+        sub {
+              carp("Statement unlikely to be reached");
               carp("\t(Maybe you meant system() when you said exec()?)\n");
         }
     )
 
 Get that?
 
-Here are the things that can be tested:
+Here are the things that can be tested in this way:
 
         name targ type seq flags private pmflags pmpermflags
         first other last sibling next pmreplroot pmreplstart pmnext
 
+Additionally, you can use the C<kids> keyword with an array reference
+to match the result of a call to C<$op-E<gt>kids()>. An example use is
+given in the documentation for C<op_or> below.
+
+For debugging, you can have many properties of an op that is currently being
+matched against a given condition dumped to STDERR
+by specifying C<dump => 1> in the condition's hash reference.
+
+If you match a complex condition against an op tree, you may want to extract
+a specific piece of information from the tree if the condition matches.
+This normally entails manually walking the tree a second time down to
+the op you wish to extract, investigate or modify. Since this is tedious
+duplication of code and information, you can specify a special property
+in the pattern of the op you wish to extract to capture the sub-op
+of interest. Example:
+
+  my ($result) = opgrep(
+    { name => "exec",
+      next => { name    => "nextstate",
+                sibling => { name => [qw(! exit warn die)]
+                             capture => "notreached",
+                           },
+              }
+    },
+    $root_op
+  );
+  
+  if ($result) {
+    my $name = $result->{notreached}->name; # result is *not* the root op
+    carp("Statement unlikely to be reached (op name: $name)");
+    carp("\t(Maybe you meant system() when you said exec()?)\n");
+  }
+  
+While the above is a terribly contrived example, consider the win for a
+deeply nested pattern or worse yet, a pattern with many disjunctions.
+If a C<capture> property is found anywhere in
+the op pattern, C<opgrep()> returns an unblessed hash reference on success
+instead of the tested op. You can tell them apart using L<Scalar::Util>'s
+C<blessed()>. That hash reference contains all captured ops plus the
+tested root up as the hash entry C<$result-E<gt>{op}>. Note that you cannot
+use this feature with C<walkoptree_filtered> since that function was
+specifically documented to pass the tested op itself to the callback.
+
+You cannot capture disjunctions, but that doesn't really make sense anyway.
+
+=item C<opgrep( \@conditions, @ops )>
+
+Same as above, except that you don't have to chain the conditions
+yourself.  If you pass an array-ref, opgrep will chain the conditions
+for you using C<next>. 
+The conditions can either be strings (taken as op-names), or
+hash-refs, with the same testable conditions as given above.
+
 =cut
 
 sub opgrep {
-    my ($cref, @ops) = @_;
-    my %conds = %$cref;
-    my @rv = ();
-    my $o;
-    OPLOOP: for $o (@ops) {
-        # First, let's skim off ops of the wrong type.
-        for (qw(first other last pmreplroot pmreplstart pmnext pmflags pmpermflags)) {
-            next OPLOOP if exists $conds{$_} and !$o->can($_);
-        }
+    return unless defined wantarray;
 
-        for my $test (qw(name targ type seq flags private pmflags pmpermflags)) {
-            next unless exists $conds{$test};
-            next OPLOOP unless ref $o and $o->can($test);
-	    if (!ref $conds{$test}) {
-	       next OPLOOP if $o->$test ne $conds{$test};
-	    } else {
-		    if ($conds{$test}[0] eq "!") {
-			my @conds = @{$conds{$test}}; shift @conds;
-			next OPLOOP if grep {$o->$test eq $_} @conds;
-		    } else {
-			next OPLOOP unless grep {$o->$test eq $_} @{$conds{$test}};
-		    }
-	    }
-        }
+    my $conds_ref = shift;
+    $conds_ref = _opgrep_helper($conds_ref)
+        if 'ARRAY' eq ref $conds_ref;
+
+    my @grep_ops;
+
+    # Check whether we're dealing with a disjunction of patterns:
+    my @conditions = exists($conds_ref->{disjunction}) ? @{$conds_ref->{disjunction}} : ($conds_ref);
+
+OP:
+    for my $op (@_) {
+        next unless ref $op and $$op;
+
+        # only one condition by default, but if we have a disjunction, there will
+        # be several
+CONDITION:
+        foreach my $condition (@conditions) {
+            # nested disjunctions? naughty user!
+            # $foo or ($bar or $baz) is $foo or $bar or $baz!
+            # ==> flatten
+            if (exists($condition->{disjunction})) {
+              push @conditions, @{$condition->{disjunction}};
+              next CONDITION;
+            }
+
+            # structure to hold captured information
+            my $capture = {};
+
+            # Debugging aid
+            if (exists $condition->{'dump'}) {
+                ($op->can($_)
+                or next)
+                and warn "$_: " . $op->$_ . "\n"
+                for
+                qw( first other last pmreplroot pmreplstart pmnext pmflags pmpermflags name targ type seq flags private kids);
+            }
+
+            # special disjunction case. undef in a disjunction => (child) does not exist
+            if (not defined $condition) {
+                return TRUE if not defined $op and not wantarray();
+                return();
+            }
+
+            # save the op if the user wants flat access to it
+            if ($condition->{capture}) {
+                $capture->{ $condition->{capture} } = $op;
+            }
+
+            # First, let's skim off ops of the wrong type. If they require
+            # something that isn't implemented for this kind of object, it
+            # must be wrong. These tests are cheap
+            exists $condition->{$_}
+                and !$op->can($_)
+                and next
+                for
+                qw( first other last pmreplroot pmreplstart pmnext pmflags pmpermflags name targ type seq flags private kids);
+
+#            # Check alternations
+#            (   ref( $condition->{$_} )
+#                ? ( "!" eq $condition->{$_}[0]
+#                    ? ()
+#                    : ()
+#                    )
+#                : ( $op->can($_) && $op->$_ eq $condition->{$_} or next )
+#                )
+#                for qw( name targ type seq flags private pmflags pmpermflags );
+
+            for my $test (
+                qw(name targ type seq flags private pmflags pmpermflags))
+            {
+                next unless exists $condition->{$test};
+                my $val = $op->$test;
+
+                if ( 'ARRAY' eq ref $condition->{$test} ) {
+
+                    # Test a list of valid/invalid values.
+                    if ( '!' eq $condition->{$test}[0] ) {
+
+                        # Fail if any entries match.
+                        $_ ne $val
+                            or next CONDITION 
+                            for @{ $condition->{$test} }
+                            [ 1 .. $#{ $condition->{$test} } ];
+                    }
+                    else {
+
+                        # Fail if no entries match.
+                        my $okay = 0;
+                        
+                        $_ eq $val and $okay = 1, last 
+                            for @{ $condition->{$test} };
+
+                        next CONDITION if not $okay;
+                    }
+                }
+                elsif ( 'CODE' eq ref $condition->{$test} ) {
+                    local $_ = $val;
+                    $condition->{$test}($op)
+                        or next CONDITION;
+                }
+                else {
+
+                    # Test a single value.
+                    $condition->{$test} eq $op->$test
+                        or next CONDITION;
+                }
+            } # end for test
+
+            # We know it ->can because that was tested above. It is an
+            # error to have anything in this list of tests that isn't
+            # tested for ->can above.
+            foreach (
+              qw( first other last sibling next pmreplroot pmreplstart pmnext )
+              ) {
+                next unless exists $condition->{$_};
+                my ($result) = opgrep( $condition->{$_}, $op->$_ );
+                next CONDITION if not $result;
+
+                if (not blessed($result)) {
+                    # copy over the captured data/ops from the recursion
+                    $capture->{$_} = $result->{$_} foreach keys %$result;
+                }
+            }
+  
+            # Apply all kids conditions. We $op->can(kids) (see above).
+            if (exists $condition->{kids}) {
+                my $kidno = 0;
+                my $kidconditions = $condition->{kids};
+
+                next CONDITION if not @{$kidconditions} == @{$condition->{kids}};
+
+                foreach my $kid ($op->kids()) {
+                    # if you put undef in your kid conditions list, we skip one kid
+                    next if not defined $kidconditions->[$kidno];
+
+                    my ($result) = opgrep( $kidconditions->[$kidno++], $kid );
+                    next CONDITION if not $result;
+                    
+                    if (not blessed($result)) {
+                        # copy over the captured data/ops from the recursion
+                        $capture->{$_} = $result->{$_} foreach keys %$result;
+                    }
+                }
+            }
+
+            # Attempt to quit early if possible.
+            if (wantarray) {
+                if (keys %$capture) {
+                    # save all captured information and the main op
+                    $capture->{op} = $op;
+                    push @grep_ops, $capture;
+                }
+                else {
+                    # save main op
+                    push @grep_ops, $op;
+                }
+                last;
+            }
+            elsif ( defined wantarray ) {
+                return TRUE;
+            }
+        } # end for @conditions
+        # end of conditions loop should be end of op test
+    }
 
-        for my $neighbour (qw(first other last sibling next pmreplroot pmreplstart pmnext)) {
-            next unless exists $conds{$neighbour};
-            # We know it can, because we tested that above
-            # Recurse, recurse!
-            next OPLOOP unless opgrep($conds{$neighbour}, $o->$neighbour);
-        }
+    # Either this was called in list context and then I want to just
+    # return everything possible or this is in scalar/void context and
+    # @grep_ops will be empty and thus "false."
+    return @grep_ops;
+}
 
-        push @rv, $_;
+sub _opgrep_helper {
+    my @conds =
+        map ref() ? {%$_} : { name => $_ }, @{ $_[0] };
+
+    # Wire this into a list of entries, all ->next
+    for ( 1 .. $#conds ) {
+        $conds[ $_ - 1 ]{next} = $conds[$_];
     }
-    return @rv;
+
+    # This is a linked list now so I can return only the head.
+    return $conds[0];
 }
 
-1;
+=item C<op_or( @conditions )>
+
+Unlike the chaining of conditions done by C<opgrep> itself if there are multiple
+conditions, this function creates a disjunction (C<$cond1 || $cond2 || ...>) of
+the conditions and returns a structure (hash reference) that can be passed to
+opgrep as a single condition.
+
+Example:
+
+  my $sub_structure = {
+    name => 'helem',
+    first => { name => 'rv2hv', },
+    'last' => { name => 'const', },
+  };
+  
+  my @ops = opgrep( {
+      name => 'leavesub',
+      first => {
+        name => 'lineseq',
+        kids => [,
+          { name => 'nextstate', },
+          op_or(
+            {
+              name => 'return',
+              first => { name => 'pushmark' },
+              last => $sub_structure,
+            },
+            $sub_structure,
+          ),
+        ],
+      },
+  }, $op_obj );
+
+This example matches the code in a typical simplest-possible
+accessor method (albeit not down to the last bit):
+
+  sub get_foo { $_[0]->{foo} }
+
+But by adding an alternation
+we can also match optional op layers. In this case, we optionally
+match a return statement, so the following implementation is also
+recognized:
+
+  sub get_foo { return $_[0]->{foo} }
+
+Essentially, this is syntactic sugar for the following structure
+recognized by C<opgrep()>:
+
+  { disjunction => [@conditions] }
+
+=cut
+
+sub op_or {
+  my @conditions = @_;
+  return({ disjunction => [@conditions] });
+}
+
+sub op_pattern_match {
+  my $op = shift;
+  my $pattern = shift;
+
+  my $ret = {};
+
+  
+  return $ret;
+}
+
+=item C<carp(@args)>
+
+=item C<croak(@args)>
+
+Warn and die, respectively, from the perspective of the position of
+the op in the program. Sounds complicated, but it's exactly the kind
+of error reporting you expect when you're grovelling through an op
+tree.
+
+=cut
+
+sub carp (@)  { CORE::warn( _preparewarn(@_) ) }
+sub croak (@) { CORE::die( _preparewarn(@_) ) }
+
+sub _preparewarn {
+    my $args = join '', @_;
+    $args = "Something's wrong " unless $args;
+    if ( "\n" ne substr $args, -1, 1 ) {
+        $args .= " at $file line $line.\n";
+    }
+    return $args;
+}
 
 =back
 
@@ -500,16 +1074,22 @@
 
 =head1 AUTHOR
 
-Simon Cozens, C<simon at cpan.org>
+Originally written by Simon Cozens, C<simon at cpan.org>
+Maintained by Joshua ben Jore, C<jjore at cpan.org>
+
+Contributions from Mattia Barbon, Jim Cromie, and Steffen Mueller.
 
-=head1 TODO
+=head1 LICENSE
 
-I need to add more Fun Things, and possibly clean up some parts where
-the (previous/parent) algorithm has catastrophic cases, but it's more
-important to get this out right now than get it right.
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
 
 =head1 SEE ALSO
 
 L<B>, L<B::Generate>.
 
 =cut
+
+"Wow, you're pretty uptight for a guy who worships a multi-armed,
+hermaphrodite embodiment of destruction who has a fetish for vaguely
+phallic shaped headgear.";

Added: B-Utils/t/00signature.t
==============================================================================
--- (empty file)
+++ B-Utils/t/00signature.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,10 @@
+#!perl
+use Test::More;
+eval "use Test::Signature;";
+if ( $@ ) {
+    plan skip_all => "Test::Signature wasn't installed";
+}
+else {
+    plan tests => 1;
+    signature_ok();
+}

Added: B-Utils/t/01pod.t
==============================================================================
--- (empty file)
+++ B-Utils/t/01pod.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,6 @@
+#!perl
+use Test::More;
+eval "use Test::Pod";
+plan skip_all => "Test::Pod required for testing POD" if $@;
+
+all_pod_files_ok();

Added: B-Utils/t/03yaml.t
==============================================================================
--- (empty file)
+++ B-Utils/t/03yaml.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,9 @@
+use Test::More;
+eval "use YAML qw( LoadFile )";
+if ($@) {
+    plan( skip_all => "YAML required to test META.yml's syntax" );
+}
+else {
+    plan( tests => 1 );
+    ok( LoadFile("META.yml") );
+}

Added: B-Utils/t/10use.t
==============================================================================
--- (empty file)
+++ B-Utils/t/10use.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,4 @@
+#!perl
+use strict;
+use Test::More tests => 1;
+BEGIN { use_ok( 'B::Utils' ) };

Added: B-Utils/t/11export.t
==============================================================================
--- (empty file)
+++ B-Utils/t/11export.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,25 @@
+use Test::More tests => 12;
+use strict;
+use B::Utils;
+
+ok( B::Utils->can('import'), "Can import()" );
+
+is( scalar(@B::Utils::EXPORTS), 0, "Nothing is exported without asking" );
+
+is( scalar( @{ $B::Utils::EXPORT_TAGS{all} } ),
+    scalar(@B::Utils::EXPORT_OK),
+    "All optional exports are exported via :all"
+);
+
+# Test for function exports
+for my $function (
+    qw( all_starts all_roots anon_subs recalc_sub_cache
+    walkoptree_simple walkoptree_filtered
+    walkallops_simple walkallops_filtered )
+    )
+{
+    ok( eval { B::Utils->import($function); 1 },
+        "B::Utils exports $function" );
+}
+
+cmp_ok( B::Utils->VERSION, '>=', 0.01, "B::Utils->VERSION is specified" );

Added: B-Utils/t/20all_starts.t
==============================================================================
--- (empty file)
+++ B-Utils/t/20all_starts.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,26 @@
+#!perl
+use Test::More tests => 4;
+use B 'svref_2object';
+use B::Utils 'all_starts';
+
+sub find_this { 1 }
+
+{
+    # List context
+    my %starts = all_starts();
+    ok( $starts{'main::find_this'},
+        "Found start" );
+    is( ${svref_2object( \ &find_this )->START},
+        ${$starts{'main::find_this'}},
+        "Found correct start" );
+}
+{
+    # Scalar context
+    my $starts = all_starts();
+    ok( $starts->{'main::find_this'},
+        "Found start" );
+    is( ${svref_2object( \ &find_this )->START},
+        ${$starts->{'main::find_this'}},
+        "Found correct start" );
+}
+        

Added: B-Utils/t/21all_roots.t
==============================================================================
--- (empty file)
+++ B-Utils/t/21all_roots.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,27 @@
+#!perl
+use Test::More tests => 4;
+use B 'svref_2object';
+use B::Utils 'all_roots';
+
+sub find_this { 1 }
+
+{
+    # List context
+    my %roots = all_roots();
+    
+    ok( $roots{'main::find_this'},
+        "Found root" );
+    is( ${svref_2object( \ &find_this )->ROOT},
+        ${$roots{'main::find_this'}},
+        "Found correct root" );
+}
+{
+    # Scalar context
+    my $roots = all_roots();
+    ok( $roots->{'main::find_this'},
+        "Found root" );
+    is( ${svref_2object( \ &find_this )->ROOT},
+        ${$roots->{'main::find_this'}},
+        "Found correct root" );
+}
+

Added: B-Utils/t/22anon_subs.t
==============================================================================
--- (empty file)
+++ B-Utils/t/22anon_subs.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,30 @@
+#!perl
+use Test::More tests => 2;
+use B 'svref_2object';
+use B::Utils 'anon_subs';
+
+my $sub = sub {
+    my $arg = shift;
+    return sub { time - 10 }
+};
+my $found = svref_2object( $sub );
+
+{
+    # List context
+    my @subs = anon_subs();
+    
+    is( scalar grep( ${$found->START} == ${$_->{start}}
+		     && ${$found->ROOT} == ${$_->{root}},
+		     @subs ),
+	1,
+        "Found correct anon sub" );
+}
+{
+    # List context
+    my $subs = anon_subs();
+    is( scalar grep( ${$found->START} == ${$_->{start}}
+		     && ${$found->ROOT} == ${$_->{root}},
+		     @$subs ),
+	1,
+        "Found correct anon sub" );
+}

Added: B-Utils/t/30parent.t
==============================================================================
--- (empty file)
+++ B-Utils/t/30parent.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1,62 @@
+test_data() for @empty_array;
+
+{
+    no warnings;
+
+    sub test_data {
+        BB() if AA();
+        DD() for CC();
+        my $x = 10;
+        FF() while EE() < --$x;
+        for ( my $y; $y; ++$y ) {
+            ++$x;
+        }
+
+        0 for 0;
+    }
+}
+
+use strict;
+use Test::More;
+use B 'svref_2object';
+use B::Utils 'walkoptree_simple';
+
+# use B::Concise;
+# B::Concise::set_style(
+#     "#hyphseq2 (*(   (x( ;)x))*)#exname-#class=(#addr) #arg ~#flags(?(/#private)?)(x(;~->#next)x)\n",
+#     "  (*(    )*)     goto #seq\n",
+#     "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"
+# );
+# B::Concise::compile("test_data")->();
+
+# Set the # of tests to run and make a table of parents
+my $tests = 0;
+my $root  = svref_2object( \&test_data )->ROOT;
+walkoptree_simple( $root, sub { ++$tests } );
+plan( tests => ( $tests * 2 ) - 1 );
+
+walkoptree_simple(
+    $root,
+    sub {
+        my $op = shift;
+
+        my $parent = eval { $op->parent };
+        if ( $$op == $$root ) {
+            is( $parent, undef, "No parent for root " . $op->stringify );
+        }
+        else {
+
+            ok( $parent, $op->stringify . " has a parent" );
+
+            my $correct_parent;
+            for ( $parent ? $parent->kids : () ) {
+                if ( $$_ == $$op ) {
+                    $correct_parent = 1;
+                    last;
+                }
+            }
+
+            ok( $correct_parent, $op->stringify . " has the *right* parent" );
+        }
+    }
+);

Added: B-Utils/t/31oldname.t
==============================================================================
--- (empty file)
+++ B-Utils/t/31oldname.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/32kids.t
==============================================================================
--- (empty file)
+++ B-Utils/t/32kids.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/33ancestors.t
==============================================================================
--- (empty file)
+++ B-Utils/t/33ancestors.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/34descendants.t
==============================================================================
--- (empty file)
+++ B-Utils/t/34descendants.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/35siblings.t
==============================================================================
--- (empty file)
+++ B-Utils/t/35siblings.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/36previous.t
==============================================================================
--- (empty file)
+++ B-Utils/t/36previous.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/37stringify.t
==============================================================================
--- (empty file)
+++ B-Utils/t/37stringify.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/40walk.t
==============================================================================
--- (empty file)
+++ B-Utils/t/40walk.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/41walkfilt.t
==============================================================================
--- (empty file)
+++ B-Utils/t/41walkfilt.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/42all.t
==============================================================================
--- (empty file)
+++ B-Utils/t/42all.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/43allfilt.t
==============================================================================
--- (empty file)
+++ B-Utils/t/43allfilt.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/44optrep.t
==============================================================================
--- (empty file)
+++ B-Utils/t/44optrep.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/50carp.t
==============================================================================
--- (empty file)
+++ B-Utils/t/50carp.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";

Added: B-Utils/t/51croak.t
==============================================================================
--- (empty file)
+++ B-Utils/t/51croak.t	Wed Aug 13 09:06:58 2008
@@ -0,0 +1 @@
+use Test::More skip_all => "No tests written yet.";


More information about the Jifty-commit mailing list