Locally change an attribute of a class in Perl - perl

I have come across an odd problem in one of my Perl scripts. I have a Perl object. Within a certain scope I want one of the objects attributes to be changed, but I want the attribute to be restored to it's old value after it leaves the scope.
Example:
my $object = Object->new('name' => 'Bob');
{
# I know this doesn't work, but it is the best way
# I can represent what I amd trying to do.
local $object->name('Lenny');
# Prints "Lenny"
print $object->name();
}
# Prints "Bob"
print $object->name();
Is there a way to achieve something like this?

This might not be as much encapsulation as you were asking for, but you can local-ize an attribute of a hash. This outputs "CarlLennyCarl"
sub Object::new { bless { _name => $_[1] }, $_[0] } }
sub Object::name { $_[0]->{_name} }
my $obj = Object->new("Carl");
print $obj->name;
{
local $obj->{_name} = "Lenny";
print $obj->name;
}
print $obj->name;
You could also local-ize the entire method. This also outputs "CarlLennyCarl":
sub Object::new { bless { _name => $_[1] }, $_[0] } }
sub Object::name { $_[0]->{_name} }
my $obj = Object->new("Carl");
print $obj->name;
{
local *Object::name = sub { "Lenny" };
print $obj->name;
}
print $obj->name;

I was completely misunderstanding what was occurring there. You cannot use local on subroutine calls, that is the issue you are having.
Lets use a code example from one that I know works and try to explain what eval is actually doing.
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Cwd;
print getcwd() . "\n";
eval{
local #INC = ('/tmp');
require 'test.pl';
print 'local: ' . Dumper(\#INC);
};
print Dumper(\#INC);
That works because I am modifying a variable, not calling on another subroutine to modify my variable.
In order for it to work as you are expecting, you would have to create a deep copy of the object to modify in local scope or something of the sort. (which I'm pretty sure is what is occurring in the first place)
local creates scope for the given brackets, eval, OR file (your problem there)
If you were able to access the elements directly without the method call (bad practice IMHO) you would likely be able to localize the scope of that element in the object.
Example:
name.pm:
package name;
use strict;
use warnings;
{
sub new {
my ($class,$name) = #_;
my $self = bless {}, $class;
$self->{'name'} = $name if defined $name;
return $self;
}
sub name
{
my ($self,$name) = #_;
$self->{'name'} = $name if defined $name;
return $self->{'name'};
}
}
index.pl:
#!/usr/bin/perl -w
use strict;
use warnings FATAL => 'all';
use name;
my $obj = name->new('test');
print $obj->{'name'} . "\n";
{
local $obj->{'name'} = 'test2';
print $obj->{'name'} . "\n";
}
print $obj->{'name'} . "\n";

Related

Generating a subroutine reference from a string

I'm creating a dispatch table:
my $dispatch = {
'do_this' => \&do_this,
'do_that' => \&do_that,
'do_something' => \&do_something,
'do_something_else' => \&do_something_else,
};
Instead of typing in the same string of chars for the key and the value, I'd like to do this:
my $dispatch_values = ['do_this', 'do_that', 'do_something', 'do_something_else'];
my $dispatch = generate_dispatch_table($dispatch_values);
sub generate_dispatch_table {
my $values = shift;
my $table = {};
foreach $value (#$values) {
$table{$value} = #WHAT GOES HERE?
}
return $table;
}
I don't know how to generate a subroutine reference from a string, though.
Just use \&{ $sub_name }:
#! /usr/bin/perl
use warnings;
use strict;
sub hi { print "Hi\n" }
sub bye { print "Bye\n" }
my %dispatch = map { $_, \&{$_} } qw(hi bye);
chomp(my $action = <>);
$dispatch{$action}->();
Alternatives include:
use an object.
use a package.
For an object, it's pretty much exactly what you're used to:
#! /usr/bin/perl
package Foo;
use warnings;
use strict;
sub hi { print "Hi\n" }
sub bye { print "Bye\n" }
sub new { bless {} }
package main;
my $dispatcher = Foo->new;
chomp(my $action = <>);
$dispatcher->$action();
Of course, one should check if you can do the action, but we're omitting some basic checks here.
Another good check is to not use the action as is, but to use a prefix that indicates it's dispatchable in case you have other non-dispatch methods in the object:
#! /usr/bin/perl
package Foo;
use warnings;
use strict;
sub do_hi { print "Hi\n" }
sub do_bye { print "Bye\n" }
sub new { bless {} }
package main;
my $dispatcher = Foo->new;
chomp(my $action = <>);
$action = "do_" . $action;
$dispatcher->$action();
The only difference is the do_ prefix, but now the caller can't call new through the dispatcher. Otherwise, it's the same - this dispatcher will dispatch hi and bye like choroba's answer.
Remember, of course, that $self is the first parameter, if you're passing in parameters at all.
Doing this via packages is almost the same:
#! /usr/bin/perl
package Foo;
use warnings;
use strict;
sub do_hi { print "Hi\n" }
sub do_bye { print "Bye\n" }
package main;
chomp(my $action = <>);
$action = 'do_' . $action;
Foo->$action();
Here, the first parameter is, of course, "Foo". We also don't need an object, so no constructor required.
However, you can take this and apply it directly to your original question and avoid some of the extra sigils. Just remove the package declarations, and change Foo->$action() to __PACKAGE__->$action() even in the default (main) package. But, if you don't want to have the package name being passed in, we take this just a tiny step further:
sub do_hi { print "Hi\n" }
sub do_bye { print "Bye\n" }
chomp(my $action = <>);
$action = 'do_' . $action;
__PACKAGE__->can($action)->();
TMTOWTDI. Pick the one that makes the most sense to you and your code layout. Sometimes I use the object model, sometimes another one.

Passing hashes from a package to a method in another package and manipulating it in Perl

I have two packages. There is one hash in one package. I want to pass this hash to a method in another package, manipulate it and see the results in the previous package. Here's my code:
{
package Statistical_Analysis;
use Moose;
our $data;
our $ref;
our $k;
our $v;
sub countUseCase
{
my ($self, $value, $hash) = #_;
print "Passed value: ".$value."\n";
print "Hash Address: ".$hash."\n";
$self->{ref} = $hash;
$self->{%$ref}{'country'} = "something";
#print "IP Address: ".$self->{data}."\n";
#print "Hash Value: ".$self->{ref{'ip_count'}}."\n";
}
}
{
package Parse;
use Moose;
our %ip_address;
sub getFields
{
our $stanalyze_obj = Statistical_Analysis->new();
my $ref = \%ip_address;
$stanalyze_obj->countUseCase($ref);
dispHashMap();
}
sub dispHashMap
{
print \%ip_address."\n";
while ( my ($k,$v) = each %ip_address )
{
print "$k => $v\n";
}
}
But I cant see the changes in the hash. Any help?
You don't see any change because you never change it. Since it makes no sense, I presume you meant to change the $ip_address{country} when you do
$self->{%$ref}{'country'} = 'something';
If so, that should be
$hash->{country} = 'something';
Of course, $hash is stored in $self->{ref}, so you could also use
$self->{ref}->{country} = 'something';
which can be shortened to
$self->{ref}{country} = 'something';
PS — What's with all the our variables? You should almost never have to use our. #ISA and #EXPORT_OK are about the only uses I can think of. All of those should be my.
PSS — Actually, almost none of those should exist at all. What's with declaring variables you don't even use? One of these declarations is making your error a lot less obvious.
It seems that you called countUseCase with only one parameter, $ref. Calling that method with only one parameter, causes $hash to be undef.

How to dynamically load modules and execute methods in perl

I'm following up on this question about perl web services. I've managed to get modules loading and executing from a main program. Each of the modules is something like this:
#!/usr/bin/perl
package NiMbox::perlet::skeleton;
use strict;
use warnings;
require Exporter;
our #ISA = qw(Exporter);
our #EXPORT_OK = qw(%DEFINITION main secondary);
our %DEFINITION;
$DEFINITION{'main'} = {
summary => 'skeleton main',
description => 'long skeleton main description',
args => { 'box' => {}, 'other' => {} }
};
$DEFINITION{'secondary'} = {
summary => 'skeleton secondary',
description => 'long skeleton secondary description'
};
sub main {
print "main...\n";
}
sub secondary {
print "secondary...\n"
}
1;
And invocation of these modules can then be done like this:
use NiMbox::perlet::skeleton;
my %DEFINITION = %NiMbox::perlet::skeleton::DEFINITION;
foreach my $s (keys %DEFINITION) {
print "calling sub '$s'\n";
NiMbox::perlet::skeleton->$s();
}
How would I get rid of the direct invocation of NiMbox::perlet:skeleton in a way in which I could do something that looks like this (which does not work but illustrates what I need to do):
my $perlet = 'skeleton';
use NiMbox::perlet::$perlet;
my %DEFINITION = %NiMbox::perlet::$perlet::DEFINITION;
foreach my $s (keys %DEFINITION) {
print "calling sub '$s'\n";
NiMbox::perlet::$perlet->$s();
}
Since I'm very close I would rather see what is missing in this example rather than use another library. Any ideas?
If you want to make the class name dynamic, you can do something like this:
my $class = 'NiMbox::perlet::' . $perlet;
my $class_file = $class;
$class_file =~ s{::}{/};
$class_file .= '.pm';
require $class_file;
$class->import;
(Or even better, use Module::Load as #Schwern suggests.
Getting the %DEFINITION class is a bit tricky since it would involve symbolic references. A better way would be to provide a class method that returns it, e.g.
package NiMbox::perlet::skeleton;
...
sub definition {
my %definition;
$definition{main} = { summary => 'skeleton main', ... };
return %definition;
}
Then you could do something like:
my %DEFINITION = $class->definition;
foreach my $s( keys %DEFINITION ) {
print "calling sub '$s'\n";
$class->$s;
}
I believe what you're looking for is Exporter or its many follow on modules. I see you're already using it in your module, but you're not using it to get %DEFINITION. You'd do that like so:
use NiMbox::perlet::skeleton qw(%DEFINITION);
foreach my $s (keys %DEFINITION) {
print "calling sub '$s'\n";
NiMbox::perlet::skeleton->$s();
}
That aliases %NiMbox::perlet::skeleton::DEFINITION to %DEFINITION and saves a bunch of typing.
To be able to use a variable definition of %DEFINITION you could use "symbolic references" to refer to the variable by name... but those are fraught with peril. Also, exporting global variables means you can only have one at a time in a given namespace. We can do better.
What I would suggest is instead changing the %DEFINITION hash into the definition() class method which returns a reference to %DEFINITION. You could return a hash, but the reference avoids wasting time copying.
package NiMbox::perlet::skeleton;
use strict;
use warnings;
my %DEFINITION = ...;
sub definition {
return \%DEFINITION;
}
Now you can call that method and get the hash ref.
use NiMbox::perlet::skeleton;
my $definition = NiMbox::perlet::skeleton->definition;
foreach my $s (keys %$definition) {
print "calling sub '$s'\n";
NiMbox::perlet::skeleton->$s();
}
Doing it dynamically, the only trick is to load the class. You can eval "require $class" or die $# but that has security implications. UNIVERSAL::require or Module::Load can handle that better for you.
use Module::Load;
my $class = 'NiMbox::perlet::skeleton';
load $class;
my $definition = $class->definition;
foreach my $s (keys %$definition) {
print "calling sub '$s'\n";
$class->$s();
}

returning a lazily-computed scalar, in perl

I'm trying to add some functionality to our code base by using tied scalars.
We have a function which is specified to return scalars. I thought I could add some features to the system by tie-ing these scalars before returning them, but it looks like the FETCH method is called just before the return, which results in an untied scalar being returned.
Is there any way around this?
I really want to keep the subroutine's interface (returning scalars) intact if it's at all possible.
use strict;
use warnings;
main();
sub GetThing{
my $thing;
tie $thing, 'mything', #_;
return $thing;
}
sub main {
my %m;
$m{pre} = GetThing('Fred');
print "1\n";
print $m{pre};
print "2\n";
print $m{pre};
print "3\n";
}
package mything;
require Tie::Scalar;
my #ISA = qw(Tie::StdScalar);
sub TIESCALAR {
my $class = shift;
bless {
name => shift || 'noname',
}, $class;
}
sub FETCH {
my $self = shift;
print "ACCESS ALERT!\n";
return " NAME: '$self->{name}'\n";
}
Desired output:
1
ACCESS ALERT!
NAME: 'Fred'
2
ACCESS ALERT!
NAME: 'Fred'
3
I can get the desired output by returning a reference, and dereferencing on each access, but that ruins our established interface, and makes it more confusing for our users.
--Buck
As DVK said, tie applies to containers, so isn't useful for returned values.
For that, you use overloading. An example (not all the possible overloaded operations are supplied; see http://perldoc.perl.org/overload.html#Minimal-set-of-overloaded-operations):
use strict;
use warnings;
main();
sub GetThing{
my $thing;
$thing = "mything"->new(#_);
return $thing;
}
sub main {
my %m;
$m{pre} = GetThing('Fred');
print "1\n";
print $m{pre};
print "2\n";
print $m{pre};
print "3\n";
}
package mything;
use overload 'fallback' => 1, '""' => 'FETCH';
sub new {
my $class = shift;
bless {
name => shift || 'noname',
}, $class;
}
sub FETCH {
my $self = shift;
print "ACCESS ALERT!\n";
return " NAME: '$self->{name}'\n";
}
As mentioned in other answers, tie applies to containers, and not to values, so there is no way to assign a tied variable to another variable and retain the tied properties.
Since assignment is out, you need to pass the container into the GetThing routine. You can do this by reference as follows:
use strict;
use warnings;
main();
sub GetThing{
tie ${$_[1]}, 'mything', $_[0];
}
sub main {
my %m;
GetThing('Fred' => \$m{pre});
print "1\n";
print $m{pre};
print "2\n";
print $m{pre};
print "3\n";
}
package mything;
require Tie::Scalar;
my #ISA = qw(Tie::StdScalar);
sub TIESCALAR {
my $class = shift;
bless {
name => shift || 'noname',
}, $class;
}
sub FETCH {
my $self = shift;
print "ACCESS ALERT!\n";
return " NAME: '$self->{name}'\n";
}
which produces the correct output.
However, if you want to retain the assignment, you will need to use overloading, which applies to values (actually to objects, but they themselves are values). Without more detail on your intended purpose it is hard to give a complete answer, but this will meet your stated requirements:
use strict;
use warnings;
main();
sub GetThing{
return mything->new( shift );
}
sub main {
my %m;
$m{pre} = GetThing('Fred');
print "1\n";
print $m{pre};
print "2\n";
print $m{pre};
print "3\n";
}
package mything;
sub new {
my $class = shift;
bless {
name => shift || 'noname',
}, $class;
}
use overload '""' => sub { # '""' means to overload stringification
my $self = shift;
print "ACCESS ALERT!\n";
return " NAME: '$self->{name}'\n";
};
Both ties and overloads can get complicated, so read through all of the documentation if anything is not clear.
First, the exact method of doing what you are proposing seems technically impossible:
Tied variables have the tie attached to the variable itself, not to its value.
In Perl, subroutine's return values are returned by value, meaning you take the value passed to return, access it (in you case, accessing the tied variable and calling FETCH in the process) - and then copy that value! Which means that what the caller gets is a scalar VALUE, not a scalar variable (tied or untied).
Your confusion, in short, seems to stem from mixing together variables (locations in program's symbol table) and values stored in those variables.
Second, you were somewhat unclear as to what exactly you are trying to achieve, so it's hard to propose how to achieve what you want. But assuming, based on your description, that you wanted to call some method upon subroutine's return (possibly passing it the return value), you CAN do that.
To do so, you need to employ what fancy people call aspect programming. The politically (and technically) correct way of doing it in Perl is by using Moose.
However, you can DIY it, by basically replacing the original method with a wrapper method.
The exact mechanics of both Moose and DIY approaches can be seen in the first two answers to the following SO question, so I won't copy/paste them here, hope you don't mind:
Simulating aspects of static-typing in a duck-typed language
If you're feeling adventurous, you could also use the Scalar::Defer module which provides a general-purpose mechanism for a scalar variable to compute a value lazily, either once or on each access.

Deferring code on scope change in Perl

I often find it useful to be able to schedule code to be executed upon leaving the current scope. In my previous life in TCL, a friend created a function we called defer.
It enabled code like:
set fp [open "x"]
defer("close $fp");
which was invoked when the current scope exited. The main benefit is that it's always invoked no matter how/where I leave scope.
So I implemented something similar in Perl but it seems there'd be an easier way. Comments critiques welcome.
The way I did it in Perl:
create a global, tied variable which holds an array of subs to be executed.
whenever I want to schedule a fn to be invoked on exit, I use local to change the array.
when I leave the current scope, Perl changes the global to the previous value
because the global is tied, I know when this value change happens and can invoke the subs in the list.
The actual code is below.
Is there a better way to do this? Seems this would be a commonly needed capability.
use strict;
package tiescalar;
sub TIESCALAR {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
sub FETCH {
my $self = shift;
return $self->{VAL};
}
sub STORE {
my $self = shift;
my $value = shift;
if (defined($self->{VAL}) && defined($value)) {
foreach my $s (#{$self->{VAL}}) { &$s; }
}
$self->{VAL} = $value;
}
1;
package main;
our $h;
tie($h, 'tiescalar');
$h = [];
printf "1\n";
printf "2\n";
sub main {
printf "3\n";
local $h = [sub{printf "9\n"}];
push(#$h, sub {printf "10\n";});
printf "4\n";
{
local $h = [sub {printf "8\n"; }];
mysub();
printf "7\n";
return;
}
}
sub mysub {
local $h = [sub {printf "6\n"; }];
print "5\n";
}
main();
printf "11\n";
Well, your specific case is already handled if you use lexical filehandles (as opposed to the old style bareword filehandles). For other cases, you could always use the DESTROY method of an object guaranteed to go to zero references when it goes out of scope:
#!/usr/bin/perl
use strict;
use warnings;
for my $i (1 .. 5) {
my $defer = Defer::Sub->new(sub { print "end\n" });
print "start\n$i\n";
}
package Defer::Sub;
use Carp;
sub new {
my $class = shift;
croak "$class requires a function to call\n" unless #_;
my $self = {
func => shift,
};
return bless $self, $class;
}
sub DESTROY {
my $self = shift;
$self->{func}();
}
ETA: I like brian's name better, Scope::OnExit is a much more descriptive name.
Instead of using tie for this, I think I'd just create an object. You can also avoid the local that way too.
{
my $defer = Scope::OnExit->new( #subs );
$defer->push( $other_sub ); # and pop, shift, etc
...
}
When the variable goes out of scope, you have a chance to do things in the DESTROY method.
Also, in the example you posted, you need to check that the values you store are code references, and it's probably a good idea to check that the VAL value is an array reference:
sub TIESCALAR { bless { VAL => [] }, $_[0] }
sub STORE {
my( $self, $value ) = #_;
carp "Can only store array references!" unless ref $value eq ref [];
foreach { #$value } {
carp "There should only be code refs in the array"
unless ref $_ eq ref sub {}
}
foreach ( #{ $self->{VAL}} ) { $_->() }
$self->{VAL} = $value;
}
You may want to try out B::Hooks::EndOfScope
I Believe this works:
use B::Hooks::EndOfScope;
sub foo {
on_scope_end {
$codehere;
};
$morecode
return 1; # scope end code executes.
}
foo();
I think you want something like Scope::Guard, but it can't be pushed. Hmmm.
Thanks.
Trivially,
sub OnLeavingScope::DESTROY { ${$_[0]}->() }
used like:
{
...
my $onleavingscope = bless \sub { ... }, 'OnLeavingScope';
my $onleavingscope2 = bless \\&whatever, 'OnLeavingScope';
...
}
(The extra level of having a reference to a reference to a sub is necessary only to work around an optimization (that's arguably a bug) when using a non-closure anonymous sub.)