I'm trying to replace a problematic and long snippet of code in Perl to something like this:
my $disp = {
option1 => sub { if(true){$disp->{option2}->();}},
option2 => sub { print "opt 2\n"},
option3 => sub { print "opt 3\n"},
default => sub { print "default\n" },
};
$disp->{($disp->{$option})?$option:'default'}->(#args);
My problem occurs when I need to execute for example option2 when the execution is inside option1, but I can't access $disp within $disp and $self isn't present, ideas?
Just declare the variable in a previous statement so you can use it in the next one:
my $disp;
$disp = {
option1 => sub { if(true){$disp->{option2}->();}},
option2 => sub { print "opt 2\n"},
option3 => sub { print "opt 3\n"},
default => sub { print "default\n" },
};
$disp->{($disp->{$option})?$option:'default'}->(#args);
Also, I'd probably write the last line as
($disp->{$option} || $disp->{default})->(#args);
Related
Is there a clean way to, at declaration time, make a stored hash value point to another value in the same datastructure?
For example, say I have a datastructure for command callbacks:
my %commands = (
'a' => {
'init' => sub { return "common initializer"; },
'run' => sub { return "run a"; }
},
'b' => {
'init' => sub { return "init b"; },
'run' => sub { return "run b"; }
},
'c' => {
'init' => sub { return "common initializer"; },
'run' => sub { return "run c"; }
}
);
I know this could be rewritten as:
sub common_initializer() { return "common initializer"; }
my %commands = (
'a' => {
'init' => \&common_initializer,
'run' => sub { return "run a"; }
},
'b' => {
'init' => sub { return "init b"; },
'run' => sub { return "run b"; }
},
'c' => {
'init' => \&common_initializer,
'run' => sub { return "run c"; }
}
);
This works but the subroutines are no longer all anonymous. Double-initialization is another option:
sub get_commands($;$) {
my ($_commands, $pass) = #_;
%$_commands = (
'a' => {
'init' => sub { return "common initializer"; },
'run' => sub { return "run a"; }
},
'b' => {
'init' => sub { return "init b"; },
'run' => sub { return "run b"; }
},
'c' => {
'init' => $$_commands{'a'}{'init'},
'run' => sub { return "run c"; }
}
);
get_commands($_commands, 1) unless (defined $pass);
}
my %commands;
get_commands(\%commands);
This works but it's rather kludgy and expensive. I'm using subroutines in the example above but I'd like this to work for any datatype. Is there a cleaner way to do this in Perl?
I believe that using a named subroutine might be the best option. E.g.:
sub foo { return "foo" }
my %commands ( "a" => { 'init' => \&foo } );
It is easily repeatable, contained and even allows you to add arguments dynamically.
But you can also use a lookup-table:
my %commands ( "a" => {
'init' => "foo",
'run' => "foo"
});
my %run = ( "foo" => sub { return "run foo" });
my %init = ( "foo" => sub { return "init foo" });
print "The run for 'a' is: " . $run{ $commands{a}{run} }->() . "\n";
This looks a bit more complicated to me, but it would work for any datatype, as you requested.
I see that you are using prototypes, e.g. sub foo($;$). You should be aware that these are optional, and they do not do what most people think. Most often you can skip these, and your code will be improved. Read the documentation.
Is there a clean way to, at declaration time, make a stored hash value point to another value in the same datastructure?
Impossible, by definition. You can't look up a value in the hash before you actually assign it to the hash. As such, solutions of the form my %h = ...; can't possibly work.
If you want to avoid duplication, you have two options:
my $common_val = ...;
my %h = ( a => $common_val, b => $common_val );
my %h = ( a => ..., b => undef );
$h{b} = $h{a};
(The first is best because it gives a name to the common thing.)
What I would probably do instead is use classes or objects. Inheritance and composition (e.g. roles) provide convenient means of sharing code between classes.
Classes:
my %commands = (
a => ClassA,
b => ClassB,
);
Objects:
my %commands = (
a => ClassA->new(),
b => ClassB->new(),
);
Either way, the caller would look like this:
$commands{$id}->init();
Taking it one step further, you could get rid of %commands entirely by naming the classes Command::a, Command::b, etc. Then all you'd need is
( "Command::" . $id )->init();
You're effectively using plugins at this point. There are modules that might make using a plugin even more shiny.
Note: Answering my own question but I'm still open to other solutions.
One alternate approach I've come up with is to mark cross-references with specially-formatted strings. At runtime the datastructure is traversed and any such strings are replaced with pointers to the values they name.
This is lighter-weight than the double-initialization method I mentioned in my question. It also has the advantage of keeping everything referenced in the datastructure within the datastructure (i.e. subroutines are all inline). I'm using subroutine references in the example below but this technique can be adapted for use with arbitrary datatypes (i.e. by removing the sanity check).
Here's an example:
#!/usr/bin/perl
use strict;
sub ALIAS($$#);
sub COOK(\%);
my %h = (
'a' => {
'init' => sub { return "common initializer\n"; },
'run' => sub { return "common run\n"; },
},
'b' => {
'init' => sub { return "init b\n"; },
'run' => "ALIAS {'a'}{'run'}"
},
'c' => {
ALIAS 'init' => '{a}{"init"}',
'run' => sub { return "run c\n"; },
},
);
COOK(%h);
print "Init a: " . &{$h{'a'}{'init'}}();
print "Init b: " . &{$h{'b'}{'init'}}();
print "Init c: " . &{$h{'c'}{'init'}}();
print "Run a: " . &{$h{'a'}{'run'}}();
print "Run b: " . &{$h{'b'}{'run'}}();
print "Run c: " . &{$h{'c'}{'run'}}();
# Replaces function aliases with references to the pointed to functions.
#
# Alias format is 'ALIAS {COMMAND}{FUNCTION}' where COMMAND and FUNCTION are
# the top-level and second-level keys in the passed datastructure. Both
# COMMAND and FUNCTION can optionally be quoted. See also ALIAS(...) for
# some syntatic sugar.
#
# IN: %commands -> Hash containing command descriptors (passed by reference)
sub COOK(\%) {
my ($_commands) = #_;
# Loop through commands...
foreach my $command ( keys %$_commands ) {
# Loop through functions...
foreach my $function ( keys %{$$_commands{$command}} ) {
# Only consider strings
next if ( ref $$_commands{$command}{$function} );
# Does the string look like an alias?
if ( $$_commands{$command}{$function}
=~ /^ALIAS\s+
\{
(
(?: [a-zA-Z0-9_-]+ ) |
(?:'[a-zA-Z0-9_-]+') |
(?:"[a-zA-Z0-9_-]+")
)
\}
\{
(
(?: [a-zA-Z0-9_-]+ ) |
(?:'[a-zA-Z0-9_-]+') |
(?:"[a-zA-Z0-9_-]+")
)
\}
$/x ) {
# Matched, find where it points to
my ($link_to_command, $link_to_function) = ($1, $2);
$link_to_command =~ s/['"]//g;
$link_to_function =~ s/['"]//g;
# Sanity check
unless (ref $$_commands{$link_to_command}{$link_to_function} eq 'CODE') {
die "In COOK(...), {$command}{$function} points to " .
"{$link_to_command}{$link_to_function} " .
"which is not a subroutine reference";
}
# Replace string with reference to pointed-to function
$$_commands{$command}{$function}
= $$_commands{$link_to_command}{$link_to_function};
} # END - Alias handler
} # END - Functions loop
} # END - Commands loop
} # END - COOK(...)
# Function providing syntatic sugar to let one write:
# ALIAS 'key' => "{command}{function}"
#
# instead of:
# 'key' => "ALIAS {command}{function}"
#
# This makes aliased functions more visible and makes it easier to write an
# appropriate code syntax highlighting pattern.
#
# See also COOK(...)
sub ALIAS($$#) {
my ($key, $alias, #rest) = #_;
return $key, "ALIAS $alias", #rest;
}
When run, this outputs:
Init a: common initializer
Init b: init b
Init c: common initializer
Run a: common run
Run b: common run
Run c: run c
I am using the perl Tk interface where I want to have a button test_1 and upon clicking on this button I would like a variable $varchoice to be defined as test_1. If I press on the button test_2, the variable $varchoice should be defined as test_2.
Before is the snippet of code in which I attempted to accomplish this:
$budget_frame->Button(-text => 'test_1',-command => sub{$varchoice=budget_plot_1()})->pack(-side => "left");
$budget_frame->Button(-text => 'test_2',-command => sub{$varchoice=budget_plot_2()})->pack(-side => "left");
sub budget_plot_1()
{
print "plotting 1\n";
my $var=1;
return $var;
}
sub budget_plot_2()
{
print "plotting 2\n";
my $var=2;
return $var;
}
How do I tweak this code to get the desired results?
Your program seems to work fine. Here is an example of how I tested it:
use feature qw(say);
use strict;
use warnings;
use Tk;
my $budget_frame = MainWindow->new(-title=>"Button test");
my $varchoice;
$budget_frame->Button(
-text => 'test_1',
-command => sub{ $varchoice = budget_plot_1() }
)->pack(-side => "left");
$budget_frame->Button(
-text => 'test_2',
-command => sub{ $varchoice = budget_plot_2() }
)->pack(-side => "left");
MainLoop;
say "Value of \$varchoice = $varchoice";
sub budget_plot_1()
{
print "plotting 1\n";
return "test_1";
}
sub budget_plot_2()
{
print "plotting 2\n";
return "test_2";
}
Output:
Value of $varchoice = test_1
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.
Given this Perl/Tkx code fragment:
#itemList = ({'attrib1' => 'name1', 'attrib2' => 'value1'},
{'attrib1' => 'name2', 'attrib2' => 'value2'});
$row = 0;
foreach $item (#itemList) {
push(#btn_list, new_ttk__button(-text => $item->{'attrib1'}, -command => sub {do_something($item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
(In the real program #itemList is populated from a user editable config file.)
I do see two buttons labeled 'name1' and 'name2'. But when I click on either button it seems that the parameter that is passed to the callback is always $itemList[1]->{'attrib2'}; i.e. 'attrib2' of the last element of the #itemList array. What I would like is to have the first button call do_something($itemList[0]->{'attrib2'} and the second call do_something($itemList[1]->{'attrib2'}.
What am I doing wrong, please and thank you?
You have encountered a subtle feature of for loops in Perl. First the solution: use my in the for loop. Then $item will be able to create a proper closure in the anonymous sub you declare later in the loop.
for my $item (#itemlist) {
push(#btn_list, new_ttk__button(
-text => $item->{'attrib1'},
-command => sub {do_something($item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
Further explanation: Perl implicitly localizes the subject variable of a for loop. If you don't use my in the for loop, the loop will be using a localized version of a package variable. That makes your code equivalent to:
package main;
$main::item = undef;
#itemList = ({'attrib1' => 'name1', 'attrib2' => 'value1'},
{'attrib1' => 'name2', 'attrib2' => 'value2'});
$row = 0;
foreach (#itemList) {
local $main::item = $_;
push(#btn_list, new_ttk__button(
-text => $main::item->{'attrib1'},
-command => sub {do_something($main::item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
# at the end of the loop, value of $main::item restored to undef
Your anonymous subs still refer to the $main::item package variable, whatever value that variable holds at the time that those subroutines are invoked, which is probably undef.
Shorter solution: use strict
Additional proof-of-concept. Try to guess what the following program outputs:
#foo = ( { foo => 'abc', bar => 123 },
{ foo => 'def', bar => 456 } );
my #fn;
foreach $foo (#foo) {
push #fn, sub { "42" . $foo->{bar} . "\n" };
}
foreach my $foo (#foo) {
push #fn, sub { "19" . $foo->{foo} . "\n" };
}
print $_->() for #fn;
Here's the answer:
42
42
19abc
19def
I am having trouble getting Params::Validate to work how I want it to.
#!/usr/local/bin/perl -w
use strict;
use Params::Validate qw/:all/;
use Data::Dumper;
sub foo {
my %args = validate(#_, {
bar => {
default => 99,
# TODO - Somehow use a callback to return a default if undefined
# ??!!??
# callbacks => { call_me => sub { return 99 if !defined shift }},
},
});
# $args{bar} //= 99; # Don't want to define default in 2 places
print Dumper(\%args);
}
foo({ bar => undef });
So how do I set / test for an undef in the args list and replace with the said 'default' value with Params::Validate ??
You need to be setting $_[0]:
call_me => sub { $_[0] = 99 if not defined $_[0] }
#_ is aliased to the parameters passed in, so you can use this as a reference to the original.
Also,
$args{bar} ||= 99;
would reset bar even if it were 0 or '' (empty string), which doesn't sound like what you want. Using
$args{bar} //= 99;
if you're using perl 5.10 or later would do what you want, though.
Based on your comment of not duplicating the default, the best I could come up with is:
sub foo
{
unshift #_, bar => undef;
my %args = validate(#_,
{
bar => {
optional => 1,
callbacks => {
call_me => sub { $_[0] = 99 unless defined $_[0] },
},
},
},
);
print Dumper \%args;
}
That seems to work, but I have to admit - it's ugly.