r53822 - in /trunk/libsub-wrappackages-perl: ./ debian/ lib/Sub/ t/ t/lib/ t/lib/Module/With/Both/ t/lib/Module/With/Data/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun Mar 7 01:55:50 UTC 2010
Author: jawnsy-guest
Date: Sun Mar 7 01:55:42 2010
New Revision: 53822
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=53822
Log:
Standards-Version 3.8.4 (no changes)
Added:
trunk/libsub-wrappackages-perl/t/02b_inh_late_loading.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/02b_inh_late_loading.t
trunk/libsub-wrappackages-perl/t/02c_inh_from_grandparent.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/02c_inh_from_grandparent.t
trunk/libsub-wrappackages-perl/t/02d_inh_from_grandparent_parent_also_wrapped.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/02d_inh_from_grandparent_parent_also_wrapped.t
trunk/libsub-wrappackages-perl/t/02e_inh_from_grandparent_parent_also_wrapped_order_rev.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/02e_inh_from_grandparent_parent_also_wrapped_order_rev.t
trunk/libsub-wrappackages-perl/t/02f_point_inh_proxies_at_original.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/02f_point_inh_proxies_at_original.t
trunk/libsub-wrappackages-perl/t/03_inh_in_same_file.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/03_inh_in_same_file.t
trunk/libsub-wrappackages-perl/t/03b_inh_in_same_file_late_loading.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/03b_inh_in_same_file_late_loading.t
trunk/libsub-wrappackages-perl/t/04b_wrap_tree_of_packages_late_loading.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/04b_wrap_tree_of_packages_late_loading.t
trunk/libsub-wrappackages-perl/t/06_prototypes.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/06_prototypes.t
trunk/libsub-wrappackages-perl/t/07_use_lib.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/07_use_lib.t
trunk/libsub-wrappackages-perl/t/08_caller.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/08_caller.t
trunk/libsub-wrappackages-perl/t/10_prototypes.t
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/10_prototypes.t
trunk/libsub-wrappackages-perl/t/coverage.sh
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/coverage.sh
trunk/libsub-wrappackages-perl/t/lib/Prototyped.pm
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/lib/Prototyped.pm
trunk/libsub-wrappackages-perl/t/lib/c.pm
- copied unchanged from r53816, branches/upstream/libsub-wrappackages-perl/current/t/lib/c.pm
Removed:
trunk/libsub-wrappackages-perl/t/03_wrap_inherited_in_same_file.t
trunk/libsub-wrappackages-perl/t/04b_wrap_tree_of_packages_after_loading.t
Modified:
trunk/libsub-wrappackages-perl/Changes
trunk/libsub-wrappackages-perl/MANIFEST
trunk/libsub-wrappackages-perl/META.yml
trunk/libsub-wrappackages-perl/Makefile.PL
trunk/libsub-wrappackages-perl/TODO
trunk/libsub-wrappackages-perl/debian/changelog
trunk/libsub-wrappackages-perl/debian/control
trunk/libsub-wrappackages-perl/lib/Sub/WrapPackages.pm
trunk/libsub-wrappackages-perl/t/00_wrap_as_subs.t
trunk/libsub-wrappackages-perl/t/01_wrap_as_packages.t
trunk/libsub-wrappackages-perl/t/01b_wrap_as_packages_late_loading.t
trunk/libsub-wrappackages-perl/t/02_wrap_inherited.t
trunk/libsub-wrappackages-perl/t/04_wrap_tree_of_packages.t
trunk/libsub-wrappackages-perl/t/05___DATA__.t
trunk/libsub-wrappackages-perl/t/lib/Module/With/Both/Segments.pm
trunk/libsub-wrappackages-perl/t/lib/Module/With/Data/Segment.pm
trunk/libsub-wrappackages-perl/t/lib/a.pm
trunk/libsub-wrappackages-perl/t/lib/b.pm
Modified: trunk/libsub-wrappackages-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/Changes?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/Changes (original)
+++ trunk/libsub-wrappackages-perl/Changes Sun Mar 7 01:55:42 2010
@@ -1,3 +1,8 @@
+2010-03-06 2.0 Slightly incompatible re-write
+
+2010-01-09 1.31 Bugfix for 'use constant' in perl 5.10, thanks to
+ Lee Johnson
+
2009-08-11 1.3 deferred wrapping of modules that aren't yet loaded;
wildcards for modules
Modified: trunk/libsub-wrappackages-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/MANIFEST?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/MANIFEST (original)
+++ trunk/libsub-wrappackages-perl/MANIFEST Sun Mar 7 01:55:42 2010
@@ -1,7 +1,4 @@
lib/Sub/WrapPackages.pm
-t/00_wrap_as_subs.t
-t/01_wrap_as_packages.t
-t/02_wrap_inherited.t
t/lib/a.pm
t/lib/b.pm
MANIFEST
@@ -10,20 +7,36 @@
Changes
Makefile.PL
t/lib/Banana.pm
-t/03_wrap_inherited_in_same_file.t
-t/pod-coverage.t
-t/pod.t
-t/04_wrap_tree_of_packages.t
t/lib/Banana/Tree.pm
-t/01b_wrap_as_packages_late_loading.t
-t/04b_wrap_tree_of_packages_after_loading.t
ARTISTIC.txt
GPL2.txt
t/lib/Orchard/Tree/Pear/Conference.pm
-t/05___DATA__.t
t/lib/Module/With/Data/Segment.pm
t/lib/Module/With/END/Segment.pm
t/lib/Module/With/Both/Segments.pm
+t/lib/Prototyped.pm
+t/lib/c.pm
+t/00_wrap_as_subs.t
+t/01_wrap_as_packages.t
+t/01b_wrap_as_packages_late_loading.t
+t/02_wrap_inherited.t
+t/02b_inh_late_loading.t
+t/02c_inh_from_grandparent.t
+t/02d_inh_from_grandparent_parent_also_wrapped.t
+t/02e_inh_from_grandparent_parent_also_wrapped_order_rev.t
+t/03_inh_in_same_file.t
+t/03b_inh_in_same_file_late_loading.t
+t/04_wrap_tree_of_packages.t
+t/04b_wrap_tree_of_packages_late_loading.t
+t/05___DATA__.t
+t/06_prototypes.t
+t/07_use_lib.t
+t/pod-coverage.t
+t/pod.t
+t/08_caller.t
+t/02f_point_inh_proxies_at_original.t
+t/coverage.sh
+t/lib/breakuseconstant.pm
+t/09_5.10_use_constant.t
+t/10_prototypes.t
META.yml Module meta-data (added by MakeMaker)
-t/09_5.10_use_constant.t
-t/lib/breakuseconstant.pm
Modified: trunk/libsub-wrappackages-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/META.yml?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/META.yml (original)
+++ trunk/libsub-wrappackages-perl/META.yml Sun Mar 7 01:55:42 2010
@@ -1,11 +1,22 @@
-# http://module-build.sourceforge.net/META-spec.html
-#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
-name: Sub-WrapPackages
-version: 1.31
-version_from: lib/Sub/WrapPackages.pm
-installdirs: site
+--- #YAML:1.0
+name: Sub-WrapPackages
+version: 2.0
+abstract: ~
+author: []
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
requires:
- Hook::LexWrap: 0.2
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.30
+ Devel::Caller::IgnoreNamespaces: 1
+ Sub::Prototype: 0.02
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.50
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Modified: trunk/libsub-wrappackages-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/Makefile.PL?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/Makefile.PL (original)
+++ trunk/libsub-wrappackages-perl/Makefile.PL Sun Mar 7 01:55:42 2010
@@ -3,13 +3,8 @@
NAME => 'Sub::WrapPackages',
VERSION_FROM => 'lib/Sub/WrapPackages.pm',
PREREQ_PM => {
- Hook::LexWrap => 0.20,
+ 'Sub::Prototype' => 0.02,
+ # 'Sub::Uplevel' => 0.22,
+ 'Devel::Caller::IgnoreNamespaces' => 1.0,
}
);
-
-# package MY;
-# sub test {
-# my $text = shift->SUPER::test(@_);
-# $text =~ s/\t(.*test_harness)/\tHARNESS_OPTIONS=j8 $1/;
-# $text;
-# }
Modified: trunk/libsub-wrappackages-perl/TODO
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/TODO?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/TODO (original)
+++ trunk/libsub-wrappackages-perl/TODO Sun Mar 7 01:55:42 2010
@@ -1,2 +1,4 @@
-Match prototypes
Can we do something funky with AUTOLOAD?
+
+use PPI to find __DATA__ / __END__
+ perl -MPPI -MPPI::Dumper -e 'PPI::Dumper->new(PPI::Document->new("t/lib/Module/With/Data/Segment.pm"))->print()'
Modified: trunk/libsub-wrappackages-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/debian/changelog?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/debian/changelog (original)
+++ trunk/libsub-wrappackages-perl/debian/changelog Sun Mar 7 01:55:42 2010
@@ -1,15 +1,13 @@
-libsub-wrappackages-perl (1.31-1) UNRELEASED; urgency=low
-
- Lots of prototype warnings :/
- http://rt.cpan.org/Ticket/Display.html?id=55065
+libsub-wrappackages-perl (2.0-1) UNRELEASED; urgency=low
[ Jonathan Yu ]
* New upstream release
+ * Standards-Version 3.8.4 (no changes)
[ Ryan Niebur ]
* Update jawnsy's email address
- -- Jonathan Yu <jawnsy at cpan.org> Wed, 10 Feb 2010 21:14:34 -0500
+ -- Jonathan Yu <jawnsy at cpan.org> Sat, 06 Mar 2010 21:20:43 -0500
libsub-wrappackages-perl (1.3-1) unstable; urgency=low
Modified: trunk/libsub-wrappackages-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/debian/control?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/debian/control (original)
+++ trunk/libsub-wrappackages-perl/debian/control Sun Mar 7 01:55:42 2010
@@ -7,7 +7,7 @@
Maintainer: Debian Perl Group <pkg-perl-maintainers at lists.alioth.debian.org>
Uploaders: Jaldhar H. Vyas <jaldhar at debian.org>,
Jonathan Yu <jawnsy at cpan.org>
-Standards-Version: 3.8.3
+Standards-Version: 3.8.4
Homepage: http://search.cpan.org/dist/Sub-WrapPackages/
Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libsub-wrappackages-perl/
Vcs-Browser: http://svn.debian.org/viewsvn/pkg-perl/trunk/libsub-wrappackages-perl/
@@ -15,8 +15,8 @@
Package: libsub-wrappackages-perl
Architecture: all
Depends: ${perl:Depends}, ${misc:Depends}, libhook-lexwrap-perl
-Description: Perl module to wrap subroutines in packages
+Description: module to wrap subroutines in packages
Sub::WrapPackages is a Perl module that can add pre- and post-execution code
wrappers around some given subroutines. It is mostly a wrapper around Damian
- Conwway's Hook::LexWrap module. Instead of exporting a wrap function, magic
+ Conway's Hook::LexWrap module. Instead of exporting a wrap function, magic
happens when you load the module via the "use" keyword.
Modified: trunk/libsub-wrappackages-perl/lib/Sub/WrapPackages.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/lib/Sub/WrapPackages.pm?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/lib/Sub/WrapPackages.pm (original)
+++ trunk/libsub-wrappackages-perl/lib/Sub/WrapPackages.pm Sun Mar 7 01:55:42 2010
@@ -1,13 +1,27 @@
use strict;
use warnings;
+use Data::Dumper;
+
package Sub::WrapPackages;
-use vars qw($VERSION);
-
-$VERSION = '1.31';
-
-use Hook::LexWrap;
+use vars '$VERSION';
+use vars '%ORIGINAL_SUBS'; # coderefs of what we're wrapping, keyed
+ # by package::sub
+use vars '@MAGICINCS'; # list of magic INC subs, used by lib.pm hack
+use vars '%INHERITED'; # coderefs of inherited methods (before proxies
+ # installed), keys by package::sub
+use vars '%WRAPPED_BY_WRAPPER'; # coderefs of original subs, keyed by
+ # stringified coderef of wrapper
+use vars '%WRAPPER_BY_WRAPPED'; # coderefs of wrapper subs, keyed by
+ # stringified coderef of original sub
+use Sub::Prototype ();
+use Devel::Caller::IgnoreNamespaces;
+Devel::Caller::IgnoreNamespaces::register(__PACKAGE__);
+
+use lib ();
+
+$VERSION = '2.0';
=head1 NAME
@@ -31,66 +45,95 @@
print "$_[0] returned $_[1]\n";
};
+=head1 COMPATIBILITY
+
+While this module does broadly the same job as the 1.x versions did,
+the interface may have changed incompatibly. Sorry. Hopefully it'll
+be more maintainable and slightly less crazily magical. Also, caller()
+should now work properly, ignoring wrappings.
+
=head1 DESCRIPTION
-This is mostly a wrapper around Damian Conway's Hook::LexWrap module.
-Please go and read the docs for that module now. The differences are:
+This module installs pre- and post- execution subroutines for the
+subroutines or packages you specify. The pre-execution subroutine
+is passed the
+wrapped subroutine's name and all its arguments. The post-execution
+subroutine is passed the wrapped sub's name and its results.
+
+The return values from the pre- and post- subs are ignored, and they
+are called in the same context (void, scalar or list) as the calling
+code asked for.
+
+Normal usage is to pass a bunch of parameters when the module is used.
+However, you can also call Sub::WrapPackages::wrapsubs with the same
+parameters.
+
+=head1 PARAMETERS
+
+Either pass parameters on loading the module, as above, or pass them
+to ...
+
+=head2 the wrapsubs subroutine
=over 4
-=item no exporting
-
-We don't export a wrap() function, instead preferring to do all the magic
-when you C<use> this module. We just wrap named subroutines, no references.
-I didn't need that functionality so although it's probably available if
-you look at the source I haven't tested it. Patches welcome!
-
-=item the subs and packages arrayrefs
+=item the subs arrayref
In the synopsis above, you will see two named parameters, C<subs> and
-C<packages>. Any subroutine mentioned in C<subs> will be wrapped. Any
-packages mentioned in C<packages> will have all their subroutines wrapped,
-including any that they import.
-
+C<packages>. Any subroutine mentioned in C<subs> will be wrapped.
Any subroutines mentioned in 'subs' must already exist - ie their modules
-must be loaded - at the time you try to wrap them. Otherwise the order in
-which modules are loaded doesn't matter due to Stunt Code.
+must be loaded - at the time you try to wrap them.
+
+=item the packages arrayref
+
+Any package mentioned here will have all its subroutines wrapped,
+including any that it imports at load-time. Packages can be loaded
+in any order - they don't have to already be loaded for Sub::WrapPackages
+to work its magic.
+
+You can specify wildcard packages. Anything ending in ::* is assumed
+to be such. For example, if you specify Orchard::Tree::*, then that
+matches Orchard::Tree, Orchard::Tree::Pear, Orchard::Apple::KingstonBlack
+etc, but not - of course - Pine::Tree or My::Orchard::Tree.
Note, however, that if a module exports a subroutine at load-time using
C<import> then that sub will be wrapped in the exporting module but not in
the importing module. This is because import() runs before we get a chance
-to fiddle with things. The code for deferred fiddlage isn't re-entrant.
-It's probably horribly fragile in all kinds of other ways too.
+to fiddle with things. Sorry.
+
+Deferred wrapping of subs in packages that aren't yet loaded works
+via a subroutine inserted in @INC. This means that if you mess around
+with @INC, eg by inserting a directoy at the beginning of the path, the
+magic might not get a chance to run. If you C<use lib> to mess with
+ at INC though, it should work, as I've over-ridden lib's import() method.
+That said, code this funky has no right to work. Use with caution!
=item wrap_inherited
In conjunction with the C<packages> arrayref, this wraps all calls to
inherited methods made through those packages. If you call those
-methods directly in the superclass then they are not affected.
-
-=item parameters passed to your subs
-
-I threw Damian's ideas out of the window. Instead, your pre-wrapper will
-be passed the wrapped subroutine's name, and all the parameters to be passed
-to it. Who knows what will happen if you modify those params, I don't
-need that so haven't tested it. Patches welcome!
-
-The post-wrapper will be passed the wrapped subroutine's name, and a single
-parameter for the return value(s) as in Damian's module. Figuring out the
-difference between returning an array and returning a reference to an array
-is left as an exercise for the interested reader.
+methods directly in the superclass then they are not affected - unless
+they're wrapped in the superclass of course.
+
+=item pre and post
+
+References to the subroutines you want to use as wrappers.
=back
=head1 BUGS
-Wrapped subroutines may cause perl 5.6.1, and maybe other versions, to
-segfault when called in void context. I believe this is a bug in
-Hook::LexWrap.
-
-I say "patches welcome" a lot.
-
-AUTOLOAD and DESTROY are not treated as being special.
+AUTOLOAD and DESTROY are not treated as being special. I'm not sure
+whether they should be or not.
+
+If you use wrap_inherited but classes change their inheritance tree at
+run-time, then very bad things will happen. VERY BAD THINGS. So don't
+do that. You shouldn't be doing that anyway. Mind you, you shouldn't
+be doing the things that this module does either. BAD PROGRAMMER, NO
+BIKKIT!
+
+If you find any other lurking horrors, please report them using
+L<https://rt.cpan.org/Public/Dist/Display.html?Name=Sub-WrapPackages>.
=head1 FEEDBACK
@@ -109,25 +152,27 @@
=head1 THANKS TO
-Thanks also to Adam Trickett who thought this was a jolly good idea,
-Tom Hukins who prompted me to add support for inherited methods, and Ed
+Thanks to Tom Hukins for sending in a test case for the situation when
+a class and a subclass are both defined in the same file, and for
+prompting me to support inherited methods;
+
+to Dagfinn Ilmari Mannsaker for help with the craziness for
+fiddling with modules that haven't yet been loaded;
+
+to Lee Johnson for reporting a bug caused by perl 5.10's
+constant.pm being Far Too Clever, and providing a patch and test;
+
+to Adam Trickett who thought this was a jolly good idea;
+
+and to Ed
Summers, whose code for figgering out what functions a package contains
I borrowed out of L<Acme::Voodoo>.
-Thanks to Tom Hukins for sending in a test case for the situation when
-a class and a subclass are both defined in the same file.
-
-Thanks to Dagfinn Ilmari Mannsaker for help with the craziness for
-fiddling with modules that haven't yet been loaded.
-
-Thanks to Lee Johnson for reporting a bug caused by perl 5.10's
-constant.pm being Far Too Clever, and providing a patch and test.
-
=cut
sub import {
shift;
- _wrapsubs(@_) if(@_);
+ wrapsubs(@_) if(@_);
}
sub _subs_in_packages {
@@ -137,7 +182,6 @@
foreach my $package (@targets) {
no strict;
while(my($k, $v) = each(%{$package})) {
- # 5.10 makes 'use constant' imports into scalars
push @subs, $package.$k if(ref($v) ne 'SCALAR' && defined(&{$v}));
}
}
@@ -149,7 +193,7 @@
my $wildcard_packages = [map { s/::.//; $_; } grep { /::\*$/ } @{$params{packages}}];
my $nonwildcard_packages = [grep { $_ !~ /::\*$/ } @{$params{packages}}];
- unshift @INC, sub {
+ push @MAGICINCS, sub {
my($me, $file) = @_;
(my $module = $file) =~ s{/}{::}g;
$module =~ s/\.pm//;
@@ -165,46 +209,52 @@
close($fh);
%Sub::WrapPackages::params = %params;
- $text =~ /(.*?)(__DATA__|__END__|$)/s;
+ $text =~ /(.*?)(__DATA__.*|__END__.*|$)/s;
my($code, $trailer) = ($1, $2);
$text = $code.qq[
;
- Sub::WrapPackages::_wrapsubs(
+ Sub::WrapPackages::wrapsubs(
%Sub::WrapPackages::params,
packages => [qw($module)]
);
1;
- ].$trailer;
+ ]."\n$trailer";
open($fh, '<', \$text);
$fh;
};
-}
-
-sub _wrapsubs {
+ unshift @INC, $MAGICINCS[-1];
+}
+
+sub _getparents {
+ my $package = shift;
+ my @parents = eval '@'.$package.'::ISA';
+ return @parents, (map { _getparents($_) } @parents);
+}
+
+sub wrapsubs {
my %params = @_;
if(exists($params{packages}) && ref($params{packages}) =~ /^ARRAY/) {
my $wildcard_packages = [map { (my $foo = $_) =~ s/::.$//; $foo; } grep { /::\*$/ } @{$params{packages}}];
my $nonwildcard_packages = [grep { $_ !~ /::\*$/ } @{$params{packages}}];
- # wrap stuff that's not yet loaded
+ # defer wrapping stuff that's not yet loaded
_make_magic_inc(%params);
- # wrap wildcards that *are* loaded
+ # wrap wildcards that are loaded
if(@{$wildcard_packages}) {
foreach my $loaded (map { (my $f = $_) =~ s!/!::!g; $f =~ s/\.pm$//; $f } keys %INC) {
my $pattern = '^('.join('|',
map { (my $f = $_) =~ s/::\*$/::/; $f } @{$wildcard_packages}
).')';
- _wrapsubs(%params, packages => [$loaded]) if($loaded =~ /$pattern/);
+ wrapsubs(%params, packages => [$loaded]) if($loaded =~ /$pattern/);
}
}
- # wrap non-wildcards that *are* loaded
+ # wrap non-wildcards that are loaded
if($params{wrap_inherited}) {
foreach my $package (@{$nonwildcard_packages}) {
- # FIXME? does this work with 'use base'
- my @parents = eval '@'.$package.'::ISA';
+ my @parents = _getparents($package);
# get inherited (but not over-ridden!) subs
my %subs_in_package = map {
@@ -217,18 +267,24 @@
s/.*:://; $_;
} _subs_in_packages(@parents);
- # define them in $package using SUPER
+ # define proxy method that just does a goto to get
+ # to the right place. We then later wrap the proxy
foreach my $sub (@subs_to_define) {
- no strict;
- *{$package."::$sub"} = eval "
- sub {
- package $package;
- my \$self = shift;
- \$self->SUPER::$sub(\@_);
- };
- ";
- eval 'package __PACKAGE__';
- # push @{$params{subs}}, $package."::$sub";
+ next if(exists($INHERITED{$package."::$sub"}));
+ $INHERITED{$package."::$sub"} = $package->can($sub);
+ # if the inherited method is already wrapped,
+ # point this proxy at the original method
+ # so we don't wrap a wrapper
+ if(exists($WRAPPED_BY_WRAPPER{$INHERITED{$package."::$sub"}})) {
+ $INHERITED{$package."::$sub"} =
+ $WRAPPED_BY_WRAPPER{$INHERITED{$package."::$sub"}};
+ }
+ eval qq{
+ sub ${package}::$sub {
+ goto &{\$Sub::WrapPackages::INHERITED{"${package}::$sub"}};
+ }
+ };
+ die($@) if($@);
}
}
}
@@ -238,14 +294,60 @@
}
return undef if(!$params{pre} && !$params{post});
+ $params{pre} ||= sub {};
+ $params{post} ||= sub {};
foreach my $sub (@{$params{subs}}) {
- Hook::LexWrap::wrap($sub, (($params{pre}) ?
- (pre => sub { &{$params{pre}}($sub, @_[0..$#_-1]) }) : ()
- ),(($params{post}) ?
- (post => sub { &{$params{post}}($sub, $_[-1]) }) : ()
- ));
+ next if(exists($ORIGINAL_SUBS{$sub}));
+
+ $ORIGINAL_SUBS{$sub} = \&{$sub};
+ my $imposter = sub {
+ local *__ANON__ = $sub;
+ my(@r, $r) = ();
+ my $wa = wantarray();
+ if(!defined($wa)) {
+ $params{pre}->($sub, @_);
+ $ORIGINAL_SUBS{$sub}->(@_);
+ $params{post}->($sub);
+ } elsif($wa) {
+ my @f = $params{pre}->($sub, @_);
+ @r = $ORIGINAL_SUBS{$sub}->(@_);
+ @f = $params{post}->($sub, @r);
+ } else {
+ my $f = $params{pre}->($sub, @_);
+ $r = $ORIGINAL_SUBS{$sub}->(@_);
+ $f = $params{post}->($sub, $r);
+ }
+ return wantarray() ? @r : $r;
+ };
+ Sub::Prototype::set_prototype($imposter, prototype($ORIGINAL_SUBS{$sub}))
+ if(prototype($ORIGINAL_SUBS{$sub}));
+
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ $WRAPPED_BY_WRAPPER{$imposter} = $ORIGINAL_SUBS{$sub};
+ $WRAPPER_BY_WRAPPED{$ORIGINAL_SUBS{$sub}} = $imposter;
+
+ *{$sub} = $imposter;
+ };
}
}
+package lib;
+use strict; no strict 'refs';
+use warnings; no warnings 'redefine';
+
+my $originallibimport = \&{'lib::import'};
+my $newimport = sub {
+ $originallibimport->(@_);
+ my %magicincs = map { $_, 1 } @Sub::WrapPackages::MAGICINCS;
+ @INC = (
+ (grep { exists($magicincs{$_}); } @INC),
+ (grep { !exists($magicincs{$_}); } @INC)
+ );
+};
+
+*{'lib::import'} = $newimport;
+
1;
Modified: trunk/libsub-wrappackages-perl/t/00_wrap_as_subs.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/00_wrap_as_subs.t?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/00_wrap_as_subs.t (original)
+++ trunk/libsub-wrappackages-perl/t/00_wrap_as_subs.t Sun Mar 7 01:55:42 2010
@@ -1,36 +1,50 @@
#!/usr/bin/perl -w
-
-my $loaded;
-my $r;
use strict;
-BEGIN { $| = 1; print "1..3\n"; }
-END { print "not ok 1\n" unless $loaded; }
+my $pre;
+my $post;
+
+use Test::More tests => 10;
use lib 't/lib'; use a;
use Sub::WrapPackages (
- subs => [qw(a::a_scalar a::a_list)],
- pre => sub {
- $r .= join(", ", @_);
- },
- post => sub {
- $r .= ref($_[1]) =~ /^ARRAY/ ? join(', ', @{$_[1]}) : $_[1];
- }
+ subs => [qw(a::a_scalar a::a_list a::a_context_sensitive)],
+ pre => sub { $pre .= join(", ", @_); },
+ post => sub { $post .= join(", ", @_); }
);
-$loaded=1;
-my $test = 0;
-print "ok ".(++$test)." compile and wrap subs\n";
+my $r = a::a_scalar(1..3);
-$r .= a::a_scalar(1..3);
+is($pre, 'a::a_scalar, 1, 2, 3',
+ 'pre-wrapper works in scalar context');
+is($post, 'a::a_scalar, in sub a_scalar',
+ 'post-wrapper works in scalar context');
+is($r, 'in sub a_scalar',
+ 'return scalar in scalar context');
-print 'not ' unless($r eq 'a::a_scalar, 1, 2, 3in sub a_scalarin sub a_scalar');
-print 'ok '.(++$test)." returning scalar in scalar context\n";
-
-$r = '';
+$pre = $post = '';
my @r = a::a_list(4,6,8);
-print 'not ' unless(join('', @r) eq 'insuba_list' && $r eq 'a::a_list, 4, 6, 8in, sub, a_list');
-print 'ok '.(++$test)." returning array in array context\n";
+is($pre, 'a::a_list, 4, 6, 8',
+ 'pre-wrapper works in list context');
+is($post, 'a::a_list, in, sub, a_list',
+ 'post-wrapper works in list context');
+is(join(', ', @r), 'in, sub, a_list',
+ 'return list in list context');
+a::a_context_sensitive();
+ok($main::voidcontext, 'wantarray() undef in void context');
+is_deeply(my $foo = a::a_context_sensitive(), [qw(in sub a_context_sensitive)],
+ 'wantarray() false in scalar context');
+is_deeply([my @foo = a::a_context_sensitive()], [qw(in sub a_context_sensitive)],
+ 'wantarray() true in list context');
+
+Sub::WrapPackages::wrapsubs(
+ subs => [qw(a::a_scalar a::a_list a::a_context_sensitive)],
+ pre => sub { $pre .= join(", ", @_); },
+ post => sub { $post .= join(", ", @_); }
+);
+$pre = '';
+$r = a::a_scalar(1..3);
+is($pre, 'a::a_scalar, 1, 2, 3', "subs can't be re-wrapped");
Modified: trunk/libsub-wrappackages-perl/t/01_wrap_as_packages.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/01_wrap_as_packages.t?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/01_wrap_as_packages.t (original)
+++ trunk/libsub-wrappackages-perl/t/01_wrap_as_packages.t Sun Mar 7 01:55:42 2010
@@ -1,32 +1,30 @@
#!/usr/bin/perl -w
-my $r;
-
use strict;
-
-BEGIN { $| = 1; print "1..2\n"; }
+use Test::More tests => 4;
use lib 't/lib'; use a;
+my $pre; my $post;
use Sub::WrapPackages (
packages => [qw(a)],
- pre => sub {
- $r .= join(", ", @_);
- },
- post => sub {
- $r .= ref($_[1]) =~ /^ARRAY/ ? join(', ', @{$_[1]}) : $_[1];
- }
+ pre => sub { $pre .= join(", ", @_); },
+ post => sub { $post .= join(", ", @_); }
);
-my $test = 0;
+my $r = a::a_scalar(1..3);
-$r .= a::a_scalar(1..3);
+is($pre, 'a::a_scalar, 1, 2, 3',
+ 'package pre-wrapper works');
+is($post, 'a::a_scalar, in sub a_scalar',
+ 'package post-wrapper works');
+is($r, 'in sub a_scalar',
+ 'package-wrapped sub returns correctly');
-print 'not ' unless($r eq 'a::a_scalar, 1, 2, 3in sub a_scalarin sub a_scalar');
-print 'ok '.(++$test)." returning scalar in scalar context\n";
-
-$r = '';
-my @r = a::a_list(4,6,8);
-
-print 'not ' unless(join('', @r) eq 'insuba_list' && $r eq 'a::a_list, 4, 6, 8in, sub, a_list');
-print 'ok '.(++$test)." returning array in array context\n";
-
+Sub::WrapPackages::wrapsubs(
+ packages => [qw(a)],
+ pre => sub { $pre .= join(", ", @_); },
+ post => sub { $post .= join(", ", @_); }
+);
+$pre = '';
+$r = a::a_scalar(1..3);
+is($pre, 'a::a_scalar, 1, 2, 3', "subs can't be re-wrapped via a package");
Modified: trunk/libsub-wrappackages-perl/t/01b_wrap_as_packages_late_loading.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/01b_wrap_as_packages_late_loading.t?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/01b_wrap_as_packages_late_loading.t (original)
+++ trunk/libsub-wrappackages-perl/t/01b_wrap_as_packages_late_loading.t Sun Mar 7 01:55:42 2010
@@ -1,34 +1,22 @@
#!/usr/bin/perl -w
-my $r;
+use strict;
+use Test::More tests => 3;
-use strict;
-
-BEGIN { $| = 1; print "1..2\n"; }
-
+my $pre; my $post;
use lib 't/lib';
use Sub::WrapPackages (
packages => [qw(a)],
- pre => sub {
- $r .= join(", ", @_);
- },
- post => sub {
- $r .= ref($_[1]) =~ /^ARRAY/ ? join(', ', @{$_[1]}) : $_[1];
- }
+ pre => sub { $pre .= join(", ", @_); },
+ post => sub { $post .= join(", ", @_); }
);
+use a;
-use a; # load after Sub::WrapPackages
+my $r = a::a_scalar(1..3);
-my $test = 0;
-
-$r .= a::a_scalar(1..3);
-
-print 'not ' unless($r eq 'a::a_scalar, 1, 2, 3in sub a_scalarin sub a_scalar');
-print 'ok '.(++$test)." returning scalar in scalar context\n";
-
-$r = '';
-my @r = a::a_list(4,6,8);
-
-print 'not ' unless(join('', @r) eq 'insuba_list' && $r eq 'a::a_list, 4, 6, 8in, sub, a_list');
-print 'ok '.(++$test)." returning array in array context\n";
-
+is($pre, 'a::a_scalar, 1, 2, 3',
+ 'package pre-wrapper works');
+is($post, 'a::a_scalar, in sub a_scalar',
+ 'package post-wrapper works');
+is($r, 'in sub a_scalar',
+ 'package-wrapped sub returns correctly');
Modified: trunk/libsub-wrappackages-perl/t/02_wrap_inherited.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/02_wrap_inherited.t?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/02_wrap_inherited.t (original)
+++ trunk/libsub-wrappackages-perl/t/02_wrap_inherited.t Sun Mar 7 01:55:42 2010
@@ -1,32 +1,41 @@
#!/usr/bin/perl -w
use strict;
-use Test::More tests => 3;
+use Test::More tests => 8;
use Data::Dumper;
-my $r;
+my $pre; my $post;
use lib 't/lib'; use b;
use Sub::WrapPackages (
packages => [qw(b)],
wrap_inherited => 1,
- pre => sub { $r .= join(", ", @_); },
- post => sub {
- $r .= ref($_[1]) =~ /^ARRAY/ ? join(', ', @{$_[1]}) : $_[1];
- }
+ pre => sub { $pre .= join(", ", @_); },
+ post => sub { $post .= join(', ', @_); }
);
-$r .= b->b_function();
+my $r = b->b_function(94);
-ok($r eq 'b::b_function, bi like piei like pie',
- 'when wrapping inherited methods, normal methods are wrapped too');
+is($pre, 'b::b_function, b, 94',
+ "when wrapping inherited methods, normal methods' pre-wrappers are OK");
+is($post, 'b::b_function, i like pie',
+ "when wrapping inherited methods, normal methods' post-wrappers are OK");
+is($r, 'i like pie',
+ "when wrapping inherited methods, normal methods' return the right value");
-$r = '';
+$pre = $post = '';
my @r = b->a_list(4,6,8);
-ok(join('', @r) eq 'insuba_list' && $r eq 'b::a_list, b, 4, 6, 8in, sub, a_list',
- 'Can wrap inherited subs');
+is($pre, 'b::a_list, b, 4, 6, 8',
+ "when wrapping inherited methods, pre-wrapper is OK");
+is($post, 'b::a_list, in, sub, a_list',
+ "when wrapping inherited methods, post-wrapper is OK");
+is_deeply(\@r, [qw(in sub a_list)],
+ "wrapped inherited method returns the right value");
-$r = '';
+$pre = $post = '';
@r = a->a_list(4,6,8);
-ok(join('', @r) eq 'insuba_list' && $r eq '', 'And calling the superclass method directly avoids wrapping shenanigans');
+ok($pre eq $post && $post eq '',
+ "calling the superclass method directly avoids wrapping shenanigans");
+is_deeply(\@r, [qw(in sub a_list)],
+ "non-wrapped super-class method returns the right value");
Modified: trunk/libsub-wrappackages-perl/t/04_wrap_tree_of_packages.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/04_wrap_tree_of_packages.t?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/04_wrap_tree_of_packages.t (original)
+++ trunk/libsub-wrappackages-perl/t/04_wrap_tree_of_packages.t Sun Mar 7 01:55:42 2010
@@ -3,10 +3,10 @@
use lib 't/lib';
-# FIXME uncomment, and fix prototype problems
-# BEGIN { $SIG{__WARN__} = sub { die(@_) }; }
+use Test::More tests => 8;
-use Test::More tests => 8;
+use Banana::Tree;
+use Orchard::Tree::Pear::Conference;
use Sub::WrapPackages (
packages => [qw(Banana::Tree Orchard::*)],
@@ -18,8 +18,5 @@
}
);
-use Banana::Tree; # load after Sub::WrapPackages
-use Orchard::Tree::Pear::Conference;
-
ok(Orchard::Tree::Pear::Conference::tastes_nasty, "Conference pears are BAD");
Banana::Tree::foo();
Modified: trunk/libsub-wrappackages-perl/t/05___DATA__.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/05___DATA__.t?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/05___DATA__.t (original)
+++ trunk/libsub-wrappackages-perl/t/05___DATA__.t Sun Mar 7 01:55:42 2010
@@ -3,7 +3,7 @@
use lib 't/lib';
-use Test::More tests => 9;
+use Test::More tests => 15;
use Sub::WrapPackages (
packages => [qw(
@@ -24,6 +24,8 @@
use Module::With::END::Segment;
ok(Module::With::Data::Segment::foo(), "wrapped sub in a module with a __DATA__ segment works");
+ok(Module::With::Data::Segment::data() =~ 'wibble', "and the __DATA__ is read OK");
ok(Module::With::Both::Segments::foo(), "wrapped sub in a module with __DATA__ and __END__ works");
+ok(Module::With::Both::Segments::data() =~ 'wibble', "and the __DATA__ is read OK");
ok(Module::With::END::Segment::foo(), "wrapped sub in a module with __END__ works");
Modified: trunk/libsub-wrappackages-perl/t/lib/Module/With/Both/Segments.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/lib/Module/With/Both/Segments.pm?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/lib/Module/With/Both/Segments.pm (original)
+++ trunk/libsub-wrappackages-perl/t/lib/Module/With/Both/Segments.pm Sun Mar 7 01:55:42 2010
@@ -1,6 +1,7 @@
package Module::With::Both::Segments;
sub foo { return 1; }
+sub data { return <DATA>; }
1;
__DATA__
wibble
Modified: trunk/libsub-wrappackages-perl/t/lib/Module/With/Data/Segment.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/lib/Module/With/Data/Segment.pm?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/lib/Module/With/Data/Segment.pm (original)
+++ trunk/libsub-wrappackages-perl/t/lib/Module/With/Data/Segment.pm Sun Mar 7 01:55:42 2010
@@ -1,6 +1,7 @@
package Module::With::Data::Segment;
sub foo { return 1; }
+sub data { return <DATA>; }
1;
__DATA__
wibble
Modified: trunk/libsub-wrappackages-perl/t/lib/a.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/lib/a.pm?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/lib/a.pm (original)
+++ trunk/libsub-wrappackages-perl/t/lib/a.pm Sun Mar 7 01:55:42 2010
@@ -2,4 +2,16 @@
sub a_scalar { return 'in sub a_scalar'; }
sub a_list { return qw(in sub a_list); }
+sub a_context_sensitive {
+ $main::voidcontext = 1 if(!defined(wantarray()));
+ my @rval = qw(in sub a_context_sensitive);
+ wantarray() ? @rval : \@rval;
+}
+sub a_caller {
+ return caller(shift()) if(@_);
+ return caller();
+}
+sub a_caller_caller {
+ a_caller(@_);
+}
1;
Modified: trunk/libsub-wrappackages-perl/t/lib/b.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libsub-wrappackages-perl/t/lib/b.pm?rev=53822&op=diff
==============================================================================
--- trunk/libsub-wrappackages-perl/t/lib/b.pm (original)
+++ trunk/libsub-wrappackages-perl/t/lib/b.pm Sun Mar 7 01:55:42 2010
@@ -1,6 +1,4 @@
package b;
-
-use lib 't/lib';
use base qw(a);
More information about the Pkg-perl-cvs-commits
mailing list