1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
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@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;
|
