How can I code in a functional style in Perl? - perl

How do you either:
have a sub return a sub
or
execute text as code
in Perl?
Also, how do I have an anonymous function store state?

A sub returns a sub as a coderef:
# example 1: return a sub that is defined inline.
sub foo
{
return sub {
my $this = shift;
my #other_params = #_;
do_stuff();
return $some_value;
};
}
# example 2: return a sub that is defined elsewhere.
sub bar
{
return \&foo;
}
Arbitrary text can be executed with the eval function: see the documentation at perldoc -f eval:
eval q{print "hello world!\n"};
Note that this is very dangerous if you are evaluating anything extracted from user input, and is generally a poor practice anyway as you can generally define your code in a coderef as in the earlier examples above.
You can store state with a state variable (new in perl5.10), or with a variable scoped higher than the sub itself, as a closure:
use feature 'state';
sub baz
{
state $x;
return ++$x;
}
# create a new scope so that $y is not visible to other functions in this package
{
my $y;
sub quux
{
return ++$y;
}
}

Return a subroutine reference.
Here's a simple example that creates sub refs closed over a value:
my $add_5_to = add_x_to(5);
print $add_5_to->(7), "\n";
sub add_x_to {
my $x = shift;
return sub { my $value = shift; return $x + $value; };
}
You can also work with named subs like this:
sub op {
my $name = shift;
return $op eq 'add' ? \&add : sub {};
}
sub add {
my $l = shift;
my $r = shift;
return $l + $r;
}
You can use eval with an arbitrary string, but don't do it. The code is hard to read and it restarts compilation, which slows everything down. There are a small number of cases where string eval is the best tool for the job. Any time string eval seems like a good idea, you are almost certainly better off with another approach.
Almost anything you would like to do with string eval can be achieved with closures.

Returning subs is easy by using the sub keyword. The returned sub closes over the lexical variables it uses:
#!/usr/bin/perl
use strict; use warnings;
sub mk_count_from_to {
my ($from, $to) = #_;
return sub {
return if $from > $to;
return $from ++;
};
}
my $c = mk_count_from_to(-5, 5);
while ( defined( my $n = $c->() ) ) {
print "$n\n";
}
5.10 introduced state variables.
Executing text as Perl is accomplished using eval EXPR:
the return value of EXPR is parsed and executed as if it were a little Perl program. The value of the expression (which is itself determined within scalar context) is first parsed, and if there weren't any errors, executed in the lexical context of the current Perl program, so that any variable settings or subroutine and format definitions remain afterwards. Note that the value is parsed every time the eval executes
Executing arbitrary strings will open up huge gaping security holes.

You can create anonymous subroutines and access them via a reference; this reference can of course be assigned to a scalar:
my $subref = sub { ... code ... }
or returned from another subroutine
return sub { ... code ... }
If you need to store states, you can create closures with lexical variables defined in an outer scope like:
sub create_func {
my $state;
return sub { ... code that can refer to $state ... }
}
You can run code with eval

Related

Is there a convenience for safe dereferencing in Perl?

So perl5porters is discussing to add a safe dereferencing operator, to allow stuff like
$ceo_car_color = $company->ceo->car->color
if defined $company
and defined $company->ceo
and defined $company->ceo->car;
to be shortened to e.g.
$ceo_car_color = $company->>ceo->>car->>color;
where $foo->>bar means defined $foo ? $foo->bar : undef.
The question: Is there some module or unobstrusive hack that gets me this operator, or similar behavior with a visually pleasing syntax?
For your enjoyment, I'll list ideas that I was able to come up with.
A multiple derefencing method (looks ugly).
sub multicall {
my $instance = shift // return undef;
for my $method (#_) {
$instance = $instance->$method() // return undef;
}
return $instance;
}
$ceo_car_color = multicall($company, qw(ceo car color));
A wrapper that turns undef into a proxy object (looks even uglier) which returns undef from all function calls.
{ package Safe; sub AUTOLOAD { return undef } }
sub safe { (shift) // bless {}, 'Safe' }
$ceo_car_color = safe(safe(safe($company)->ceo)->car)->color;
Since I have access to the implementations of ceo(), car() and color(), I thought about returning the safe proxy directly from these methods, but then existing code might break:
my $ceo = $company->ceo;
my $car = $ceo->car if defined $ceo; # defined() breaks
Unfortunately, I don't see anything in perldoc overload about overloading the meaning of defined and // in my safe proxy.
Maybe this is not the most useful solution, but it's one more WTDI (a variant of nr. 1) and it's a non-trivial use-case for List::Util's reduce, which are very rare. ;)
Code
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use List::Util 'reduce';
my $answer = 42;
sub new { bless \$answer }
sub foo { return shift } # just chaining
sub bar { return undef } # break the chain
sub baz { return ${shift()} } # return the answer
sub multicall { reduce { our ($a, $b); $a and $a = $a->$b } #_ }
my $obj = main->new();
say $obj->multicall(qw(foo foo baz)) // 'undef!';
say $obj->multicall(qw(foo bar baz)) // 'undef!';
Output
42
undef!
Note:
Of course it should be
return unless defined $a;
$a = $a->$b;
instead of the shorter $a and $a = $a->$b from above to work correctly with defined but false values, but my point here is to use reduce.
You can use eval:
$ceo_car_color = eval { $company->ceo->car->color };
But it will of course catch any errors, not just calling a method on an undef.

Perl: Syntactical Sugar for Latter Coderef Arguments?

Using sub prototypes, we can define our own subs that look like map or grep. That is, the first coderef argument has shorter syntax than a normal anonymous sub. For example:
sub thunked (&) { $_[0] }
my $val = thunked { 2 * 4 };
Works great here, since the first argument is the coderef. For latter arguments however, it simple won't parse properly.
I made a with sub designed to make writing GTK2 code cleaner. It's meant to look like this (untested since it's hypothetical code):
use 5.012;
use warnings;
use Gtk2 '-init';
sub with ($&) {
local $_ = $_[0];
$_[1]->();
$_;
}
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(with Gtk2::VBox->new {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
Gtk2->main;
It doesn't work because with needs to take the block as a first argument for the nice syntax to work. Is there any way to pull it off?
The module Devel::Declare contains tools for extending Perl's syntax in a relatively safe way.
Using Devel::Declare you would create a hook on the with token, which will stop the parser when it reaches that word. From there, you have control over the parser and you can read ahead until you reach a { symbol. At that point, you have what you need to work with, so you rewrite it into valid Perl, and pass it back to the parser.
in the file With.pm:
package With;
use warnings;
use strict;
use Devel::Declare;
sub import {
my $caller = caller;
Devel::Declare->setup_for (
$caller => {with => {const => \&parser}}
);
no strict 'refs';
*{$caller.'::with'} = sub ($&) {
$_[1]() for $_[0];
$_[0]
}
}
our $prefix = '';
sub get {substr Devel::Declare::get_linestr, length $prefix}
sub set { Devel::Declare::set_linestr $prefix . $_[0]}
sub parser {
local $prefix = substr get, 0, length($_[0]) + $_[1];
my $with = strip_with();
strip_space();
set "scalar($with), sub " . get;
}
sub strip_space {
my $skip = Devel::Declare::toke_skipspace length $prefix;
set substr get, $skip;
}
sub strip_with {
strip_space;
my $with;
until (get =~ /^\{/) {
(my $line = get) =~ s/^([^{]+)//;
$with .= $1;
set $line;
strip_space;
}
$with =~ s/\s+/ /g;
$with
}
and to use it:
use With;
sub Window::add {say "window add: ", $_[1]->str}
sub Window::new {bless [] => 'Window'}
sub Box::new {bless [] => 'Box'}
sub Box::add {push #{$_[0]}, #_[1..$#_]}
sub Box::str {"Box(#{$_[0]})"}
sub Button::new {"Button($_[1])"}
with Window->new {
$_->add(with Box->new {
for my $num (1 .. 4) {
$_->add(Button->new($num))
}
})
};
Which prints:
window add: Box(Button(1) Button(2) Button(3) Button(4))
A completely different approach would be to skip the with keyword altogether and write a routine to generate constructor subroutines:
BEGIN {
for my $name (qw(VBox)) { # and any others you want
no strict 'refs';
*$name = sub (&#) {
use strict;
my $code = shift;
my $with = "Gtk2::$name"->new(#_);
$code->() for $with;
$with
}
}
}
and then your code could look like
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(VBox {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
One way that you could deal with it is to add a fairly useless keyword:
sub perform(&) { $_[0] }
with GTK2::VBox->new, perform { ... }
where perform is really just a sugarier alternative to sub.
Another way is to write a Devel::Declare filter or a Syntax::Keyword:: plugin to implement your with, as long as you have some way to tell when you're done parsing the with argument and ready to start parsing the block — balanced parentheses would do (so would an opening curly brace, but then hashes become a problem). Then you could support something like
with (GTK2::VBox->new) { ... }
and let the filter rewrite it to something like
do {
local $_ = GTK2::VBox->new;
do {
...;
};
$_;
}
which, if it works, has the advantage of not actually creating a sub, and thus not interfering with #_, return, and a few other things. The two layers of do-age I think are necessary for being able to install an EndOfScope hook in the proper place.
The obvious disadvantages of this are that it's tricky, it's hairy, and it's a source filter (even if it's a tame one) which means there are problems you have to solve if you want any code using it to be debuggable at all.

When should I use subroutine attributes?

I don't grok Perl subroutine attributes at all.
I have never seen them in actual code and perldoc perlsub and the perldoc attributes fail to answer my questions:
What are attributes useful for?
What do they bring to the table that is not already present in Perl best practices?
Are there any CPAN modules (well-known or otherwise) that make use of attributes?
It would be great if someone could put together a detailed example of attributes being used the way they should be.
For those who are as clueless as me, attributes are the parameters after the colon in the attributes SYNOPSIS examples below:
sub foo : method ;
my ($x,#y,%z) : Bent = 1;
my $s = sub : method { ... };
use attributes (); # optional, to get subroutine declarations
my #attrlist = attributes::get(\&foo);
use attributes 'get'; # import the attributes::get subroutine
my #attrlist = get \&foo;
Attributes allow you annotate variables to perform auto-magic behind the scenes. A similar concept is java annotations. Here is a small example that might help. It uses Attribute::Handlers to create the loud attributes.
use Attribute::Handlers;
sub UNIVERSAL::loud : ATTR(CODE) {
my ( $pkg, $sym, $code ) = #_;
no warnings 'redefine';
*{$sym} = sub {
return uc $code->(#_);
};
}
sub foo : loud {
return "this is $_[0]";
}
say foo("a spoon");
say foo("a fork");
Whenever a sub is declared with the loud attribute the UNIVERSAL::loud callback triggers exposing meta-information on the sub. I redefined the function to actually call an anonymous sub, which in turn calls the original sub and passes it to uc
This outputs:
THIS IS A SPOON
THIS IS A FORK
Now let's looks a the variable example from the SYNOPSIS:
my ($x,#y,%z) : Bent = 1;
Breaking this down into small perl statement without taking into account attributes we have
my $x : Bent
$x = 1;
my #y : Bent
#y = 1;
my %Z : Bent
%z = 1;
We can now see that each variable has been attributed the Bent annotation in a concise way, while also assigning all variables the value 1. Here is a perhaps more interesting example:
use Attribute::Handlers;
use Tie::Toggle;
sub UNIVERSAL::Toggle : ATTR(SCALAR) {
my ($package, $symbol, $referent, $attr, $data, $phase) = #_;
my #data = ref $data eq 'ARRAY' ? #$data : $data;
tie $$referent, 'Tie::Toggle', #data;
}
my $x : Toggle;
say "x is ", $x;
say "x is ", $x;
say "x is ", $x;
Which outputs:
x is
x is 1
x is
You can use this to do logging, create test annotations, add type details to variables, syntactic sugar, do moose-ish role composition and many other cool things.
Also see this question: How do Perl method attributes work?.
What are attributes useful for?
It is a way to pass some additional information (the attribute)
about a variable or subroutine.
You can catch this information (the attribute) as a string ( at COMPILE TIME !)
and handle it however you like. You can generate additional code,
modify stashs ... . It is up to you.
What do they bring to the table that is not already present in Perl best practices?
Sometimes it makes life easier. See example below.
Some people use it. Do a : find . -name *.p[ml] | xargs grep 'use attributes;'
at your perl installation path to look at packages using attributes.
Catalyst extensively uses attributes to handle requests based on the given path.
Example :
Say you like to execute subroutines in a certain order. And you want to tell the
subroutine when it has to execute ( by a run number RUNNR ). Using attributes
the implementation could be :
#!/usr/bin/env perl
use strict;
use warnings;
use Runner; # immplements the attribute handling
# some subroutines to be scheduled :
# attibutes automatically filling #$Runner::schedule
sub func_a : RUNNR(2) {return "You called func_a !"};
sub func_b : RUNNR(1) {return "You called func_b !"};
sub func_c : RUNNR(3) {return "You called func_c !"};
# run the subroutines according to the their RUNNR
sub run {
# #$Runner::schedule holds the subroutine refs according
# to their RUNNR
foreach my $func (#$Runner::schedule) {
if ( defined $func ) {
print "Running : $func --> ", $func->(), "\n";
}
}
}
print "Starting ...\n\n";
run();
print "\nDone !\n";
The attribute handling is in package Runner using the MODIFY_CODE_ATTRIBUTES
hook.
package Runner;
use strict;
use warnings;
use attributes;
BEGIN {
use Exporter ();
our (#ISA, #EXPORT);
#ISA = qw(Exporter);
#EXPORT = qw(&MODIFY_CODE_ATTRIBUTES); # needed for use attributes;
}
# we have subroutines with attributes : <type> is CODE in MODIFY_<type>_ATTRIBUTES
# MODIFY_CODE_ATTRIBUTES is executed at COMPILE TIME ! try perl -c <prog_name> to prove it :-)
sub MODIFY_CODE_ATTRIBUTES {
# for each subroutine of a package we get
# the code ref to it and the attribute(s) as string
my ($pckg, $code_ref, #attr) = #_;
# whatever you like to do with the attributes of the sub ... do it
foreach my $attr (#attr) {
# here we parse the attribute string(s), extract the number and
# save the code ref of the subroutine
# into $Runner::schedule array ref according to the given number
# that is how we 'compile' the RUNNR of subroutines into
# a schedule
if ( $attr =~ /^RUNNR\((\d+)\)$/ ) {
$Runner::schedule->[$1] = $code_ref;
}
}
return(); # ERROR if returning a non empty list
}
1;
The output will be :
Starting ...
Running : CODE(0x129c288) --> You called func_b !
Running : CODE(0x129c2b8) --> You called func_a !
Running : CODE(0x12ed460) --> You called func_c !
Done !
If you really want to understand what attributes do and when what happens you
have to 'perldoc attributes', read it step by step and play with it. The interface
is cumbersome but in principle you hook in at compile time and handle
the information provided.
You can use attributes to tie a variable upon creation. See the silly module Tie::Hash::Cannabinol which lets you do:
use Tie::Hash::Cannabinol;
my %hash;
tie %hash, 'Tie::Hash::Cannabinol';
## or ##
my %hash : Stoned;
Edit: upon deeper examination, T::H::C (hehe) uses Attribute::Handlers too (as JRideout's answer already suggests) so perhaps that is the place to look.
Here's an example that I ran on perl 5.26.1 with Carp::Assert. Perl attributes seem to generate nice syntax for decorator pattern. Was sort of a pain to implement MODIFY_CODE_ATTRIBUTES though b.c. of the damn eval and Perl's auto reference counting.
use strict;
use Carp::Assert;
# return true if `$func` is callable, false otherwise
sub callable {
my ($func) = #_;
return defined(&$func);
}
# get the symbol table hash (stash) and the inverse of it the
# coderef table hash (crtash) where coderefs are keys and symbols are
# values. The return value is a pair of hashrefs ($stash, $crtash)
sub get_stash_and_crtash {
my $stash = eval("\\%" . __PACKAGE__ . "::");
my %coderef_to_sym;
while (my ($k, $v) = each(%$stash)) {
$coderef_to_sym{$v} = $k if (callable($v));
}
return ($stash, \%coderef_to_sym);
}
# return an eval string that inserts `$inner` as the first argument
# passed into the function call string `$outer`. For example, if
# `$inner` is "$foo" (the lvalue NAME, not the lvalue itself), and
# `$outer` is "bar(1)", then the resulting eval string will be
# "bar($foo, 1)"
sub insert_context {
my ($inner, $outer) = #_;
my $args_pat = qr/\((.*)\)$/;
$outer .= '()' if ($outer !~ /\)$/);
$outer =~ /$args_pat/;
$1 ?
$outer =~ s/$args_pat/($inner, $1)/ :
$outer =~ s/$args_pat/($inner)/;
return $outer;
}
# hook that gets called when appending attributes to functions.
# `$cls` is the package at the point of function declaration/definition,
# `$ref` is the coderef to the function being declared/defined,
# `#attrs` is a list to the attributes being added. Attributes are function
# call strings.
sub MODIFY_CODE_ATTRIBUTES {
my ($cls, $ref, #attrs) = #_;
assert($cls eq 'main');
assert(ref($ref) eq 'CODE');
for (#attrs) {
assert(/^appender_d\(.*\)$/ || $_ eq 'upper_d');
}
my #non_decorators = grep { !/^\w+_d\b/ } #attrs;
return #non_decorators if (#non_decorators);
my ($stash, $crtash) = get_stash_and_crtash();
my $sym = $crtash->{$ref};
$stash->{$sym} = sub {
my $ref = $ref;
my $curr = '$ref';
for my $attr (#attrs) {
$curr = insert_context($curr, $attr);
}
eval("${curr}->()");
};
return ();
}
sub appender_d {
my ($func, $chars) = #_;
return sub { $func->() . $chars };
}
sub upper_d {
my ($func) = #_;
return sub { uc($func->()) };
}
sub foo : upper_d appender_d('!') {
return "foo";
}
sub main {
print(foo());
}
main();

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

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+$/;

Deferring code on scope change in Perl

I often find it useful to be able to schedule code to be executed upon leaving the current scope. In my previous life in TCL, a friend created a function we called defer.
It enabled code like:
set fp [open "x"]
defer("close $fp");
which was invoked when the current scope exited. The main benefit is that it's always invoked no matter how/where I leave scope.
So I implemented something similar in Perl but it seems there'd be an easier way. Comments critiques welcome.
The way I did it in Perl:
create a global, tied variable which holds an array of subs to be executed.
whenever I want to schedule a fn to be invoked on exit, I use local to change the array.
when I leave the current scope, Perl changes the global to the previous value
because the global is tied, I know when this value change happens and can invoke the subs in the list.
The actual code is below.
Is there a better way to do this? Seems this would be a commonly needed capability.
use strict;
package tiescalar;
sub TIESCALAR {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
sub FETCH {
my $self = shift;
return $self->{VAL};
}
sub STORE {
my $self = shift;
my $value = shift;
if (defined($self->{VAL}) && defined($value)) {
foreach my $s (#{$self->{VAL}}) { &$s; }
}
$self->{VAL} = $value;
}
1;
package main;
our $h;
tie($h, 'tiescalar');
$h = [];
printf "1\n";
printf "2\n";
sub main {
printf "3\n";
local $h = [sub{printf "9\n"}];
push(#$h, sub {printf "10\n";});
printf "4\n";
{
local $h = [sub {printf "8\n"; }];
mysub();
printf "7\n";
return;
}
}
sub mysub {
local $h = [sub {printf "6\n"; }];
print "5\n";
}
main();
printf "11\n";
Well, your specific case is already handled if you use lexical filehandles (as opposed to the old style bareword filehandles). For other cases, you could always use the DESTROY method of an object guaranteed to go to zero references when it goes out of scope:
#!/usr/bin/perl
use strict;
use warnings;
for my $i (1 .. 5) {
my $defer = Defer::Sub->new(sub { print "end\n" });
print "start\n$i\n";
}
package Defer::Sub;
use Carp;
sub new {
my $class = shift;
croak "$class requires a function to call\n" unless #_;
my $self = {
func => shift,
};
return bless $self, $class;
}
sub DESTROY {
my $self = shift;
$self->{func}();
}
ETA: I like brian's name better, Scope::OnExit is a much more descriptive name.
Instead of using tie for this, I think I'd just create an object. You can also avoid the local that way too.
{
my $defer = Scope::OnExit->new( #subs );
$defer->push( $other_sub ); # and pop, shift, etc
...
}
When the variable goes out of scope, you have a chance to do things in the DESTROY method.
Also, in the example you posted, you need to check that the values you store are code references, and it's probably a good idea to check that the VAL value is an array reference:
sub TIESCALAR { bless { VAL => [] }, $_[0] }
sub STORE {
my( $self, $value ) = #_;
carp "Can only store array references!" unless ref $value eq ref [];
foreach { #$value } {
carp "There should only be code refs in the array"
unless ref $_ eq ref sub {}
}
foreach ( #{ $self->{VAL}} ) { $_->() }
$self->{VAL} = $value;
}
You may want to try out B::Hooks::EndOfScope
I Believe this works:
use B::Hooks::EndOfScope;
sub foo {
on_scope_end {
$codehere;
};
$morecode
return 1; # scope end code executes.
}
foo();
I think you want something like Scope::Guard, but it can't be pushed. Hmmm.
Thanks.
Trivially,
sub OnLeavingScope::DESTROY { ${$_[0]}->() }
used like:
{
...
my $onleavingscope = bless \sub { ... }, 'OnLeavingScope';
my $onleavingscope2 = bless \\&whatever, 'OnLeavingScope';
...
}
(The extra level of having a reference to a reference to a sub is necessary only to work around an optimization (that's arguably a bug) when using a non-closure anonymous sub.)