In Perl, can I call a method before executing every function in a package?

Question

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?

Answer 1

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();
    # ...
}

Answer 2

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;

Answer 3

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:

1. Moose or any of the Hook modules can't be installed and/or are too heavy weight for you

2. You're good enough with Perl that you can read the code above and analyze it for flaws.

3. 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");
#######################################################################

Answer 4

See the Aspect.pm package on CPAN for aspect-oriented computing.

before { Class->method; } qr/^Package::\w+$/;