[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