I want to do, in Perl, the equivalent of the following Ruby code:
class Foo
MY_CONST = {
'foo' => 'bar',
'baz' => {
'innerbar' => 'bleh'
},
}
def some_method
a = MY_CONST[ 'foo' ]
end
end
# In some other file which uses Foo...
b = Foo::MY_CONST[ 'baz' ][ 'innerbar' ]
That is, I just want to declare a constant, nested hash structure for use both in the class and outside. How to?
You can also do this entirely with builtins:
package Foo;
use constant MY_CONST =>
{
'foo' => 'bar',
'baz' => {
'innerbar' => 'bleh',
},
};
sub some_method
{
# presumably $a is defined somewhere else...
# or perhaps you mean to dereference a parameter passed in?
# in that case, use ${$_[0]} = MY_CONST->{foo} and call some_method(\$var);
$a = MY_CONST->{foo};
}
package Main; # or any other namespace that isn't Foo...
# ...
my $b = Foo->MY_CONST->{baz}{innerbar};
You can use the Hash::Util module to lock and unlock a hash (keys, values, or both).
package Foo;
use Hash::Util;
our %MY_CONST = (
foo => 'bar',
baz => {
innerbar => 'bleh',
}
);
Hash::Util::lock_hash_recurse(%MY_CONST);
Then in some other file:
use Foo;
my $b = $Foo::MY_CONST{baz}{innerbar};
See Readonly:
#!/usr/bin/perl
package Foo;
use strict;
use warnings;
use Readonly;
Readonly::Hash our %h => (
a => { b => 1 }
);
package main;
use strict;
use warnings;
print $Foo::h{a}->{b}, "\n";
$h{a}->{b} = 2;
Output:
C:\Temp> t
1
Modification of a read-only value attempted at C:\Temp\t.pl line 21
Here is a guide to hashes in perl. Hash of Hashes
Related
I try to eval output of Dumper for pretty simple hashref, where two keys have same value (ref to another hash):
#!/usr/bin/env perl
use strict; use warnings;
use Data::Dumper;
my $foo = { data => 1 };
my $boo = {
x => $foo,
y => $foo,
};
my $VAR1;
my $bar = eval( Dumper( $boo ) );
print Dumper( $boo );
print Dumper( $bar );
I expect the $boo and $bar to have same structure, but eval seems not solve inner-ref $VAR1->{'x'} correctly, I hoped last 2 lines to print same string:
$VAR1 = {
'x' => {
'data' => 1
},
'y' => $VAR1->{'x'}
};
But second has x or y undefined (depending which was referenced in literal form):
$VAR1 = {
'x' => {
'data' => 1
},
'y' => undef
};
I tried simple usage part on doc, and it gave fine results with much more complex structure (no strict, yet), but I can' accomplish it with my data with 2 references to same hash.
What am I missing here?
To correctly capture references inside a structure, you need to set the Purity flag (see the Data::Dumper documentation for details).
$Data::Dumper::Purity = 1;
It's not enough, though, as Dumper($boo) will now return
$VAR1 = {
'y' => {
'data' => 1
},
'x' => {}
};
$VAR1->{'x'} = $VAR1->{'y'};
So, you can't just eval this string, you also need to return $VAR1 from it.
To prevent the purity flag interfering with other parts of the code, you can set it locally:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
my $foo = { data => 1 };
my $boo = {
x => $foo,
y => $foo,
};
my $VAR1;
my $bar = do {
local $Data::Dumper::Purity = 1;
eval Dumper( $boo );
$VAR1
};
print Dumper( $boo );
print Dumper( $bar );
I have created this simple subroutine.
use List::Util qw(pairmap);
sub pairGroupBy(&#) {
my($irCode, #iaItems) = #_;
my %laResult = ();
pairmap {
my $lsKey = $irCode->();
if (!defined($lsKey)) {
die "Trying to pairGroup by nonexisting key '$lsKey'";
}
push #{$laResult{$lsKey}}, $a => $b;
} #iaItems;
return %laResult;
}
It works well until the subroutine is used from the same file where it is defined. When I move it to some package then variables $a and $b becomes undefined inside the $irCode->() callback.
I have learned from the List::Util source code that this code do the trick:
my $caller = caller;
local(*{$caller."::a"}) = \my $a;
local(*{$caller."::b"}) = \my $b;
So I'have modified my subroutine in this way:
use List::Util qw(pairmap);
sub pairGroupBy(&#) {
my($irCode, #iaItems) = #_;
my $caller = caller;
my %laResult = ();
pairmap {
no strict 'refs';
local(*{$caller."::a"}) = \$a; # <---- the line 96
local(*{$caller."::b"}) = \$b;
my $lsKey = $irCode->();
if (!defined($lsKey)) {
die "Trying to pairGroup by nonexisting key '$lsKey'";
}
push #{$laResult{$lsKey}}, $a => $b;
} #iaItems;
return %laResult;
}
But I need to use the no strict 'refs'; line (the List::Util source code does not use it). Otherwise the error message appears:
Can't use string ("main::a") as a symbol ref while "strict refs" in use at /home/.../bin/SatFunc.pm line 96.
My question is: Is there some better way how to define $a and $b variables in the caller's context without using no strict 'refs';?
I want my function will be used in the same way as pairmap, pairgrep etc.
EDIT:
#simbabque asked for an example, how the function is used. So this is an example:
my %laHoH = (
aa => {
color => 'yellow',
item => 'sun',
active => 1
},
bb => {
color => 'blue',
item => 'sky',
active => 1
},
cc => {
color => 'green',
item => 'grass',
active => 0
},
dd => {
color => 'blue',
item => 'watter',
active => 1
}
);
my %laGrouped = pairGroupBy {
$b->{color}
} pairgrep {
$b->{active}
} %laHoH;
The function then returns this structure:
{
'yellow' => [
'aa',
{
'color' => 'yellow',
'item' => 'sun',
'active' => 1
}
],
'blue' => [
'dd',
{
'active' => 1,
'item' => 'watter',
'color' => 'blue'
},
'bb',
{
'color' => 'blue',
'item' => 'sky',
'active' => 1
}
]
};
I'm not sure why you're seeing that problem, but I suspect you're overthinking matters. Using pairmap in void context like that seems a bad idea.
Can't you just convert your array into a hash and then iterate across that?
my %iaItemsHash = #iaItams;
while (my ($k, $v) = each %iaItemsHash) {
my $lsKey = $irCode->();
if (!defined($lsKey)) {
die "Trying to pairGroup by nonexisting key '$lsKey'";
}
push #{$laResult{$lsKey}}, $k => $v;
}
Update: In light of your comment, I've re-read your original question and spotted that you are talking about accessing the variables with the $irCode->() call.
The problem with my solution is that $k and $v are lexical variables and, therefore, aren't available outside of their lexical scope (this is generally seen as a feature!) The solution is to resort to good programming practice and to send the values into the subroutine as parameters.
Is there some better way how to define $a and $b variables in the caller's context without using no strict 'refs';?
You're asking us how to perform symbolic dereferences while asking Perl to prevent you from symbolic deferences. There's no reason to do that. If you want to perform symbolic dereferences, don't ask Perl to prevent you from doing it.
Even if Perl doesn't catch you doing it (i.e. if you manage to find a way to not trigger use strict qw( refs );), you'll still be using symbolic dereferences! You'd just be lying to yourself and to your readers.
Instead, it's best to document what you are doing. Use no strict qw( refs ); to signal that you are using doing something use strict qw( refs ); is suppose to block.
The following approach for building the same structure as your code is much less wasteful:
my %laGrouped;
for my $key (keys(%laHoH)) {
my $rec = $laHoH{$key};
next if !$rec->{active};
push #{ $laGrouped{ $rec->{color} } }, $key, $rec;
}
But let's improve the structure as well. The following approach produces a structure that's easier to use:
my %laGrouped;
for my $key (keys(%laHoH)) {
my $rec = $laHoH{$key};
next if !$rec->{active};
$laGrouped{ $rec->{color} }{$key} = $rec;
}
If you find yourself using pairGroupBy, you've probably went wrong somewhere. But here's a better implementation of it for educational purposes:
sub pairGroupBy(&#) {
my $cb = shift;
my $caller = caller;
my $ap = do { no strict 'refs'; \*{ $caller.'::a' } }; local *$ap;
my $bp = do { no strict 'refs'; \*{ $caller.'::b' } }; local *$bp;
my %groups;
while (#_) {
*$ap = \shift;
*$bp = \shift;
my $group = $cb->();
push #{ $groups{$group} }, $a, $b;
}
return %groups;
}
I want to be able to have a Moo* class with these characteristics:
an object's attribute can store a reference to the object itself
that attribute will be type-constrained using a Type::Tiny type so the reference must be of the right type
the class must function when it is immutable, and the attribute is "required", i.e. an undefined value is unacceptable and it cannot be updated later
E.g.
package GraphQLType;
use Moo;
use Types::Standard -all;
has [qw(children)] => (
is => 'rwp',
isa => ArrayRef[InstanceOf['GraphQLType']],
required => 1,
);
package main;
my $type;
$type = GraphQLType->new(children => [$type]);
The above presents a chicken-and-egg problem: $type will be undefined and therefore fail the type constraint.
A pattern used in graphql-js is "thunking". In Perl terms:
package GraphQLType;
use Moo;
use Types::Standard -all;
has [qw(children)] => (
is => 'rwp',
isa => CodeRef | ArrayRef[InstanceOf['GraphQLType']],
required => 1,
);
package main;
my $type;
$type = GraphQLType->new(children => sub { [$type] });
While that works for the specific type there, how can I have a parameterised type that implements something like this? Also, it will help even more if this can hook into the "lazy" functionality to minimise the code involved in storing the computed value.
package Thunking;
use Moo;
use Types::Thunking -all;
use Types::Standard -all;
has [qw(children)] => (
is => 'lazy',
isa => Thunk[ArrayRef[InstanceOf['GraphQLType']]],
required => 1,
);
Two issues need to be dealt with here: a parameterised Type::Tiny type constraint for a delayed-computation immutable attribute (DCIA), and an actually-functioning DCIA.
Parameterised type
Since this is Perl, there is more than one way to do this. The heart of making a parameterised type in Type::Tiny is to provide a constraint_generator parameter. The most idiomatic way to do this, using only Type::Tiny components, is:
package Types::Thunking;
use Types::TypeTiny -all;
use Type::Library -base;
use Type::Utils -all;
declare "Thunk", constraint_generator => sub { union [ CodeLike, #_ ] };
That's it! If no parameters are given, it works just like a CodeLike. The libraries can take care of any "inline" code generating.
The reason it can be so short is that the constraint_generator must return either a code-ref, which would probably be a closure that captures the parameters passed to it (see below), or simply a Type::Tiny - in which case the other parameterisability parameters are not needed. Since union (which looks like it's normally intended for producing arguments to a declare) returns a suitably-constructed Type::Tiny::Union, it just drops in perfectly.
A more spelled-out version, not using a union type (and for brevity, using CodeRef not CodeLike:
package Types::Thunking;
use Types::Standard -all;
use Type::Library -base;
use Type::Utils -all;
declare "Thunk",
constraint_generator => sub {
my ($param) = #_;
die "parameter must be a type" if grep !UNIVERSAL::isa($_, 'Type::Tiny'), #_;
return sub { is_CodeRef($_) or $param->check($_) };
},
inline_generator => sub {
my ($param) = #_;
die "parameter must be a type" if grep !UNIVERSAL::isa($_, 'Type::Tiny'), #_;
return sub {
my ($constraint, $varname) = #_;
return sprintf(
'Types::Standard::is_CodeRef(%s) or %s',
$varname,
$param->inline_check($varname),
);
};
};
This is the "harness" I used for testing these:
#!/usr/bin/perl
use Thunking;
sub do_test {
use Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0;
my ($args, $should_work) = #_;
my $l = eval { Thunking->new(#$args) };
if (!$l) {
say "correctly did not work" and return if !$should_work;
say "INcorrectly did not work" and return if $should_work;
}
my $val = eval { $l->attr };
if (!$val) {
say "correctly did not work" and return if !$should_work;
say "INcorrectly did not work" and return if $should_work;
}
say(($should_work ? "" : "INcorrectly worked: "), Dumper $val);
}
do_test [attr => { k => "wrong type" }], 0;
do_test [attr => ["real value at init"]], 1;
do_test [attr => sub { [ "delayed" ] }], 1;
do_test [attr => sub { { k => "delayed wrong type" } }], 0;
Delayed-computation immutable attribute
In order to make this immutable, we want setting the attribute to fail unless it's us doing it. When reading the attribute, we want to see whether there is computation to be done; if yes, do it; then return the value.
Naive approach
package Thunking;
use Moo;
use Types::Standard -all;
use Types::Thunking -all;
has attr => (
is => 'rwp',
isa => Thunk[ArrayRef],
required => 1,
);
before 'attr' => sub {
my $self = shift;
return if #_; # attempt at setting, hand to auto
my $value = $self->{attr};
return if ref($value) ne 'CODE'; # attempt at reading and already resolved
$self->_set_attr($value->());
}
The before should be fairly self-explanatory but you will see it manually looks in the object's hash-ref, which is usually a clue that your programming is not finished yet. Also, it's rwp and requires the before in the class, which is far from pretty.
Using MooX modules
An approach that tries to generalise this with a separate module, MooX::Thunking. First, another module to encapsulate overriding of Moo functions:
package MooX::Utils;
use strict;
use warnings;
use Moo ();
use Moo::Role ();
use Carp qw(croak);
use base qw(Exporter);
our #EXPORT = qw(override_function);
sub override_function {
my ($target, $name, $func) = #_;
my $orig = $target->can($name) or croak "Override '$target\::$name': not found";
my $install_tracked = Moo::Role->is_role($target) ? \&Moo::Role::_install_tracked : \&Moo::_install_tracked;
$install_tracked->($target, $name, sub { $func->($orig, #_) });
}
Now the thunking MooX module itself, which uses the above to override has:
package MooX::Thunking;
use MooX::Utils;
use Types::TypeTiny -all;
use Class::Method::Modifiers qw(install_modifier);
sub import {
my $target = scalar caller;
override_function($target, 'has', sub {
my ($orig, $name, %opts) = #_;
$orig->($name, %opts), return if $opts{is} ne 'thunked';
$opts{is} = 'ro';
$orig->($name, %opts); # so we have method to modify
install_modifier $target, 'before', $name => sub {
my $self = shift;
return if #_; # attempt at setting, hand to auto
my $value = $self->{$name};
return if !eval { CodeLike->($value); 1 }; # attempt at reading and already resolved
$self->{$name} = $value->();
$opts{isa}->($self->{$name}) if $opts{isa}; # validate
}
});
}
This applies "thunking" to an attribute. It will only function if the attribute is ro, and will quietly resolve any CodeLike values on reading. It can be used like this:
package Thunking;
use Moo;
use MooX::Thunking;
use Types::Standard -all;
use Types::Thunking -all;
has attr => (
is => 'thunked',
isa => Thunk[ArrayRef],
);
Using BUILDARGS and lazy
An alternative approach, suggested by the mighty #haarg:
package MooX::Thunking;
use MooX::Utils;
use Types::TypeTiny -all;
use Class::Method::Modifiers qw(install_modifier);
sub import {
my $target = scalar caller;
override_function($target, 'has', sub {
my ($orig, $name, %opts) = #_;
$orig->($name, %opts), return if $opts{is} ne 'thunked';
$opts{is} = 'lazy';
my $gen_attr = "_gen_$name";
$orig->($gen_attr => (is => 'ro'));
$opts{builder} = sub { $_[0]->$gen_attr->(); };
install_modifier $target, 'around', 'BUILDARGS' => sub {
my ($orig, $self) = (shift, shift);
my $args = $self->$orig(#_);
$args->{$gen_attr} = delete $args->{$name} if eval { CodeLike->($args->{$name}); 1 };
return $args;
};
$orig->($name, %opts);
});
}
It uses the built-in lazy mechanism, creating a builder that will call the supplied CodeLike if that is what is given. One important downside is that this technique does not work for Moo::Roles.
How do I increment a field in a Class::Struct object?
For now I am stuck with
use Class::Struct foo => [
counter => '$',
];
my $bar = foo->new(counter => 5);
$bar->counter($bar->counter()+1);
I wonder if there is something more expressive than the last line (the obvious $bar->counter++ results in Can't modify non-lvalue subroutine call).
EDIT: of course, I am not interested in $bar->[0]++ et al - what if I add a field before counter? I don't want to have to hunt my code for all such "bugs-in-waiting".
You can add an increment method to foo:
#!/usr/bin/env perl
package foo;
use strict; use warnings;
sub increment_counter {
my $self = shift;
my $val = $self->counter + 1;
$self->counter($val);
return $val;
}
package main;
use 5.012;
use strict;
use warnings;
use Class::Struct foo => [
counter => '$',
];
my $bar = foo->new(counter => 5);
$bar->increment_counter;
say $bar->counter;
__END__
Alternatively, try doing this :
use strict; use warnings;
use Class::Struct foo => [
counter => '$',
];
my $bar = foo->new(counter => 5);
print ++$bar->[0];
or using a SCALAR ref (no need to hard-code the "path" like the previous snippet) :
use strict; use warnings;
$\ = "\n";
use Class::Struct foo => [
counter => '*$',
];
my $bar = foo->new(counter => 5);
print ++${ $bar->counter };
I have a list of functions in Perl. Example:
my #funcs = qw (a b c)
Now they all belong to this module Foo::Bar::Stix. I would like to call them iteratively in a loop:
foreach $func (#funcs) {
Foo::Bar::Stix::$func->(%args)
}
where args is a hash of arguments. However I keep getting this error: "Bad name after :: ..." at the line which contains Foo::Bar::Stix::$func->(%args) How do I fix this error?
a b and c are not function objects but strings
Rather than storing the names of the functions in your array, store references to them in a hash so that you can refer to them by name. Here's a simple code example:
#!/usr/bin/perl
use strict;
use warnings;
my %func_refs = (
'a' => \&Foo::Bar::Stix::a,
'b' => \&Foo::Bar::Stix::b,
'c' => \&Foo::Bar::Stix::c
);
foreach my $func_ref ( values %func_refs ) {
print $func_ref->( "woohoo: " ), "\n";
}
{
package Foo::Bar::Stix;
sub a {
my $arg = shift;
return $arg . "a";
}
sub b {
my $arg = shift;
return $arg . "b";
}
sub c {
my $arg = shift;
return $arg . "c";
}
}
If you're stuck with storing the names for some reason, try this:
my $package = "Foo::Bar::Stix";
my #func_names = qw/ a b c /;
foreach my $func_name (#func_names) {
my $str = &{ "$package\::$func_name" }( "woohoo: " );
print $str, "\n";
}
However, this doesn't work under use strict, and because of this I prefer the first solution. Whatever you do, try to avoid using eval. It's unnecessary, and will likely only cause you problems.
Also, most people who work with Perl capitalize it as Perl rather than PERL. Here's a Stackoverflow question on the subject:
How should I capitalize Perl?
Bad answer: use a symbolic reference:
for $func (#funcs) {
&{"Foo::Bar::Stix::$func"}(\%args);
}
Good answer: use a dispatch table:
my %call_func = (
'a' => \&Foo::Bar::Stix::a,
'b' => \&Foo::Bar::Stix::b,
'c' => \&Foo::Bar::Stix::c,
);
...
for $func (#funcs) {
$call_func{$func}->(\%args);
}
Slight change of syntax will give you what you want
Foo::Bar::Stix->$func(%args)
Though this will pass the package name as the first parameter.
You can use can
my #funcs = qw (a b c)
foreach $func (#funcs) {
Foo::Bar::Stix->can($func)->(%args)
}
You could access it through the special %Foo::Bar::Stix:: variable. This gives full access directly to the symbol table. You'll also notice that it works under strict mode.
#! /usr/bin/env perl
use strict;
use warnings;
{
package Foo::Bar::Stix;
sub a{ print "sub a\n" }
sub b{ print "sub b\n" }
sub c{ print "sub c\n" }
}
my #funcs = qw' a b c ';
my %args;
for my $func (#funcs) {
$Foo::Bar::Stix::{$func}->(%args); # <====
}
Another option:
my $symbol_table = $::{'Foo::'}{'Bar::'}{'Stix::'};
my %funcs = (
# we only want the CODE references
'a' => *{ $symbol_table->{'a'} }{'CODE'},
'b' => *{ $symbol_table->{'b'} }{'CODE'},
'c' => *{ $symbol_table->{'c'} }{'CODE'},
);
for my $func (#funcs) {
$funcs{$func}->(%args); # <====
}
If you are going to be doing that for a large number of subroutines, this is how I would load up the %funcs variable.
my %funcs;
BEGIN{
my $symbol_table = $::{'Foo::'}{'Bar::'}{'Stix::'};
for my $name (qw' a b c '){
$funcs{$name} = *{ $symbol_table->{$name} }{'CODE'};
}
}
I wouldn't do this unless you need the subroutines to have both a fully qualified name, and access to it through a hash variable.
If you only need access to the subroutines through a hash variable this is a better way to set it up.
my %funcs = (
'a' => sub{ print "sub a\n" },
'b' => sub{ print "sub b\n" },
'c' => sub{ print "sub c\n" },
);
Note: you could replace "my %funcs" with "our %funcs"