I think this might be best asked using an example:
use strict;
use warnings;
use 5.010;
use Storable qw(nstore retrieve);
local $Storable::Deparse = 1;
local $Storable::Eval = 1;
sub sub_generator {
my ($x) = #_;
return sub {
my ($y) = #_;
return $x + $y;
};
}
my $sub = sub_generator(1000);
say $sub->(1); # gives 1001
nstore( $sub, "/tmp/sub.store" );
$sub = retrieve("/tmp/sub.store");
say $sub->(1); # gives 1
When I dump /tmp/sub.store I see:
$VAR1 = sub {
package Storable;
use warnings;
use strict 'refs';
my($y) = #_;
return $x + $y;
}
But $x is never defined in this sub. I would expect that the sub generated by sub_generator will have $x replaced with its actual value upon generation. How should I solve this?
Note this question relates to this one.
Unfortunately I don't think Storable works with closures. However there are other CPAN modules that will serialise a closure. For eg. Data::Dump::Streamer
use 5.012;
use warnings;
use Data::Dump::Streamer;
sub sub_generator {
my ($x) = #_;
return sub {
my ($y) = #_;
return $x + $y;
};
}
my $sub = sub_generator(1000);
say $sub->(1); # gives 1001
my $serialised = Dump( $sub )->Out;
my $copy = do {
my $CODE1 = undef;
eval $serialised;
$CODE1;
};
say $copy->(2); # gives 1002
say $sub->(1); # still gives 1001
This is what the serialised code looks like when printed here, say Dump $sub;:
my ($x);
$x = 1000;
$CODE1 = sub {
use warnings;
use strict 'refs';
BEGIN {
$^H{'feature_unicode'} = q(1);
$^H{'feature_say'} = q(1);
$^H{'feature_state'} = q(1);
$^H{'feature_switch'} = q(1);
}
my($y) = #_;
return $x + $y;
};
Update
See this thread Storable and Closures on the Perl5 porters mailing list. It confirms what I thought about Storable and closures.
/I3az/
Related
I found a solution to renaming anonymous subs in Perl here. It involves temporarily mangling the symbol table to insert the desired name. This solution uses a hard-coded symbol table name to be replaced. My problem is that I would like to dynamically choose the symbol table name at runtime. Something like this:
$pkg = 'MyPkg::ModA::';
$name = 'subname';
...
no strict 'refs';
local *{"${pkg}__ANON__"} = "$name [anon]";
strict refs;
The only way to make it work is to disable strict refs. If they are not disabled, the script fails with this message:
Can't use string ("MyPkg::ModA::__ANON__") as a symbol ref while "strict refs" in use at /path/to/source/File.pm line xx
Note that the equivalent statement could be used
local ${$pkg}{__ANON__} = "$name [anon]";
with the similar error message:
Can't use string ("MyPkg::ModA::") as a HASH ref while "strict refs" in use at /path/to/source/File.pm line xx
Is it possible to do the same thing without disabling strict refs?
TMI/DNR:
Here is a complete example in case you're interested. Ironically, my solution uses an anonymous sub to rename the given anonymous sub.
ModA.pm
package MyPkg::ModA;
use strict;
use warnings;
use MyPkg::Util;
# Create a new instance.
sub new
{
my ($type, $class, $self);
# allow for both ModA::new and $moda->new
$type = shift;
$class = ref $type || $type;
$self = {#_};
bless $self, $class;
# use exported Util::anon sub here
$self->{func} = anon sub
{
my ($arg);
$arg = shift;
debug "\$arg: $arg";
};
return $self;
} # new
1;
__END__
ModB.pm
package MyPkg::ModB;
use strict;
use warnings;
use MyPkg::ModA;
# Create a new instance.
sub new
{
my ($type, $class, $self);
# allow for both ModB::new and $modb->new
$type = shift;
$class = ref $type || $type;
$self = {#_};
bless $self, $class;
$self->{modA} = MyPkg::ModA->new;
return $self;
} # new
# Do something with ModA.
sub doit
{
my ($self);
$self = shift;
$self->{modA}->{func}->('What is your quest?');
} # doit
1;
__END__
Util.pm
package MyPkg::Util;
use strict;
use warnings;
require Exporter;
our (#ISA, #EXPORT);
#ISA = qw(Exporter);
#EXPORT = qw(
anon
debug);
# Temporarily mangle symbol table to replace '__ANON__'.
sub anon
{
my ($func, $sub, $pkg, $name);
$func = shift;
$sub = (caller 1)[3];
$sub =~ /(.*::)(.+)/;
$pkg = $1;
$name = $2;
return sub
{
# TODO How to do this w/o disabling strict?
#no strict 'refs';
# temp symbol table mangling here
# ${$pkg}{__ANON__} is equivalent to *{"${pkg}__ANON__"}
local *{"${pkg}__ANON__"} = "$name [anon]";
use strict;
$func->(#_);
};
} # anon
# Print a debug message.
sub debug
{
my($fname, $line, $sub);
($fname, $line) = (caller 0)[1,2];
$fname =~ s/.+\///;
$sub = (caller 1)[3] || 'main';
$sub =~ s/.*::(.+)/$1/;
printf STDERR "%-10s %s(%s) - \"%s\"\n", $fname, $sub, $line, "#_";
} # debug
1;
__END__
mytest.pl
#! /usr/bin/perl
use strict;
use warnings;
use MyPkg::ModB;
# Stuff happens here.
my ($modB);
$modB = MyPkg::ModB->new;
$modB->doit;
You can use core module Sub::Util's set_subname.
use Sub::Util qw( set_subname );
sub anon {
...
return set_subname("$name [anon]", $func);
}
I am well aware that there are several questions on a similar subjects but I fail to see how to apply the answers to my problem :
< Can't locate object method "idx" via package "1" >
What I don't understand is that I am using the same architecture in two packages and that it is OK in the first one... Where is the package "1" coming from ?
Here is the package that works fine :
package ObjA;
use warnings;
use strict;
use Data::Dumper;
use Carp;
use ObjB;
#CONSTRUCTOR AND INITIALISATION
sub new {
my $class = shift;
my $self = {#_};
bless($self,$class);
$self->language();
return $self;
}
sub load {
my $self = shift;
open (my $stream,"<",$self ->{name});
my #glob_xs=();
my $i = 0;
while (<$stream>){
$i += 1;
my #x = extract($stream,());
#glob_xs=(#glob_tokens,#x);
}
$self->tokens(\#glob_xs);
}
sub extract{
my ($stream,#x) = #_;
my $line = <$stream>;
chomp $line;
if ($line =~ /^\s*$/){
return #x;
}
print join("/",split("\t",$line));
my $b = ObjB::new(split("\t",$line));
push #x,$b->form;
extract_sentence($stream,#x);
}
# OBJECT ACCESSOR METHODS
sub language {$_[0]->{language}=$_[1] if defined $_[1] ; $_[0]->{language}}
1;
And here is the one that produces the error :
package ObjB;
use warnings;
use strict;
use Data::Dumper;
use Carp;
# CONSTRUCTOR AND INITIALISATION
sub new {
my $class = shift;
my $self = {#_};
bless($self,$class);
$self->idx(); # Dies here.
return $self;
}
# OBJECT ACCESSOR METHODS
sub idx {$_[0]->{idx}=$_[1] if defined $_[1] ; $_[0]->{idx}}
1;
Would it be because ObjB is called inside ObjA ? Or because they are declared in two different files ?
I truly hope someone will have an answer because I have been running in circles ...
Thank you !!
Obj::new is a method, but you call it as a subroutine.
ObjB::new(split("\t",$line));
This results in the value of first field of the line being used as the class, and that value is probably 1. You probably meant to use
ObjB->new(split("\t",$line));
I'm to learn Perl for a job interview over weekend. In order to get a deeper understanding I'm trying to implement a tree class.
#use strict;
#use warnings;
package Tree;
sub new {
my $class = shift #_;
my $content = shift #_;
my #array = shift #_;
return bless { "content" => $content, "array" => #array }, $class;
}
sub num_children {
my $self = shift #_;
my #array = $self->{"array"};
return scalar #array;
}
return 1;
To test the (faulty) tree class I have implemented the following test script.
#!/usr/bin/perl
require Tree;
my $t = Tree->new("#", undef);
my $tt = Tree->new("*", undef);
my $tttt = Tree->new("-", undef);
my $ttttt = Tree->new(".", undef);
my #list = ();
push #list, $tt;
push #list, $t;
push #list, $tttt;
push #list, $ttttt;
my $ttt = Tree->new("+", #list);
print $ttt->num_children();
Unfortunately the output is 1 instead of my expection of 4. I assume the array is somehow cut off or unvoluntarily converted to a scalar. Any Ideas?
The main problem is that you can't pass arrays as a single value—you have to pass a reference instead.
Also, you should never comment out use strict and use warnings. They are valuable debugging tools, and if you are getting error messages with them enabled you should fix the errors that they are flagging instead.
Here's a working Tree.pm
use strict;
use warnings;
package Tree;
sub new {
my $class = shift;
my ($content, $array) = #_;
return bless { content => $content, array => $array }, $class;
}
sub num_children {
my $self = shift;
my $array = $self->{array};
return scalar #$array;
}
1;
and the calling program tree_test.pl. Note that you should use rather than require a module.
#!/usr/bin/perl
use strict;
use warnings;
use Tree;
my #list = map { Tree->new($_) } ('#', '*', '-', '.');
my $ttt = Tree->new('+', \#list);
print $ttt->num_children, "\n";
output
4
shift only removes one element from an array. Populate #array without it:
my #array = #_;
But, you can't store an array in a hash directly, you have to use a reference:
return bless { content => $content,
array => \#array,
}, $class;
which you then have to dereference:
my #array = #{ $self->{array} };
return scalar #array
Currently I am making a new module and I was wondering how could I implement in my module 2 things.
We often see the use like:
use My::Module qw(something);
for example:
use CGI::Carp qw(fatalsToBrowser);
So the first question is, how do i
retrieve this, i mean wether the
user has specified anything and what
he specified ?
Second question is, How do i pass and read the args
directly on the constructor like
this:
my $my_module = My::Module->new(arg1,arg2,arg3);
AS requested on the comment the simple module test code:
package My::Module;
# $Id$
use strict;
use Carp;
sub new {
my $class = shift;
my $self = {};
$self->{ARG1} = undef;
$self->{ARG2} = undef;
$self->{ARG3} = undef;
$self->{ARG4} = undef;
bless($self,$class);
return $self;
}
sub arg1 {
my $self = shift;
if (#_) { $self->{ARG1} = shift }
return $self->{ARG1};
}
sub arg2 {
my $self = shift;
if (#_) { $self->{ARG2} = shift }
return $self->{ARG2};
}
sub arg3 {
my $self = shift;
if (#_) { $self->{ARG3} = shift }
return $self->{ARG3};
}
sub arg4 {
my $self = shift;
if (#_) { $self->{ARG4} = shift }
return $self->{ARG4};
}
sub dump {
my $self = shift;
require Data::Dumper;
my $d = Data::Dumper->new([$self], [ref $self]);
$d->Deepcopy(1);
return $d->Dump();
}
1; # so the require or use succeeds
perldoc -f use explains that the use keyword is simply loading a module during compile-time, and then calling ->import on it. The arguments a caller gave to the use statement will be passed to the import method call.
As for your second question: constructors are just methods. Getting their arguments works like it does for any other method or function, using the #_ variable.
import subroutine gets the arguments passed in a use. The following code samples should help you.
File: My/Module.pm
package My::Module;
use warnings;
use strict;
use Data::Dumper;
sub import {
my ( $package, #args ) = #_;
print Dumper \#args;
}
1;
File: module.pl
#!/usr/bin/env perl
use warnings;
use strict;
use My::Module qw(something);
If you are programming an object oriented module, you may try Moose which will save you lots of time.
Is it possible to dynamically specify a class in Perl and access a static method in that class? This does not work, but illustrates what I'd like to do:
use Test::Class1;
my $class = 'Test::Class1';
$class::static_method();
I know I can do this:
$class->static_method();
and ignore the class name passed to static_method, but I wonder if there's a better way.
Yup! The way to do it with strictures is to use can.
package Foo::Bar;
use strict;
use warnings;
sub baz
{
return "Passed in '#_' and ran baz!";
}
package main;
use strict;
use warnings;
my $class = 'Foo::Bar';
if (my $method = $class->can('baz'))
{
print "yup it can, and it ";
print $method->();
}
else
{
print "No it can't!";
}
can returns a reference to the method, undef / false. You then just have to call the method with the dereferene syntax.
It gives:
> perl foobar.pl
yup it can, and it Passed in '' and ran baz!
As always with Perl, there is more than one way to do it.
use strict;
use warnings;
{
package Test::Class;
sub static_method{ print join(' ', #_), "\n" }
}
You can use the special %:: variable to access the symbol table.
my $class = 'Test::Class';
my #depth = split '::', $class;
my $ref = \%::;
$ref = $glob->{$_.'::'} for #depth; # $::{'Test::'}{'Class::'}
$code = $glob->{'static_method'};
$code->('Hello','World');
You could just simply use a symbolic reference;
no strict 'refs';
my $code = &{"${class}::static_method"};
# or
my $code = *{"${class}::static_method"}{CODE};
$code->('Hello','World');
You could also use a string eval.
eval "${class}::static_method('Hello','World')";
The simplest in this case, would be to use UNIVERSAL::can.
$code = $class->can('static_method');
$code->('Hello','World');
I am unaware of a particularly nice way of doing this, but there are some less nice ways, such as this program:
#!/usr/bin/perl -w
use strict;
package Test::Class1;
sub static_method {
print join(", ", #_) . "\n";
}
package main;
my $class = "Test::Class1";
{
no strict "refs";
&{${class}. "::static_method"}(1, 2, 3);
}
I have included a $class variable, as that was how you asked the question, and it illustrates how the class name can be chosen at runtime, but if you know the class beforehand, you could just as easily call &{"Test::Class1::static_method"}(1, 2, 3);
Note that you have to switch off strict "refs" if you have it on.
There are three main ways to call a static function:
$object->static_method()
Classname->static_method()
Classname::static_method()
You could define your function like this:
# callable as $object->static_method() or Classname->static_method()
sub static_method
{
my $class = shift; # ignore; not needed
# ...
}
or like this, which works in all three calling scenarios, and doesn't incur any overhead on the caller's side like Robert P's solution does:
use UNIVERSAL qw(isa);
sub static_method
{
my $class = shift if $_[0] and isa($_[0], __PACKAGE__);
# ...
}
You can use string eval:
#!/usr/bin/perl
use strict; use warnings;
package Test::Class1;
sub static_method {
print join(", ", #_) . "\n";
}
package main;
my $class = 'Test::Class1';
my $static_method = 'static_method';
my $subref = eval q{ \&{ "${class}::${static_method}" } };
$subref->(1, 2, 3);
Output:
C:\Temp> z
1, 2, 3
Benchmarks:
#!/usr/bin/perl
use strict; use warnings;
package Test::Class1;
sub static_method { "#_" }
package main;
use strict; use warnings;
use Benchmark qw( cmpthese );
my $class = 'Test::Class1';
my $static_method = 'static_method';
cmpthese -1, {
'can' => sub { my $r = $class->can($static_method); $r->(1, 2, 3) },
'eval' => sub {
my $r = eval q/ \&{ "${class}::${static_method}" } /;
$r->(1, 2, 3);
},
'nostrict' => sub {
no strict "refs";
my $r = \&{ "${class}::static_method" };
$r->(1, 2, 3);
}
};
Output:
Rate eval can nostrict
eval 12775/s -- -94% -95%
can 206355/s 1515% -- -15%
nostrict 241889/s 1793% 17% --