r15979 - in /branches/upstream/libsub-wrappackages-perl: ./ current/ current/lib/ current/lib/Sub/ current/t/ current/t/lib/
jaldhar at users.alioth.debian.org
jaldhar at users.alioth.debian.org
Fri Feb 29 20:06:40 UTC 2008
Author: jaldhar
Date: Fri Feb 29 20:06:40 2008
New Revision: 15979
URL: http://svn.debian.org/wsvn/?sc=1&rev=15979
Log:
[svn-inject] Installing original source of libsub-wrappackages-perl
Added:
branches/upstream/libsub-wrappackages-perl/
branches/upstream/libsub-wrappackages-perl/current/
branches/upstream/libsub-wrappackages-perl/current/Changes
branches/upstream/libsub-wrappackages-perl/current/MANIFEST
branches/upstream/libsub-wrappackages-perl/current/META.yml
branches/upstream/libsub-wrappackages-perl/current/Makefile.PL
branches/upstream/libsub-wrappackages-perl/current/README
branches/upstream/libsub-wrappackages-perl/current/TODO
branches/upstream/libsub-wrappackages-perl/current/lib/
branches/upstream/libsub-wrappackages-perl/current/lib/Sub/
branches/upstream/libsub-wrappackages-perl/current/lib/Sub/WrapPackages.pm
branches/upstream/libsub-wrappackages-perl/current/t/
branches/upstream/libsub-wrappackages-perl/current/t/00_wrap_as_subs.t
branches/upstream/libsub-wrappackages-perl/current/t/01_wrap_as_packages.t
branches/upstream/libsub-wrappackages-perl/current/t/02_wrap_inherited.t
branches/upstream/libsub-wrappackages-perl/current/t/03_wrap_inherited_in_same_file.t
branches/upstream/libsub-wrappackages-perl/current/t/lib/
branches/upstream/libsub-wrappackages-perl/current/t/lib/Banana.pm
branches/upstream/libsub-wrappackages-perl/current/t/lib/a.pm
branches/upstream/libsub-wrappackages-perl/current/t/lib/b.pm
Added: branches/upstream/libsub-wrappackages-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/Changes?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/Changes (added)
+++ branches/upstream/libsub-wrappackages-perl/current/Changes Fri Feb 29 20:06:40 2008
@@ -1,0 +1,3 @@
+2006-08-02: 1.2: changed how we detect what functions/methods a package defines
+2006-07-26: 1.1: added ability to wrap inherited subs
+2003-11-15: initial release
Added: branches/upstream/libsub-wrappackages-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/MANIFEST?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/MANIFEST (added)
+++ branches/upstream/libsub-wrappackages-perl/current/MANIFEST Fri Feb 29 20:06:40 2008
@@ -1,0 +1,14 @@
+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
+README
+TODO
+Changes
+Makefile.PL
+t/lib/Banana.pm
+t/03_wrap_inherited_in_same_file.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libsub-wrappackages-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/META.yml?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/META.yml (added)
+++ branches/upstream/libsub-wrappackages-perl/current/META.yml Fri Feb 29 20:06:40 2008
@@ -1,0 +1,11 @@
+# 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.2
+version_from:
+installdirs: site
+requires:
+ Hook::LexWrap: 0.2
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libsub-wrappackages-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/Makefile.PL?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/Makefile.PL (added)
+++ branches/upstream/libsub-wrappackages-perl/current/Makefile.PL Fri Feb 29 20:06:40 2008
@@ -1,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Sub::WrapPackages',
+ VERSION => '1.2',
+ PREREQ_PM => {
+ Hook::LexWrap => 0.20,
+ }
+);
Added: branches/upstream/libsub-wrappackages-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/README?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/README (added)
+++ branches/upstream/libsub-wrappackages-perl/current/README Fri Feb 29 20:06:40 2008
@@ -1,0 +1,11 @@
+Ths module makes it easy to surround large numbers of subroutines and
+methods with pre- and post-execution code.
+
+To install, do the usual:
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+You may use, modify and distribute this code under the same terms as you
+may use, modify and distribute perl itself.
Added: branches/upstream/libsub-wrappackages-perl/current/TODO
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/TODO?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/TODO (added)
+++ branches/upstream/libsub-wrappackages-perl/current/TODO Fri Feb 29 20:06:40 2008
@@ -1,0 +1,1 @@
+Can we do something funky with AUTOLOAD?
Added: branches/upstream/libsub-wrappackages-perl/current/lib/Sub/WrapPackages.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/lib/Sub/WrapPackages.pm?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/lib/Sub/WrapPackages.pm (added)
+++ branches/upstream/libsub-wrappackages-perl/current/lib/Sub/WrapPackages.pm Fri Feb 29 20:06:40 2008
@@ -1,0 +1,179 @@
+use strict;
+use warnings;
+
+package Sub::WrapPackages;
+
+use vars qw($VERSION);
+
+use Data::Dumper;
+
+$VERSION = '1.2';
+
+=head1 NAME
+
+Sub::WrapPackages - add pre- and post-execution wrappers around all the
+subroutines in packages or around individual subs
+
+=head1 SYNOPSIS
+
+ use Sub::WrapPackages (
+ packages => [qw(Foo Bar)], # wrap all Foo::* and Bar::*
+ subs => [qw(Baz::a, Baz::b)], # wrap these two subs as well
+ wrap_inherited => 1, # and wrap any methods
+ # inherited by Foo and Bar
+ pre => sub {
+ print "called $_[0] with params ".
+ join(', ', @_[1..$#_])."\n";
+ },
+ post => sub {
+ print "$_[0] returned $_[1]\n";
+ },
+
+=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:
+
+=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
+
+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.
+
+=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.
+
+=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.
+
+=head1 FEEDBACK
+
+I like to know who's using my code. All comments, including constructive
+criticism, are welcome. Please email me.
+
+=head1 AUTHOR and CREDITS
+
+David Cantrell E<lt>F<david at cantrell.org.uk>E<gt>
+
+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
+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.
+
+=head1 COPYRIGHT and LICENCE
+
+Copyright 2003 - 2006 David Cantrell
+
+This module is free-as-in-speech software, and may be used, distributed,
+and modified under the same terms as Perl itself.
+
+=cut
+
+use Hook::LexWrap;
+
+sub import {
+ my $i_am_weasel = shift;
+ wrapsubs(@_) if(@_);
+}
+
+sub subs_in_packages {
+ my @targets = map { $_.'::' } @_;
+
+ my @subs;
+ foreach my $package (@targets) {
+ no strict;
+ while(my($k, $v) = each(%{$package})) {
+ push @subs, $package.$k if(defined(&{$v}));
+ }
+ }
+ return @subs;
+}
+
+sub wrapsubs {
+ my %params = @_;
+
+ if(exists($params{packages}) && ref($params{packages}) =~ /^ARRAY/) {
+ if($params{wrap_inherited}) {
+ foreach my $package (@{$params{packages}}) {
+ # FIXME? does this work with 'use base'
+ my @parents = eval '@'.$package.'::ISA';
+
+ # get inherited (but not over-ridden!) subs
+ my %subs_in_package = map {
+ s/.*:://; ($_, 1);
+ } subs_in_packages($package);
+
+ my @subs_to_define = grep {
+ !exists($subs_in_package{$_})
+ } map {
+ s/.*:://; $_;
+ } subs_in_packages(@parents);
+
+ # define them in $package using SUPER
+ 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";
+ }
+ }
+ }
+ push @{$params{subs}}, subs_in_packages(@{$params{packages}});
+ } elsif(exists($params{packages})) {
+ die("Bad param 'packages'");
+ }
+
+ return undef if(!$params{pre} && !$params{post});
+
+ 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]) }) : ()
+ ));
+ }
+}
+
+1;
Added: branches/upstream/libsub-wrappackages-perl/current/t/00_wrap_as_subs.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/00_wrap_as_subs.t?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/00_wrap_as_subs.t (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/00_wrap_as_subs.t Fri Feb 29 20:06:40 2008
@@ -1,0 +1,36 @@
+#!/usr/bin/perl -w
+
+my $loaded;
+my $r;
+
+use strict;
+
+BEGIN { $| = 1; print "1..3\n"; }
+END { print "not ok 1\n" unless $loaded; }
+
+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];
+ }
+);
+
+$loaded=1;
+my $test = 0;
+print "ok ".(++$test)." compile and wrap subs\n";
+
+$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";
+
Added: branches/upstream/libsub-wrappackages-perl/current/t/01_wrap_as_packages.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/01_wrap_as_packages.t?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/01_wrap_as_packages.t (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/01_wrap_as_packages.t Fri Feb 29 20:06:40 2008
@@ -1,0 +1,32 @@
+#!/usr/bin/perl -w
+
+my $r;
+
+use strict;
+
+BEGIN { $| = 1; print "1..2\n"; }
+
+use lib 't/lib'; use a;
+use Sub::WrapPackages (
+ packages => [qw(a)],
+ pre => sub {
+ $r .= join(", ", @_);
+ },
+ post => sub {
+ $r .= ref($_[1]) =~ /^ARRAY/ ? join(', ', @{$_[1]}) : $_[1];
+ }
+);
+
+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";
+
Added: branches/upstream/libsub-wrappackages-perl/current/t/02_wrap_inherited.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/02_wrap_inherited.t?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/02_wrap_inherited.t (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/02_wrap_inherited.t Fri Feb 29 20:06:40 2008
@@ -1,0 +1,32 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 3;
+use Data::Dumper;
+
+my $r;
+
+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];
+ }
+);
+
+$r .= b->b_function();
+
+ok($r eq 'b::b_function, bi like piei like pie',
+ 'when wrapping inherited methods, normal methods are wrapped too');
+
+$r = '';
+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');
+
+$r = '';
+ at r = a->a_list(4,6,8);
+ok(join('', @r) eq 'insuba_list' && $r eq '', 'And calling the superclass method directly avoids wrapping shenanigans');
Added: branches/upstream/libsub-wrappackages-perl/current/t/03_wrap_inherited_in_same_file.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/03_wrap_inherited_in_same_file.t?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/03_wrap_inherited_in_same_file.t (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/03_wrap_inherited_in_same_file.t Fri Feb 29 20:06:40 2008
@@ -1,0 +1,18 @@
+#!perl
+
+use strict;
+use Test::More tests => 2;
+
+use lib 't/lib';
+use Banana;
+
+use Sub::WrapPackages (
+ packages => [qw(Banana)],
+ post => sub {
+ ok "Called $_[0]\n";
+ },
+ wrap_inherited => 1,
+);
+
+Banana->peel;
+Banana->eat;
Added: branches/upstream/libsub-wrappackages-perl/current/t/lib/Banana.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/lib/Banana.pm?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/lib/Banana.pm (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/lib/Banana.pm Fri Feb 29 20:06:40 2008
@@ -1,0 +1,8 @@
+package Fruit;
+sub eat { 'yum yum' }
+
+package Banana;
+use base 'Fruit';
+sub peel { 'ready to eat' }
+
+1;
Added: branches/upstream/libsub-wrappackages-perl/current/t/lib/a.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/lib/a.pm?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/lib/a.pm (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/lib/a.pm Fri Feb 29 20:06:40 2008
@@ -1,0 +1,5 @@
+package a;
+
+sub a_scalar { return 'in sub a_scalar'; }
+sub a_list { return qw(in sub a_list); }
+1;
Added: branches/upstream/libsub-wrappackages-perl/current/t/lib/b.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-wrappackages-perl/current/t/lib/b.pm?rev=15979&op=file
==============================================================================
--- branches/upstream/libsub-wrappackages-perl/current/t/lib/b.pm (added)
+++ branches/upstream/libsub-wrappackages-perl/current/t/lib/b.pm Fri Feb 29 20:06:40 2008
@@ -1,0 +1,9 @@
+package b;
+
+use lib 't/lib';
+
+use base qw(a);
+
+sub b_function { 'i like pie'; }
+
+1;
More information about the Pkg-perl-cvs-commits
mailing list