I'm trying to write a pragma for defining a bunch of constants, like this:
use many::constant
one_constant => 1,
other_constant => 2,
;
The relevant portion of my import looks like
package many::constant;
use strict;
use warnings;
sub import {
my ($class, #constants) = #_;
my $caller_nms = do {
no strict 'refs';
\%{caller.'::'}
};
while (my ($name, $value) = splice #constants, 0, 2) {
*{$caller_nms->{$name}} = sub () { $value };
}
}
I expect the $caller_nms stash to auto-vivify when assigned to like this, but I'm getting an error "Can't use an undefined value as a symbol reference". Is there a way to get this assignment to work like I expect? I ended up changing the assignment to:
my $caller_glob = do {
no strict 'refs';
\*{caller.'::'.$name}
};
*$caller_glob = sub () { $value };
but that feels less elegant to me.
Just use use constant as a baseline and actually examine the source: constant.pm.
That's essentially what it does as well:
my $pkg = caller;
# ...
{
no strict 'refs';
my $full_name = "${pkg}::$name";
# ...
my #list = #_;
*$full_name = sub () { #list };
}
Also, note that the constant module has this feature: constant #Defining multiple constants at once
use strict;
use warnings;
use constant {
one_constant => 1,
other_constant => 2,
};
print one_constant, ' - ', other_constant, "\n";
Outputs:
1 - 2
Related
I'm trying to make subroutine closure working like an object.
However, I cannot call the returned subs references properly.
I receive Not a CODE reference at .\closure.pl line 22. error.
#!/usr/bin/perl
use strict;
use warnings;
sub number {
my ($value) = #_;
my $val = sub { $value };
my $inc = sub { ++$value };
my $dec = sub { --$value };
my %api = (
'val' => \$val,
'inc' => \$inc,
'dec' => \$dec,
);
return %api;
}
my %numb = number(42);
$numb{'inc'}->();
print $numb{'val'}->();
How to fix the code?
Code fixed
Yes, of course, an anonymous definition must return a reference. it means that it can be put directly in the %api. Perl doesn't complain and works like a charm :)
#!/usr/bin/perl
use strict;
use warnings;
sub number {
my ($value) = #_;
my %api = (
'val' => sub { $value },
'inc' => sub { ++$value },
'dec' => sub { --$value },
);
return \%api;
}
my $m = number(14);
my $n = number(41);
$m->{'dec'}->();
$n->{'inc'}->();
print $m->{'val'}->() . "\n"; # -> 13
print $n->{'val'}->() . "\n"; # -> 42
As discussed in perlref, the sub keyword without a name creates an anonymous subroutine and returns a reference to it. So you don't need to create another level of reference using the backslash; just pass the reference you already have as the value in the hash.
I'd like to weaken captured variables in the code generated by Sub::Quote. For example, here's the non-quoted alternative:
use 5.10.0;
use Scalar::Util qw[ weaken ];
{
my $s = 'foo';
my $x = sub { say $s };
weaken( my $y = $x );
my $bar = sub { &$y };
&$bar;
$x = undef;
&$bar
}
and the output:
foo
Can't use an undefined value as a subroutine reference [...]
And here's my Sub::Quote attempt:
use 5.10.0;
use Sub::Quote;
use Scalar::Util qw[ weaken ];
{
my $s = 'foo';
my $x = sub { say $s };
weaken( my $y = $x );
my $bar = quote_sub( '&$y', { '$y' => \$y } );
&$bar;
$x = undef;
&$bar;
}
and the output:
foo
foo
Obviously the captured $y isn't weakened. Is there a way of altering the generated code to weaken captured variables?
The documentation is sparse, and the Sub::Quote implementation is complex; I'm fairly convinced this isn't possible with the current code, but I'd love to be shown to be wrong.
my $bar = quote_sub( '&$y', { '$y' => \$y } );
is roughly the same as
my $bar = eval(q{ my $y = $y; sub { &$y } });
(It does more, but those bits are irrelevant to this question). As you can see, that creates a new strong reference to the sub[1].
As a workaround, you could add a layer of indirection:
my $bar = eval(q{ my $y_ref = \$y; sub { &{ $$y_ref } } });
This can be achieved by using:
my $bar = quote_sub( '&{$$y_ref}', { '$y_ref' => \\$y } );
There wouldn't be any problems if the $y created by Sub::Quote was an alias for your $y. This can be achieved using Data::Alias or an experimental feature introduced in 5.22.
This can be demonstrated using the following:
{
package Sub::Quote;
my $sub = sub {
my ($from, $captures, $indent) = #_;
join(
'',
"use feature qw( refaliasing );\n",
"no warnings qw( experimental::refaliasing );\n",
map {
/^([\#\%\$])/
or croak "capture key should start with \#, \% or \$: $_";
(' ' x $indent).qq{\\my ${_} = \\${1}{${from}->{${\quotify $_}}};\n};
} keys %$captures
)
};
no warnings qw( redefine );
*capture_unroll = $sub;
}
my $bar = quote_sub( '&$y', { '$y' => \$y } );
You could talk to the module's maintainer about adding an option that would cause the use of aliasing.
When you create a copy of a (strong or weak) reference, it's a strong reference.
I am trying a different way of calling a subroutine in a Perl script.
I have a set of functions as follows:
sub Testcase_CheckStatus {
print "TestCase_CheckStatus called\n";
}
Then I'm traversing a Perl hash with keys like "CheckStatus":
while (my ($k, $v) = each %test_cases) {
print "TestCase_$k","\n";
Testcase_$k();
}
Basically, I want to call the function Testcase_CheckStatus like above while parsing the keys of hash, but I'm getting this error:
Can't locate object method "Testcase_" via package "CheckStatus" (perhaps you forgot to load "CheckStatus"?) at ./main.pl line 17
What can I do to correct this problem? Is there any alternate way of doing the same?
Other way:
use 5.010;
use warnings;
use strict;
my $testcases = {
test_case_1 => sub {
return 1 * shift();
},
test_case_2 => sub {
return 3 * shift();
},
test_case_3 => \&SomeSub,
};
for (1 .. 3) {
say $testcases->{ 'test_case_' . $_ }(7);
}
sub SomeSub {
return 5 * shift();
}
The following should allow you to do what you want:
while (my ($k, $v) = each %test_cases) {
print "TestCase_$k","\n";
&{"Testcase_$k"}();
}
However, this won't work if strict is in use. If you are using strict you will need a no strict inside the while loop, e.g.:
while (my ($k, $v) = each %test_cases) {
no strict 'refs';
print "TestCase_$k","\n";
&{"Testcase_$k"}();
}
I want to call a main controller function that dispatches other function dynamically, something like this:
package Controller;
my %callback_funcs = ();
sub register_callback{
my ($class,$callback,$options) = _#;
#apppend to %callback_funcs hash ... ?
}
sub main{
%callback_funcs = ( add => 'add_func', rem => 'remove_func', edit => 'edit_func');
while(<STDIN>){
last if ($_ =~ /^\s*$/);
if($_ == 'add' || _$ == 'rem' || _$ == 'edit'){
$result = ${callback_funcs['add']['func']}(callback_funcs['add']['options']);
}
}
}
sub add_func{
...
}
One caveat is that the subs are defined in other Modules, so the callbacks would have to be able to reference them... plus
I'm having a hard time getting the hashes right!
So, it's possible to have a hash that contains anonymous subroutines that you can invoke from stdin.
my %callbacks = (
add => sub {
# do stuff
},
fuzzerbligh => sub {
# other stuff
},
);
And you can insert more hashvalues into the hash:
$callbacks{next} = sub {
...
};
And you would invoke one like this
$callbacks{next}->(#args);
Or
my $coderef = $callbacks{next};
$coderef->(#args);
You can get the hashkey from STDIN, or anywhere else.
You can also define them nonymously and then take a reference to them.
sub delete {
# regular sub definition
}
$callbacks{delete} = \&delete;
I wouldn't call these callbacks, however. Callbacks are subs that get called after another subroutine has returned.
Your code is also rife with syntax errors which may be obscuring the deeper issues here. It's also not clear to me what you're trying to do with the second level of arrays. When are you defining these subs, and who is using them when, and for what?
Perhaps this simplified example will help:
# Very important.
use strict;
use warnings;
# Define some functions.
sub multiply { $_[0] * $_[1] }
sub divide { $_[0] / $_[1] }
sub add { $_[0] + $_[1] }
sub subtract { $_[0] - $_[1] }
# Create a hash of references to those functions (dispatch table).
my %funcs = (
multiply => \&multiply,
divide => \÷,
add => \&add,
subtract => \&subtract,
);
# Register some more functions.
sub register {
my ($key, $func) = #_;
$funcs{$key} = $func;
}
register('+', \&add); # As above.
register('sum', sub { # Or using an anonymous subroutine.
my $s = 0;
$s += $_ for #_;
return $s;
});
# Invoke them dynamically.
while (<>){
my ($op, #args) = split;
last unless $op and exists $funcs{$op}; # No need for equality tests.
print $funcs{$op}->(#args), "\n";
}
You've already got some good answers on how to build a dispatch table and call functions through it within a single file, but you also keep talking about wanting the functions to be defined in other modules. If that's the case, then wouldn't it be better to build the dispatch table dynamically based on what dispatchable functions each module says it has rather than having to worry about keeping it up to date manually? Of course it would!
Demonstrating this requires multiple files, of course, and I'm using Module::Pluggable from CPAN to find the modules which provide the function definitions.
dispatch_core.pl:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
use lib '.'; # a demo is easier if I can put modules in the same directory
use Module::Pluggable require => 1, search_path => 'DTable';
for my $plugin (plugins) {
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}
DTable/Add.pm:
package DTable::Add;
use strict;
use warnings;
sub dispatchable {
return (add => \&add);
}
sub add {
my ($num1, $num2) = #_;
print "$num1 + $num2 = ", $num1 + $num2, "\n";
}
1;
DTable/MultDiv.pm:
package DTable::MultDiv;
use strict;
use warnings;
sub dispatchable {
return (multiply => \&multiply, divide => \÷);
}
sub multiply {
my ($num1, $num2) = #_;
print "$num1 * $num2 = ", $num1 * $num2, "\n";
}
sub divide {
my ($num1, $num2) = #_;
print "$num1 / $num2 = ", $num1 / $num2, "\n";
}
1;
Then, on the command line:
$ ./dispatch_core.pl
add:
2 + 5 = 7
divide:
2 / 5 = 0.4
multiply:
2 * 5 = 10
Adding new functions is now as simple as dropping a new file into the DTable directory with an appropriate dispatchable sub. No need to ever touch dispatch_core.pl just to add a new function again.
Edit: In response to the comment's question about whether this can be done without Module::Pluggable, here's a modified dispatch_core.pl which doesn't use any external modules other than the ones defining the dispatchable functions:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
my #dtable = qw(
DTable::Add
DTable::MultDiv
);
use lib '.';
for my $plugin (#dtable) {
eval "use $plugin";
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}
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% --