Need to gather a list of the subroutines that the current package itself declares - no imports.
I've seen Package::Stash, but it lists imported names (of course).
Came up with the following, but I don't like having to move the includes to the bottom of the file.
Anyone see how I can gather the same list, but still keep my includes near the top ?
package Foo;
use common::sense;
use Function::Parameters;
# Must import at least "fun" and "method" first for them to work.
# See bottom of file for rest of includes.
our %package_functions;
say join q{, }, sort keys %package_functions;
sub foo_1 { ; }
fun foo_2 () { ; }
method foo_3 () { ; }
BEGIN {
# This block must be kept *after* the sub declarations, and *before* imports.
no strict 'refs';
%package_functions = map { $_ => 1 } # Hash offers more convenient lookups when/if checked often.
grep { !/^(can|fun|method)$|^_/ } # Exclude certain names or name patterns.
grep { ref __PACKAGE__->can($_) eq 'CODE' } # Pick out only CODEREFs.
keys %{__PACKAGE__ . '::'}; # Any functions above should have their names here.
}
use JSON;
use Data::Dumper;
# use ...
1;
Outputs (with "perl" -E 'use Foo;') :
foo_1, foo_2, foo_3
If BEGIN is moved after the other includes, we see Dumper, encode_json, etc..
Deparse from core is perfectly able to do that, so you can do what B::Deparse.pm is doing, namely use the B module to peek into perl's innards:
# usage: for_subs 'package', sub { my ($sub_name, $pkg, $type, $cv) = #_; ... }
sub for_subs {
my ($pkg, $sub) = (#_, sub { printf "%-15s %-15s %-15s%.0s\n", #_ });
use B (); no strict 'refs';
my %stash = B::svref_2object(\%{$pkg.'::'})->ARRAY;
while(my($k, $v) = each %stash){
if($v->FLAGS & B::SVf_ROK){
my $cv = $v->RV;
if($cv->isa('B::CV')){
$sub->($k, $pkg, sub => $cv);
}elsif(!$cv->isa('B::SPECIAL') and $cv->FLAGS & B::SVs_PADTMP){
$sub->($k, $pkg, const => $cv);
}
}elsif($v->FLAGS & B::SVf_POK){
$sub->($k, $pkg, proto => $v->PV);
}elsif($v->FLAGS & B::SVf_IOK){
$sub->($k, $pkg, proto => '');
}elsif($v->isa('B::GV')){
my $cv = $v->CV;
next if $cv->isa('B::SPECIAL');
next if ${$cv->GV} != $$v;
$sub->($k, $pkg, sub => $cv);
}
}
}
Sample usage:
package P::Q { sub foo {}; sub bar; sub baz(){ 13 } }
for_subs 'P::Q';
sub foo {}; sub bar; sub baz(){ 13 }
for_subs __PACKAGE__;
should result in:
foo P::Q sub
bar P::Q proto
baz P::Q sub
baz main const
for_subs main sub
bar main proto
foo main sub
If the package you're interested in is not main, you don't care about empty prototypes (like the bar in the example above) and you need just a list of names, you can cut it to:
# usage: #subs = get_subs 'package'
sub get_subs {
my #subs;
use B (); no strict 'refs';
my %stash = B::svref_2object(\%{shift.'::'})->ARRAY;
while(my($k, $v) = each %stash){
next unless $v->isa('B::GV');
my $cv = $v->CV;
next if $cv->isa('B::SPECIAL');
next if ${$cv->GV} != $$v;
push #subs, $k;
}
#subs
}
My Devel::Examine::Subs can do this. Review the documentation for methods (and parameters to new()) that allow you to exclude subs that are retrieved.
package TestLib;
use strict;
use warnings;
use feature 'say';
use Data::Dumper;
use Devel::Examine::Subs;
use JSON;
my $des = Devel::Examine::Subs->new(file => __FILE__);
my $sub_names = $des->all;
say join ', ', #$sub_names;
sub one {}
sub two {}
sub three {}
Output:
perl -E 'use lib "."; use TestLib'
one, two, three
Related
So I want something like:
module0.pl
sub fun {
print "fun $_[0] from 0\n"
}
1
module1.pl
sub fun {
print "fun $_[0] from 1\n"
}
1
main.pl
BEGIN{push #INC, "."};
require "module0.pl";
require "module1.pl";
fun("test")
Which will print (in any order - I don't care) :
fun test from 0
fun test from 1
Is it possible - and what is the most elegant syntax to do it?
So you want to call a list of subs from various packages (here equally named) ?
One way, using normal packages
package Pack1;
use warnings;
use strict;
use feature 'say';
sub fun { say "fun $_[0] from ", __PACKAGE__ }
1;
The calling program, in the same directory with this package (and its counterpart Pack2)
use warnings;
use strict;
use feature 'say';
use FindBin qw($RealBin);
use lib $RealBin;
use Pack1;
use Pack2;
for my $packname (qw(Pack1 Pack2)) {
MAKENAME: {
no strict 'refs';
my $fun_name = $packname . '::' . 'fun';
$fun_name->("hi") if exists &{$fun_name};
}
}
I put that scoped no strict 'refs' in another block, and name the block, just so; if this is all that is done in the loop there is no need to introduce another scope.† We need the refs stricture off for using it as a subroutine reference but then it makes sense to scope the name itself as well.
A few notes
I don't know why those are .pl files which are require-ed; they should be packages and I wrote them that way. Let me know if there is actually a specific (and unbeatable) reason for them to be require-ed programs
Add directories to #INC using the lib pragma with $FindBin::RealBin, not by hacking #INC
† Or copy the coderef
for my $packname (qw(Pack1 Pack2)) {
my $fun = \&{ $packname . '::' . 'fun' };
$fun->('hi');
}
But if we do need to check for existence that should rather be
for my $packname (qw(Pack1 Pack2)) {
my $fun_name = $packname . '::' . 'fun';
next if not exists &{$fun_name};
my $fun = \&{$fun_name};
$fun->('hi');
}
A fairly robust way would be to use a registry for callbacks.
# main.pl
{
package MyApp;
my %callbacks;
sub register_callback {
my ( $class, $event, #callbacks ) = #_;
push #{ $callbacks{$event} ||= [] }, #callbacks;
return scalar #{ $callbacks{$event} || [] };
}
sub run_callbacks {
my ( $class, $event, #args ) = #_;
$_->( #args ) for #{ $callbacks{$event} || [] };
return;
}
}
BEGIN { push #INC, "." };
require 'module0.pl';
require 'module1.pl';
MyApp->run_callbacks(
fun => ( 'test' ),
);
MyApp->run_callbacks(
boredom => (),
);
# module0.pl
MyApp->register_callback( fun => sub {
print "fun $_[0] from 0\n"
} );
MyApp->register_callback( boredom => sub {
print "boredom from 0\n"
} );
# module1.pl
MyApp->register_callback( fun => sub {
print "fun $_[0] from 1\n"
} );
I'd like to be able to "inject" methods in a class on the fly, similarly to what happens with Mojolicious helpers. Something like this:
my $s = SomeThing->new;
$s->helper(do_this => sub {
my $self = shift;
$foo = shift;
});
$s->do_this('bar');
I've made it some distance, but I would like the subs that get injected to be operating in the namespace of the class they get injected into, not in the main one. In other words this currently works as follows:
$s->do_this('bar');
print 'in main: ', $foo;
this prints "bar" - and I'd like it not to, while I'd like this
print 'in SomeThing: ', $SomeThing::foo;
to print "bar" instead
while this works but seems clunky to me
$s->helper(do_this => sub {
my $self = shift;
${(ref $self) . '::foo'} = shift;
});
$s->do_this('foo');
print 'in SomeThing: ', $SomeThing::foo; # now this prints "foo"
The package where all this happens looks like this:
package SomeThing {
use Mojo::Base -base;
use Carp;
sub helper {
my $self = shift;
my $name = shift || croak "The helper name is required";
my $sub = shift || sub {};
my $namespace = __PACKAGE__;
no strict 'refs';
{
*{"$namespace\::$name"} = $sub
}
}
};
Is there a way to do this? I suspect I'd be messing up strictness real bad - but I kind of don't want to give up just yet (and it'd be a nice trick to learn).
You are asking to change the package associated with an already-compiled anon sub for the purpose of variable lookups. I don't know if that's possible.
Even if it was possible, it's not something you want to do because your code still wouldn't work. You'd have to add use vars qw( foo ); to the file in which the sub { } literal is found. And that's in addition to using our $foo; or use vars qw( $foo ); in Something.pm if you accessed it there.
That's pretty magical and messy. And it's easily avoided by using accessors. Simple replace
$s->helper(
do_this => sub {
my $self = shift;
$foo = shift;
},
);
with
$s->helper(
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
If you also need to add the accessor, you can use the following:
$s->helper(
foo => sub {
shift;
state $foo;
$foo = shift if #_;
$foo
},
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
As an aside, monkey_patch from Mojo::Util can be used as a replacement for helper. (Credit to #brian d foy for bringing it up.) It does the same thing, but it has the two added benefits:
You don't need to support it.
It sets the name of the anon sub so that stack traces use a meaningful name instead of __ANON__.
Switching to monkey_patch doesn't address your problem, but I do recommend using it (or similar) in addition to the change of approach I mentioned above.
use Mojo::Util qw( );
sub helper { shift; Mojo::Util::monkey_patch(__PACKAGE__, #_); }
Consider roles.
# role module
package SomeThing::Role::Foo;
use Role::Tiny;
sub foo { 42 }
1;
# user
use strict;
use warnings;
use SomeThing;
use With::Roles;
my $something_with_foo = SomeThing->with::roles('+Foo');
# new subclass of SomeThing, doesn't affect other usage of SomeThing
my $obj = $something_with_foo->new;
# can also dynamically apply to an existing object
my $obj = SomeThing->new->with::roles('+Foo');
print $obj->foo;
Let's take something very simple,
# Foo.pm
package Foo {
my $baz = bar();
sub bar { 42 }; ## Overwrite this
print $baz; ## Before this is executed
}
Is there anyway that I can from test.pl run code that changes what $baz is set to and causes Foo.pm to print something else to the screen?
# maybe something here.
use Foo;
# maybe something here
Is it possible with the compiler phases to force the above to print 7?
A hack is required because require (and thus use) both compiles and executes the module before returning.
Same goes for eval. eval can't be used to compile code without also executing it.
The least intrusive solution I've found would be to override DB::postponed. This is called before evaluating a compiled required file. Unfortunately, it's only called when debugging (perl -d).
Another solution would be to read the file, modify it and evaluate the modified file, kinda like the following does:
use File::Slurper qw( read_binary );
eval(read_binary("Foo.pm") . <<'__EOS__') or die $#;
package Foo {
no warnings qw( redefine );
sub bar { 7 }
}
__EOS__
The above doesn't properly set %INC, it messes up the file name used by warnings and such, it doesn't call DB::postponed, etc. The following is a more robust solution:
use IO::Unread qw( unread );
use Path::Class qw( dir );
BEGIN {
my $preamble = '
UNITCHECK {
no warnings qw( redefine );
*Foo::bar = sub { 7 };
}
';
my #libs = #INC;
unshift #INC, sub {
my (undef, $fn) = #_;
return undef if $_[1] ne 'Foo.pm';
for my $qfn (map dir($_)->file($fn), #libs) {
open(my $fh, '<', $qfn)
or do {
next if $!{ENOENT};
die $!;
};
unread $fh, "$preamble\n#line 1 $qfn\n";
return $fh;
}
return undef;
};
}
use Foo;
I used UNITCHECK (which is called after compilation but before execution) because I prepended the override (using unread) rather than reading in the whole file in and appending the new definition. If you want to use that approach, you can get a file handle to return using
open(my $fh_for_perl, '<', \$modified_code);
return $fh_for_perl;
Kudos to #Grinnz for mentioning #INC hooks.
Since the only options here are going to be deeply hacky, what we really want here is to run code after the subroutine has been added to the %Foo:: stash:
use strict;
use warnings;
# bless a coderef and run it on destruction
package RunOnDestruct {
sub new { my $class = shift; bless shift, $class }
sub DESTROY { my $self = shift; $self->() }
}
use Variable::Magic 0.58 qw(wizard cast dispell);
use Scalar::Util 'weaken';
BEGIN {
my $wiz;
$wiz = wizard(store => sub {
return undef unless $_[2] eq 'bar';
dispell %Foo::, $wiz; # avoid infinite recursion
# Variable::Magic will destroy returned object *after* the store
return RunOnDestruct->new(sub { no warnings 'redefine'; *Foo::bar = sub { 7 } });
});
cast %Foo::, $wiz;
weaken $wiz; # avoid memory leak from self-reference
}
use lib::relative '.';
use Foo;
This will emit some warnings, but prints 7:
sub Foo::bar {}
BEGIN {
$SIG{__WARN__} = sub {
*Foo::bar = sub { 7 };
};
}
First, we define Foo::bar. It's value will be redefined by the declaration in Foo.pm, but the "Subroutine Foo::bar redefined" warning will be triggered, which will call the signal handler that redefines the subroutine again to return 7.
Here is a solution that combines hooking the module loading process with the readonly-making capabilities of the Readonly module:
$ cat Foo.pm
package Foo {
my $baz = bar();
sub bar { 42 }; ## Overwrite this
print $baz; ## Before this is executed
}
$ cat test.pl
#!/usr/bin/perl
use strict;
use warnings;
use lib qw(.);
use Path::Tiny;
use Readonly;
BEGIN {
my #remap = (
'$Foo::{bar} => \&mybar'
);
my $pre = join ' ', map "Readonly::Scalar $_;", #remap;
my #inc = #INC;
unshift #INC, sub {
return undef if $_[1] ne 'Foo.pm';
my ($pm) = grep { $_->is_file && -r } map { path $_, $_[1] } #inc
or return undef;
open my $fh, '<', \($pre. "#line 1 $pm\n". $pm->slurp_raw);
return $fh;
};
}
sub mybar { 5 }
use Foo;
$ ./test.pl
5
I have revised my solution here, so that it no longer relies on Readonly.pm, after learning that I had missed a very simple alternative, based on m-conrad's answer, which I have reworked into the modular approach that I had started here.
Foo.pm (Same as in the opening post)
package Foo {
my $baz = bar();
sub bar { 42 }; ## Overwrite this
print $baz; ## Before this is executed
}
# Note, even though print normally returns true, a final line of 1; is recommended.
OverrideSubs.pm Updated
package OverrideSubs;
use strict;
use warnings;
use Path::Tiny;
use List::Util qw(first);
sub import {
my (undef, %overrides) = #_;
my $default_pkg = caller; # Default namespace when unspecified.
my %remap;
for my $what (keys %overrides) {
( my $with = $overrides{$what} ) =~ s/^([^:]+)$/${default_pkg}::$1/;
my $what_pkg = $what =~ /^(.*)\:\:/ ? $1 : $default_pkg;
my $what_file = ( join '/', split /\:\:/, $what_pkg ). '.pm';
push #{ $remap{$what_file} }, "*$what = *$with";
}
my #inc = grep !ref, #INC; # Filter out any existing hooks; strings only.
unshift #INC, sub {
my $remap = $remap{ $_[1] } or return undef;
my $pre = join ';', #$remap;
my $pm = first { $_->is_file && -r } map { path $_, $_[1] } #inc
or return undef;
# Prepend code to override subroutine(s) and reset line numbering.
open my $fh, '<', \( $pre. ";\n#line 1 $pm\n". $pm->slurp_raw );
return $fh;
};
}
1;
test-run.pl
#!/usr/bin/env perl
use strict;
use warnings;
use lib qw(.); # Needed for newer Perls that typically exclude . from #INC by default.
use OverrideSubs
'Foo::bar' => 'mybar';
sub mybar { 5 } # This can appear before or after 'use OverrideSubs',
# but must appear before 'use Foo'.
use Foo;
Run and output:
$ ./test-run.pl
5
If the sub bar inside Foo.pm has a different prototype than an existing Foo::bar function, Perl won't overwrite it? That seems to be the case, and makes the solution pretty simple:
# test.pl
BEGIN { *Foo::bar = sub () { 7 } }
use Foo;
or kind of the same thing
# test.pl
package Foo { use constant bar => 7 };
use Foo;
Update: no, the reason this works is that Perl won't redefine a "constant" subroutine (with prototype ()), so this is only a viable solution if your mock function is constant.
Lets have a Golf contest!
sub _override { 7 }
BEGIN {
my ($pm)= grep -f, map "$_/Foo.pm", #INC or die "Foo.pm not found";
open my $fh, "<", $pm or die;
local $/= undef;
eval "*Foo::bar= *main::_override;\n#line 1 $pm\n".<$fh> or die $#;
$INC{'Foo.pm'}= $pm;
}
use Foo;
This just prefixes the module's code with a replacement of the method, which will be the first line of code that runs after the compilation phase and before the execution phase.
Then, fill in the %INC entry so that future loads of use Foo don't pull in the original.
I want to call a main controller function that dispatches other function dynamically, something like this:
package Controller;
my %callback_funcs = ();
sub register_callback{
my ($class,$callback,$options) = _#;
#apppend to %callback_funcs hash ... ?
}
sub main{
%callback_funcs = ( add => 'add_func', rem => 'remove_func', edit => 'edit_func');
while(<STDIN>){
last if ($_ =~ /^\s*$/);
if($_ == 'add' || _$ == 'rem' || _$ == 'edit'){
$result = ${callback_funcs['add']['func']}(callback_funcs['add']['options']);
}
}
}
sub add_func{
...
}
One caveat is that the subs are defined in other Modules, so the callbacks would have to be able to reference them... plus
I'm having a hard time getting the hashes right!
So, it's possible to have a hash that contains anonymous subroutines that you can invoke from stdin.
my %callbacks = (
add => sub {
# do stuff
},
fuzzerbligh => sub {
# other stuff
},
);
And you can insert more hashvalues into the hash:
$callbacks{next} = sub {
...
};
And you would invoke one like this
$callbacks{next}->(#args);
Or
my $coderef = $callbacks{next};
$coderef->(#args);
You can get the hashkey from STDIN, or anywhere else.
You can also define them nonymously and then take a reference to them.
sub delete {
# regular sub definition
}
$callbacks{delete} = \&delete;
I wouldn't call these callbacks, however. Callbacks are subs that get called after another subroutine has returned.
Your code is also rife with syntax errors which may be obscuring the deeper issues here. It's also not clear to me what you're trying to do with the second level of arrays. When are you defining these subs, and who is using them when, and for what?
Perhaps this simplified example will help:
# Very important.
use strict;
use warnings;
# Define some functions.
sub multiply { $_[0] * $_[1] }
sub divide { $_[0] / $_[1] }
sub add { $_[0] + $_[1] }
sub subtract { $_[0] - $_[1] }
# Create a hash of references to those functions (dispatch table).
my %funcs = (
multiply => \&multiply,
divide => \÷,
add => \&add,
subtract => \&subtract,
);
# Register some more functions.
sub register {
my ($key, $func) = #_;
$funcs{$key} = $func;
}
register('+', \&add); # As above.
register('sum', sub { # Or using an anonymous subroutine.
my $s = 0;
$s += $_ for #_;
return $s;
});
# Invoke them dynamically.
while (<>){
my ($op, #args) = split;
last unless $op and exists $funcs{$op}; # No need for equality tests.
print $funcs{$op}->(#args), "\n";
}
You've already got some good answers on how to build a dispatch table and call functions through it within a single file, but you also keep talking about wanting the functions to be defined in other modules. If that's the case, then wouldn't it be better to build the dispatch table dynamically based on what dispatchable functions each module says it has rather than having to worry about keeping it up to date manually? Of course it would!
Demonstrating this requires multiple files, of course, and I'm using Module::Pluggable from CPAN to find the modules which provide the function definitions.
dispatch_core.pl:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
use lib '.'; # a demo is easier if I can put modules in the same directory
use Module::Pluggable require => 1, search_path => 'DTable';
for my $plugin (plugins) {
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}
DTable/Add.pm:
package DTable::Add;
use strict;
use warnings;
sub dispatchable {
return (add => \&add);
}
sub add {
my ($num1, $num2) = #_;
print "$num1 + $num2 = ", $num1 + $num2, "\n";
}
1;
DTable/MultDiv.pm:
package DTable::MultDiv;
use strict;
use warnings;
sub dispatchable {
return (multiply => \&multiply, divide => \÷);
}
sub multiply {
my ($num1, $num2) = #_;
print "$num1 * $num2 = ", $num1 * $num2, "\n";
}
sub divide {
my ($num1, $num2) = #_;
print "$num1 / $num2 = ", $num1 / $num2, "\n";
}
1;
Then, on the command line:
$ ./dispatch_core.pl
add:
2 + 5 = 7
divide:
2 / 5 = 0.4
multiply:
2 * 5 = 10
Adding new functions is now as simple as dropping a new file into the DTable directory with an appropriate dispatchable sub. No need to ever touch dispatch_core.pl just to add a new function again.
Edit: In response to the comment's question about whether this can be done without Module::Pluggable, here's a modified dispatch_core.pl which doesn't use any external modules other than the ones defining the dispatchable functions:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
my #dtable = qw(
DTable::Add
DTable::MultDiv
);
use lib '.';
for my $plugin (#dtable) {
eval "use $plugin";
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}
I am writing a module and I want a specific piece of code to be executed before each of the functions in it.
How do I do that?
Is there no other way than to just have a function-call at the beginning of every function?
You can do this in Moose with method modifiers:
package Example;
use Moose;
sub foo {
print "foo\n";
}
before 'foo' => sub { print "about to call foo\n"; };
Wrapping a method is also possible with method attributes, but this route is not well-used in Perl and is still evolving, so I wouldn't recommend it. For normal use-cases, I would simply put the common code in another method and call it at the top of each of your functions:
Package MyApp::Foo;
sub do_common_stuff { ... }
sub method_one
{
my ($this, #args) = #_;
$this->do_common_stuff();
# ...
}
sub method_two
{
my ($this, #args) = #_;
$this->do_common_stuff();
# ...
}
And, in case someone is wondering how to achieve the effect of Hook* modules or Moose's "before" explicitly (e.g. what actual Perl mechanism can be used to do it), here's an example:
use strict;
package foo;
sub call_before { print "BEFORE\n"; } # This will be called before any sub
my $call_after = sub { print "AFTER - $_[0]\n"; };
sub fooBar { print "fooBar body\n\n"; }
sub fooBaz { print "fooBaz body\n\n"; }
no strict; # Wonder if we can get away without 'no strict'? Hate doing that!
foreach my $glob (keys %foo::) { # Iterate over symbol table of the package
next if not defined *{$foo::{$glob}}{CODE}; # Only subroutines needed
next if $glob eq "call_before" || $glob eq "import" || $glob =~ /^___OLD_/;
*{"foo::___OLD_$glob"} = \&{"foo::$glob"}; # Save original sub reference
*{"foo::$glob"} = sub {
call_before(#_); &{"foo::___OLD_$glob"}(#_); &$call_after(#_);
};
}
use strict;
1;
package main;
foo::fooBar();
foo::fooBaz();
The explanation for what we're excluding via "next" line:
"call_before" is of course the name I gave to our "before" example sub - only need this if it is actually defined as a real sub in the same package and not anonymously or code ref from outside the package.
import() has a special meaning and purpose and should generally be excluded from "run this before every sub" scenario. YMMV.
___OLD_ is a prefix we will give to "renamed" old subs - you don't need to include it here unless you're worried about this loop being execute twice. Better safe than sorry.
UPDATE: Below section about generalization is no longer relevant - at the end of the answer I pasted a general "before_after" package doing just that!!!
The loop above can obviously be easily generalized to be a separately-packaged subroutine which accepts, as arguments:
an arbitrary package
a code ref to arbitrary "before" subroutine (or as you can see, after)
and a list of sub names to exclude (or sub ref that checks if a name is to be excluded) aside from standard ones like "import").
... and/or a list of sub names to include (or sub ref that checks if a name is to be included) aside from standard ones like "import"). Mine just takes ALL subs in a package.
NOTE: I don't know whether Moose's "before" does it just this way. What I do know is that I'd obviously recommend going with a standard CPAN module than my own just-written snippet, unless:
Moose or any of the Hook modules can't be installed and/or are too heavy weight for you
You're good enough with Perl that you can read the code above and analyze it for flaws.
You like this code very much, AND the risk of using it over CPAN stuff is low IYHO :)
I supplied it more for informational "this is how the underlying work is done" purposes rather than practical "use this in your codebase" purposes, though feel free to use it if you wish :)
UPDATE
Here's a more generic version as mentioned before:
#######################################################################
package before_after;
# Generic inserter of before/after wrapper code to all subs in any package.
# See below package "foo" for example of how to use.
my $default_prefix = "___OLD_";
my %used_prefixes = (); # To prevent multiple calls from stepping on each other
sub insert_before_after {
my ($package, $prefix, $before_code, $after_code
, $before_filter, $after_filter) = #_;
# filters are subs taking 2 args - subroutine name and package name.
# How the heck do I get the caller package without import() for a defalut?
$prefix ||= $default_prefix; # Also, default $before/after to sub {} ?
while ($used_prefixes{$prefix}) { $prefix = "_$prefix"; }; # Uniqueness
no strict;
foreach my $glob (keys %{$package . "::"}) {
next if not defined *{$package. "::$glob"}{CODE};
next if $glob =~ /import|__ANON__|BEGIN/; # Any otrher standard subs?
next if $glob =~ /^$prefix/; # Already done.
$before = (ref($before_filter) ne "CODE"
|| &$before_filter($glob, $package));
$after = (ref($after_filter) ne "CODE"
|| &$after_filter($glob, $package));
*{$package."::$prefix$glob"} = \&{$package . "::$glob"};
if ($before && $after) { # We do these ifs for performance gain only.
# Else, could wrap before/after calls in "if"
*{$package."::$glob"} = sub {
my $retval;
&$before_code(#_); # We don't save returns from before/after.
if (wantarray) {
$retval = [ &{$package . "::$prefix$glob"}(#_) ];
} else {
$retval = &{$package . "::$prefix$glob"}(#_);
}
&$after_code(#_);
return (wantarray && ref $retval eq 'ARRAY')
? #$retval : $retval;
};
} elsif ($before && !$after) {
*{$package . "::$glob"} = sub {
&$before_code(#_);
&{$package . "::$prefix$glob"}(#_);
};
} elsif (!$before && $after) {
*{$package . "::$glob"} = sub {
my $retval;
if (wantarray) {
$retval = [ &{$package . "::$prefix$glob"}(#_) ];
} else {
$retval = &{$package . "::$prefix$glob"}(#_);
}
&$after_code(#_);
return (wantarray && ref $retval eq 'ARRAY')
? #$retval : $retval;
};
}
}
use strict;
}
# May be add import() that calls insert_before_after()?
# The caller will just need "use before_after qq(args)".
1;
#######################################################################
package foo;
use strict;
sub call_before { print "BEFORE - $_[0]\n"; };
my $call_after = sub { print "AFTER - $_[0]\n"; };
sub fooBar { print "fooBar body - $_[0]\n\n"; };
sub fooBaz { print "fooBaz body - $_[0]\n\n"; };
sub fooBazNoB { print "fooBazNoB body - $_[0]\n\n"; };
sub fooBazNoA { print "fooBazNoA body - $_[0]\n\n"; };
sub fooBazNoBNoA { print "fooBazNoBNoA body - $_[0]\n\n"; };
before_after::insert_before_after(__PACKAGE__, undef
, \&call_before, $call_after
, sub { return 0 if $_[0] eq "call_before"; $_[0] !~ /NoB(NoA)?$/ }
, sub { return 0 if $_[0] eq "call_before"; $_[0] !~ /NoA$/ } );
1;
#######################################################################
package main;
use strict;
foo::fooBar("ARG1");
foo::fooBaz("ARG2");
foo::fooBazNoB("ARG3");
foo::fooBazNoA("ARG4");
foo::fooBazNoBNoA("ARG5");
#######################################################################
If you search CPAN for 'hook', and then branch out from there, you'll find several options, such as:
Hook::WrapSub
Hook::PrePostCall
Hook::LexWrap
Sub::Prepend
Here's an example using Hook::LexWrap. I don't have experience with this module except for debugging. It worked fine for that purpose.
# In Frob.pm
package Frob;
sub new { bless {}, shift }
sub foo { print "foo()\n" }
sub bar { print "bar()\n" }
sub pre { print "pre()\n" }
use Hook::LexWrap qw(wrap);
my #wrappable_methods = qw(foo bar);
sub wrap_em {
wrap($_, pre => \&pre) for #wrappable_methods;
}
# In script.pl
use Frob;
my $frob = Frob->new;
print "\nOrig:\n";
$frob->foo;
$frob->bar;
print "\nWrapped:\n";
Frob->wrap_em();
$frob->foo;
$frob->bar;
See the Aspect package on CPAN for aspect-oriented computing.
before { Class->method; } qr/^Package::\w+$/;