Is there a way to choose a subroutine by means of a parameter passed to another subroutine? Something like this:
sub foo1 {
# does stuff to #_
}
sub foo2 {
# does other stuff to #_
}
sub foo3 {
# does other stuff to #_
}
sub foo {
my $whichsub = shift;
my #fooed = foo.$whichsub #_;
# does stuff to #fooed
}
where foo.$whichsub should be foo1 or the like. Except that of course that doesn't work.
You can build a dispatch table of subroutines. Something like this
my #foo_table = \(&foo1, &foo2, &foo3);
foo(2);
sub foo {
my $whichsub = shift;
die unless my $foosub = $foo_table[$whichsub-1];
my #fooed = $foosub->(#_);
# does stuff to #fooed
}
sub foo1 {
# does stuff to #_
}
sub foo2 {
# does other stuff to #_
}
sub foo3 {
# does other stuff to #_
}
It can be done without a table:
sub foo {
my $whichsub = shift;
my $foosub = "foo".$whichsub;
my #fooed = &$foosub(#_);
# does stuff to #fooed
}
Related
I'm trying to write a Perl module for a “persistent YAML hash”, with the following properties:
With every access, check if the YAML file has changed, and if so, reload.
As soon as any data in the hash is changed, save.
Don't save on UNTIE, so that the file isn't updated when you only read values.
My first attempt seemed to work pretty well:
package YAMLHash;
use v5.24;
use warnings;
use experimental 'signatures';
use YAML::XS qw(DumpFile LoadFile);
use File::stat;
sub refresh($self)
{
if (-f $self->{file}) {
if (stat($self->{file})->mtime > $self->{mtime}) {
$self->{data} = LoadFile($self->{file});
$self->{mtime} = stat($self->{file})->mtime;
}
}
}
sub save($self)
{
DumpFile($self->{file}, $self->{data});
$self->{mtime} = stat($self->{file})->mtime;
}
sub TIEHASH($class, #args)
{
my ($filename) = $args[0];
die "No filename specified" unless $filename;
my $self = bless { data=>{}, file=>$filename, mtime=>0 }, $class;
refresh($self);
return $self;
}
sub FETCH($self, $key = '')
{
refresh($self);
return $self->{data}{$key};
}
sub EXISTS($self, $key)
{
refresh($self);
return exists($self->{data}{$key});
}
sub FIRSTKEY($self)
{
refresh($self);
my #ignore = keys %{$self->{data}}; # reset iterator
return each %{$self->{data}};
}
sub NEXTKEY($self, $lastkey)
{
refresh($self);
return each %{$self->{data}};
}
sub SCALAR($self)
{
return scalar %{$self->{data}};
}
sub STORE($self, $key, $value)
{
refresh($self);
$self->{data}{$key} = $value;
save($self);
}
sub DELETE($self, $key)
{
refresh($self);
delete $self->{data}{$key};
save($self);
}
sub CLEAR($self, $key)
{
$self->{data} = {};
save($self);
}
1;
I tried this as follows:
use YAMLHash;
tie my %foo, 'YAMLHash', 'test.yaml';
$foo{hello} = 'world';
$foo{answer} = 42;
$foo{counter}++;
and the resulting YAML file looks like this:
---
answer: 42
counter: 1
hello: world
But then I changed my example code to:
use YAMLHash;
tie my %foo, 'YAMLHash', 'test.yaml';
$foo{hello} = 'world';
$foo{answer} = 42;
$foo{counter}++;
$foo{a}{b}{c}{d} = 'e';
and the result is:
---
a: {}
answer: 42
counter: 2
hello: world
So, obviously, STORE is called when $foo{a} is created, but not when $foo{a}{b}{c}{d} is assigned.
Is there any way to make this do what I want?
You will need to tie %{ $foo{a} }, %{ $foo{a}{b} } and %{ $foo{a}{b}{c} } as well.
You could recursively tie the hashes and arrays in the data structure in TIEHASH. Don't forget to the do the same thing to data added to the structure via STORE!
You might want to use a different class for the root of the data structure and non-root nodes.
Warning: Using tie will make accesses slower.
Note that you need to tie the scalars too, not just the hashes (and arrays). All of the following change the value of a hash element without calling STORE:
Changing the scalar directly:
++$foo{a};
chomp($foo{a});
$foo{a} =~ s/x/y/g;
...
Changing a scalar via an alias or a reference:
my \$x = \$foo{a}; $x = 123;
my $r = \$foo{a}; $$r = 123;
for ($foo{a}) { $_ = 123; }
sub { $_[0] = 123; }->($foo{a});
...
In Perl it is possible to implicitly pass the implicit variable to some built in functions, like this:
$_ = 'foo';
print; # prints foo
Is it possible to define such behavior for my sub? like this:
sub bar {
print $_[0];
}
$_ = 'foo';
&bar; # does not work
Thanks in advance.
$_[0] is first element of #_ array used to get values passed to subroutine. $_ is used as global implicit variable,
sub bar {
my ($arg) = (#_, $_);
print $arg;
}
local $_ = 'foo';
bar();
bar("explicit foo");
Single argument:
sub bar {
my $arg = #_ ? shift : $_;
...
}
Single argument (5.10+):
sub bar(_) {
my $arg = shift;
...
}
Multiple arguments:
sub bar {
my #args = #_ ? #_ : $_;
...
}
Multiple arguments (5.10+):
sub bar(_#) {
my #args = #_;
...
}
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
If I have the following code
sub a {
my $id = shift;
# does something
print &a_section($texta);
print &a_section($textb);
sub a_section {
my $text = shift;
# combines the $id and the $text to create and return some result.
}
}
Assuming a_section is called only by a, will I run into a memory leak, variable dependability, or other problem?
I am exploring this as an alternative so I can avoid the necessity of passing $id to a_section.
First, it's not a private sub. It's fully visible from the outside. Two, you will have problems.
$ perl -wE'
sub outer {
my ($x) = #_;
sub inner { say $x; }
inner();
}
outer(123);
outer(456);
'
Variable "$x" will not stay shared at -e line 4.
123
123 <--- XXX Not 456!!!!
You could do:
sub a {
my $id = shift;
local *a_section = sub {
my $text = shift;
# combines the $id and the $text to create and return some result.
};
print a_section($texta);
print a_section($textb);
}
(You can call the inner sub recursively using a_section(...).)
or:
sub a {
my $id = shift;
my $a_section = sub {
my $text = shift;
# combines the $id and the $text to create and return some result.
};
print $a_section->($texta);
print $a_section->($textb);
}
(Use __SUB__->(...) if you want to call the inner sub recursively to avoid memory leak, available in Perl 5.16+.)
This is the mock module I'm using:
http://metacpan.org/pod/Test::MockModule
How to mock sub a to sub b,
where sub b just does something else before call sub a?
sub b {
#do something else
a(#_);
}
You can grab the un-mocked method with can ( UNIVERSAL::can ). After that you can either goto it or just use the ampersand calling style to pass the same arguments. That's what I did below.
my $old_a = Package::To::Be::Mocked->can( 'a' );
$pkg->mock( a => sub {
# do some stuff
&$old_a;
});
This of course assumes that your sub isn't AUTOLOAD or generated through AUTOLOAD without redefining can. (I learned years back that if you're going to mess with AUTOLOAD, it's probably best to do the work in can.)
You could also create your own utility that does this automatically, by invading modifying the Test::MockModule's namespace.
{ package Test::MockModule;
sub modify {
my ( $self, $name, $modfunc ) = #_;
my $mock_class = $self->get_package();
my $old_meth = $mock_class->can( $name );
croak( "Method $name not defined for $mock_class!" ) unless $old_meth;
return $self->mock( $name => $modfunc->( $old_meth ));
}
}
And you could call it like so:
$mock->modify( a => sub {
my $old_a = shift;
return sub {
my ( $self ) = #_;
# my stuff and I can mess with $self
local $Carp::CarpLevel += 1;
my #returns = &$old_a;
# do stuff with returns
return #returns;
};
});