I'm trying to write a sub that takes a coderef parameter. My sub does some initialization, calls the coderef, then does some cleanup.
I need to call the coderef using the same context (scalar, list, void context) that my sub was called in. The only way I can think of is something like this:
sub perform {
my ($self, $code) = #_;
# do some initialization...
my #ret;
my $ret;
if (not defined wantarray) {
$code->();
} elsif (wantarray) {
#ret = $code->();
} else {
$ret = $code->();
}
# do some cleanup...
if (not defined wantarray) {
return;
} elsif (wantarray) {
return #ret;
} else {
return $ret;
}
}
Obviously there's a good deal of redundancy in this code. Is there any way to reduce or eliminate any of this redundancy?
EDIT I later realized that I need to run $code->() in an eval block so that the cleanup runs even if the code dies. Adding eval support, and combining the suggestions of user502515 and cjm, here's what I've come up with.
sub perform {
my ($self, $code) = #_;
# do some initialization...
my $w = wantarray;
return sub {
my $error = $#;
# do some cleanup...
die $error if $error; # propagate exception
return $w ? #_ : $_[0];
}->(eval { $w ? $code->() : scalar($code->()) });
}
This gets rid of the redundancy, though unfortunately now the control flow is a little harder to follow.
Check out the Contextual::Return module on CPAN. I think it allows you to do what you want (and probably a whole lot more).
You can exclude the !defined wantarray case early, because there is no cleanup to do (since $code->()'s result, if any, wasn't stored). That removes one case from the remaining function, making it simpler.
Second, you can move the cleanup stuff into its own function. Something like this came to my mind:
sub perform
{
my($self, $code) = #_;
if (!defined(wantarray)) {
$code->();
return;
}
return wantarray ? &cleanup($code->()) : &cleanup(scalar($code->()));
}
I think I'd do it like this:
sub perform {
my ($self, $code) = #_;
# do some initialization...
my #ret;
if (not defined wantarray) {
$code->();
} else {
#ret = wantarray ? $code->() : scalar $code->();
}
# do some cleanup...
return wantarray ? #ret : $ret[0];
}
You still have two wantarray checks, but then your cleanup function was going to need one in order to correctly return the value(s) it was passed in. You don't need to worry about the undef case in the second check, because in that case it doesn't matter what perform returns.
Related
How can I call another subroutine from existing subroutine just after the return statement in perl.
I dont want to call before the return statement as it is taking time to render. I do not want to wait. return it and then call another subroutine before the exit. Is it possible in perl?
You can fork and run your subroutine in a new process while the original process is returning.
sub do_something {
my ($var1, $var2, $var3) = #_;
my $output = ...
if (fork() == 0) {
# child process
do_something_else_that_takes_a_long_time();
exit;
}
# still the parent process
return $output;
}
Your question is tagged as Moose, so here is how you do what you want with a method modifier. The after modifier runs after a sub is, but its return value is ignored.
package Foo;
use Moose;
sub frobnicate {
my $self = shift;
# ...
return 123;
}
after frobnicate => sub {
my ($self, $rv) = #_;
$self->barnicate;
};
1;
Now whenever frobnicate is done, barnicate will be called.
Is there any way to achieve partial application in Perl?
Suppose, I want to do something like:
sub each_file($arr, $op) {
$op->($_) for #{$arr};
...
}
sub each_line($op, $file) {
...
}
each_file($arr, each_line($op));
I want to partially apply each_line() to only $op, so it'll become a new function can be passed to $each_file, how do I express this in idiomatic Perl?
You can do this in Perl with two approaches combined:
A function which returns a function reference
Closures
Example:
sub each_file {
my ($arr, $line_fn) = #_;
$line_fn->($_) for #{$arr};
...
}
sub each_line {
my ($op, $file) = #_;
...
}
sub make_line_processor {
my ( $op ) = #_;
# This is closed over $op, which effectively becomes
# a constant for the returned function
my $fn = sub {
return each_line( $op, #_ );
};
return $fn;
}
# To call it:
each_file( $arr, make_line_processor($op) );
This can be an even more useful technique in cases where you don't want $op directly, but some expensive-to-fetch derivation of it. In which case you would calculate the derived value just once (in the make_line_processor function) and close over that instead.
# given some $op as implied by your code snippet
each_file($arr, sub { each_line($op, shift) });
# shift op will be applied when anonymous sub { … } is called
(Your code snippet doesn't make it entirely clear what you intend $op to be when you make the call to each_line. It's usually better to present small working programs.)
You can roll this functionality up into a class. Then you can overload the subroutine dereference operator to make it look like your class is really a code reference.
package Partial;
use overload '&{}' => \&call;
sub new {
my $class = shift;
my $code = shift;
bless {code => $code, args => \#_}, $class;
}
sub call {
my ($self) = #_;
return sub{ $self->{code}->(#{$self->{args}}, #_) }
}
You can then use it like this:
sub printArgs {
print join ", ", #_;
print "\n";
}
my $partial = Partial->new(\&printArgs, 'foo', 'bar');
$partial->('baz', 'bat');
# prints foo, bar, baz, bat
Is it ok to use Attribute::Handlers for implementing retry logic
I have almost 50+ subroutine like verifyXXXX. I need to implement the retry logic for all these subs. I want to write this retry logic where the sub is actually implemented. If the return value of sub is false/undef then it will retry again.
subs will be called in regular way, so that the caller will not know about the retry logic, something like.
verify_am_i_doing_good()
or die('sorry you are not doing as expected.');
verify_am_i_fine()
or die ('sorry you are not find.');
:
:
the actual implementation of these functions is something like this in the package.
use Attribute::Handlers;
use constant RETRY_LIMIT => 4;
use constant RETRY_DELAY => 2;
sub verify_am_i_doing_good : __retry
{
return 1 if ($x == $y);
return;
}
sub __retry : ATTR(CODE) {
my ($pkg, $sym, $code) = #_;
my $name = *{ $sym }{NAME};
no warnings 'redefine';
*{ $sym } = sub
{
my $self = $_[0];
my $result;
logMsg (INFO, "Executing subroutine $name with retry limit " . RETRY_LIMIT);
for (my $retryCount = 1; $retryCount <= RETRY_LIMIT; $retryCount++)
{
logMsg (INFO, "Executing subroutine $name with retry count $retryCount");
my $result = $code->( #_ );
if ($result)
{
logMsg (INFO, "Expected result observed in retry count $retryCount");
return wantarray ? #$result : $result;
}
else
{
logMsg (INFO, "Expected result is NOT observed in retry count $retryCount");
logMsg (INFO, "Retrying again by updating uixml");
sleep RETRY_DELAY;
$self->updateState();
}
}
logMsg (WARN, "Failed to verify expected result for subroutine $name with retry limit " . RETRY_LIMIT);
return;
};
}
The reason to use Attribute::Handlers, inplace of Attribute::Attempts is that in the case of failure, I need to call another subroutine updateState() before retrying (re-executing) the subroutine.
I got this idea of writing the retry logic from following post http://www.perl.com/pub/2007/04/12/lightning-four.html
My main concern is that since I am using this __retry attribute for almost 50+ subs. Is it a good practice to do in this way or is there anything simple I can do?
You help will be highly appreciated.
You don't need attributes to do a sub wrapper. There was Memoize long before there was Memoize::Attrs (or Attribute::Memoize for that matter). You can just take a look at how Memoize handles it.
Quite recently, I was writing some Perl for functions called in another interface. All the arguments passed to the Perl function from this interface would be passed in a funky-but-universal format used by my division. Rather than deal with this everywhere, I wrote a logic wrapper like so
sub external (#) {
my ( $subname, $code ) = #_;
...
my $wrapped
= sub {
my $count = 5;
while ( --$count and not my #results = &$code ) {
adjust_stuff();
}
return #results;
};
{ no strict 'refs'; # my special "no-block"
*$subname = $wrapped;
}
return;
}
And used it like this (some people don't like this use of the "fat comma")
external something_I_want_to_do => sub {
my #regular_old_perl_args = #_;
...
};
The prototype (#) helps a sub act as an operator and need not always be called with parenthesis.
But by all means if you like method attributes and it works and you can get it not to bite you, use them. But you don't have to. You should probably read up on the caveats though.
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+$/;
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.)