use methods in different modules in mod_perl handler - perl

I want to share a variable between different perl modules. So I created a perl module called MyCache.pm which saves the variable (in my case a hash variable):
package PerlModules::MyCache;
my %cache = ();
sub set {
my ($key, $value) = #_;
$cache{$key} = $value;
}
sub get {
my ($key) = #_;
return $cache{$key};
}
Now I have two handlers. The one handler will call the set method and the other one will call the get method to access the information.
package PerlModules::MyCacheSetter;
use Apache2::RequestRec();
use Apache2::RequestIO();
use Apache2::Const -compile => qw(OK);
use PerlModules::MyCache;
sub handler {
my $r = shift;
PerlModules::MyCache::set('test1', "true");
PerlModules::MyCache::set('test2', "false");
PerlModules::MyCache::set('test3', "true");
return Apache2::Const::OK;
}
And here is the getter handler:
package PerlModules::MyCacheGetter;
use Apache2::RequestRec();
use Apache2::RequestIO();
use Apache2::Const -compile => qw(OK);
use PerlModules::MyCache;
sub handler {
my $r = shift;
$r->print(PerlModules::MyCache::get('test1'));
$r->print(PerlModules::MyCache::get('test2'));
$r->print(PerlModules::MyCache::get('test3'));
return Apache2::Const::OK;
}
Now I've configured apache (via http.conf) to access these perl modules. I run the setter handler and then the getter, but there was no output.
In the error.log there are now some entries:
Use of uninitialized value in subroutine entry at ../MyCacheGetter.pm line 14.
Use of uninitialized value in subroutine entry at ../MyCacheGetter.pm line 15.
Use of uninitialized value in subroutine entry at ../MyCacheGetter.pm line 16.
This lines are the three calls of the get method. So what am I doing wrong? How can I fix the problem and share my cache variable between different handlers?

Your cache will only exist for the lifetime of a given Apache child process. If you want other processes to see it, you'll need to store it somewhere they can all get at it.
This is untested, but you can get the general idea: (Now tested).
EDIT: OK, it seems like you can get some issues with Storable depending on what perl version and Storable version you're running. I've replaced Storable with Data::Serialize in my example. I've also added a line to the get/set methods so that either the -> or :: syntax can be used.
package PerlModules::MyCache;
use IPC::ShareLite qw/:lock/;
use Data::Serializer;
use 5.10.0;
my $key = 1234; # Your shared memory key (you set this!)
my $ipc = IPC::ShareLite->new(
-key => $key,
-create => 'yes',
-destroy => 'no'
);
my $ser = Data::Serializer->new(
serializer => 'Data::Dumper'
);
sub set {
shift #_ if $_[0] eq __PACKAGE__;
my ($key, $value) = #_;
$ipc->lock(LOCK_EX);
my $frozen; eval { $frozen = $ipc->fetch; };
my $cache = defined($frozen) ? $ser->thaw($frozen) : {};
$cache->{$key} = $value;
$ipc->store($ser->freeze($cache));
$ipc->unlock;
return $value;
}
sub get {
shift #_ if $_[0] eq __PACKAGE__;
my ($key) = #_;
my $frozen; eval { $frozen = $ipc->fetch; };
my $cache = defined($frozen) ? $ser->thaw($frozen) : {};
return $cache->{$key};
}
sub clear {
shift #_ if $_[0] eq __PACKAGE__;
$ipc->store($ser->freeze({}));
return {};
}
1;
You might want to run PerlModules::MyCache->clear once before you test to ensure the correct structure of the cache storage.

Related

Can I inject a perl sub in a package?

I'd like to be able to "inject" methods in a class on the fly, similarly to what happens with Mojolicious helpers. Something like this:
my $s = SomeThing->new;
$s->helper(do_this => sub {
my $self = shift;
$foo = shift;
});
$s->do_this('bar');
I've made it some distance, but I would like the subs that get injected to be operating in the namespace of the class they get injected into, not in the main one. In other words this currently works as follows:
$s->do_this('bar');
print 'in main: ', $foo;
this prints "bar" - and I'd like it not to, while I'd like this
print 'in SomeThing: ', $SomeThing::foo;
to print "bar" instead
while this works but seems clunky to me
$s->helper(do_this => sub {
my $self = shift;
${(ref $self) . '::foo'} = shift;
});
$s->do_this('foo');
print 'in SomeThing: ', $SomeThing::foo; # now this prints "foo"
The package where all this happens looks like this:
package SomeThing {
use Mojo::Base -base;
use Carp;
sub helper {
my $self = shift;
my $name = shift || croak "The helper name is required";
my $sub = shift || sub {};
my $namespace = __PACKAGE__;
no strict 'refs';
{
*{"$namespace\::$name"} = $sub
}
}
};
Is there a way to do this? I suspect I'd be messing up strictness real bad - but I kind of don't want to give up just yet (and it'd be a nice trick to learn).
You are asking to change the package associated with an already-compiled anon sub for the purpose of variable lookups. I don't know if that's possible.
Even if it was possible, it's not something you want to do because your code still wouldn't work. You'd have to add use vars qw( foo ); to the file in which the sub { } literal is found. And that's in addition to using our $foo; or use vars qw( $foo ); in Something.pm if you accessed it there.
That's pretty magical and messy. And it's easily avoided by using accessors. Simple replace
$s->helper(
do_this => sub {
my $self = shift;
$foo = shift;
},
);
with
$s->helper(
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
If you also need to add the accessor, you can use the following:
$s->helper(
foo => sub {
shift;
state $foo;
$foo = shift if #_;
$foo
},
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
As an aside, monkey_patch from Mojo::Util can be used as a replacement for helper. (Credit to #brian d foy for bringing it up.) It does the same thing, but it has the two added benefits:
You don't need to support it.
It sets the name of the anon sub so that stack traces use a meaningful name instead of __ANON__.
Switching to monkey_patch doesn't address your problem, but I do recommend using it (or similar) in addition to the change of approach I mentioned above.
use Mojo::Util qw( );
sub helper { shift; Mojo::Util::monkey_patch(__PACKAGE__, #_); }
Consider roles.
# role module
package SomeThing::Role::Foo;
use Role::Tiny;
sub foo { 42 }
1;
# user
use strict;
use warnings;
use SomeThing;
use With::Roles;
my $something_with_foo = SomeThing->with::roles('+Foo');
# new subclass of SomeThing, doesn't affect other usage of SomeThing
my $obj = $something_with_foo->new;
# can also dynamically apply to an existing object
my $obj = SomeThing->new->with::roles('+Foo');
print $obj->foo;

Hook to provide a value for every Hash lookup in Perl

Is it possible to provide a hook in Perl to make sure no Hash key lookup fails ?
Example :
use strict;
use warnings;
my %hash_example = ( "a"=>"apple", "b"=>"ball" );
print $hash_example{"a"}; # Goes Fine.
print $hash_example{"c"}; # Throws Warning ( "Use of uninitialized value " ).
Codepad link
Whenever a hash lookup happens, some subroutine could get called which can provide a default value.
I mean, any hash lookup should call a sub ( say "get_hash_value (hash_ref, key) " ) and pass the hash and key to it. A sample of such a sub is shown below :
sub get_hash_value {
my $hash_ref = shift;
my $key = shift;
if ( exists $hash_ref->{$key} ) { # For Normal Lookup.
return $hash_ref->{$key};
}
else {
# This is the interesting place where we could provide our own values.
return "custom_value_based_on_certain_conditions"; # Some value
}
}
Another consequence would be the ability to alter the value returned against a key. We would be able to return a different value than what actually is stored against that key ( in that hash ).
There might not be a valid use case for this but am intrigued and would like to learn if such things are supported in Perl.
As said by Сухой27 in comment, this works fine:
my %hash_example = ( "a"=>"apple", "b"=>"ball" );
print $hash_example{"a"};
print $hash_example{"c"} // "custom_value_based_on_certain_conditions";
Doc on logical defined or
I would suggest that trying to alter how a hash lookup "works" is a really terrible idea, as a good way to create code that's hard to maintain.
However instead I would suggest you look at creating an object instead of a hash. They are basically the same thing, but an object includes code, and there is an expectation that the code within the object is 'doing it's own thing'.
So at a basic level:
#!/usr/bin/env perl
use strict;
use warnings;
package Hash_Ob;
sub new {
my ($class) = #_;
my $self = {};
bless( $self, $class );
return $self;
}
sub get_value {
my ( $self, $valuename ) = #_;
if ( $self->{$valuename} ) {
return $self->{$valuename};
}
else {
#generate your own value here!
$self->{$valuename} = 42;
return $self->{$valuename};
}
}
1;
Which you'd then 'call' using:
#!/usr/bin/env perl
use strict;
use warnings;
use Hash_Ob;
my $magic_hash = Hash_Ob -> new();
print $magic_hash -> get_value('new_value');
This avoids the problem of altering how a 'well known' mechanism actually works, and so future maintenance programmers will not curse your name.
Then maybe you want to use a tied hash. Tying is a mechanism to change the behavior of a builtin data type. See perltie for the gory details.
{
package HashWithDefault;
use Tie::StdHash;
our #ISA = qw(Tie::StdHash); # inherit STORE, FIRST, NEXT, etc.
sub TIEHASH {
my ($pkg,$default_val) = #_;
return bless { __default_val__ => $default_val}, $pkg;
}
sub FETCH {
my ($self,$key) = #_;
exists $self->{$key} ? $self->{$key} : $self->{__default_val__};
}
sub CLEAR { # don't clear the default val
my $self = shift;
%$self = ( __default_val__ => $self->{__default_val__} );
}
}
tie my %hash, 'HashWithDefault', "42";
%hash = (foo => 123, bar => 456);
print $hash{foo}; # 123
print $hash{quux}; # 42

Reference found where even-sized list expected in Perl - Possible pass-by-reference error?

I have a Perl class/module that I created to display Bible verses. In it there is a hash that stores several verses, with the key being the book/chapter/verse and the value being the text. This hash is returned from the module.
I'm including the Bible class in a controller class, and that connection seems to work. The problem is I keep getting errors on executing. My IDE because I'm following a Lynda tutorial, is Eclipse with the EPIC plugin.
The error is:
Reference found where even-sized list expected at C:/Documents and Settings/nunya/eric.hepperle_codebase/lynda/lamp/perl5/Exercise Files/14 Modules/eh_bibleInspiration_controller.pl line 42.
Use of uninitialized value $value in concatenation (.) or string at C:/Documents and Settings/nunya/eric.hepperle_codebase/lynda/lamp/perl5/Exercise Files/14 Modules/eh_bibleInspiration_controller.pl line 45.
HASH(0x19ad454) =>
Here is the CONTROLLER class:
#!/usr/bin/perl
# eh_bibleInspiration_controller.pl by Eric Hepperle - 06/23/13
#
use strict;
use warnings;
use Data::Dumper;
use EHW_BibleInspiration;
main(#ARGV);
sub main
{
my $o = EHW_BibleInspiration->new; # instantiate new object.
my %bo_ref = $o->getBibleObj();
print "\$o is type: " . ref($o) . ".\n";
print "\%bo_ref is type: " . ref(\%bo_ref) . ".\n";
# exit;
$o->getVerseObj();
listHash(\%bo_ref);
message("Done.");
}
sub message
{
my $m = shift or return;
print("$m\n");
}
sub error
{
my $e = shift || 'unkown error';
print("$0: $e\n");
exit 0;
}
sub listHash
{
my %hash = #_;
foreach my $key (sort keys %hash) {
my $value = $hash{$key};
message("$key => $value\n");
}
}
Here is the class that returns the verses and has the method to pick a random verse:
# EHW_BibleInspiration.pm
# EHW_BibleInspiration.
#
package EHW_BibleInspiration;
use strict;
use warnings;
use IO::File;
use Data::Dumper;
our $VERSION = "0.1";
sub new
{
my $class = shift;
my $self = {};
bless($self, $class); # turns hash into object
return $self;
}
sub getVerseObj
{
my ($self) = #_;
print "My Bible Verse:\n";
my $verses = $self->getBibleObj();
# get random verse
#$knockknocks{(keys %knockknocks)[rand keys %knockknocks]};
# sub mysub {
# my $params = shift;
# my %paramhash = %$params;
# }
# my %verses = %{$verses};
# my $random_value = %verses{(keys %verses)[rand keys %verses]};
# print Dumper(%{$random_value});
}
sub getBibleObj
{
my ($self) = #_;
# create bible verse object (ESV)
my $bibleObj_ref = {
'john 3:16' => 'For God so loved the world,that he gave his only Son, that whoever believes in him should not perish but have eternal life.',
'matt 10:8' => 'Heal the sick, raise the dead, cleanse lepers, cast out demons. You received without paying; give without pay.',
'Luke 6:38' => 'Give, and it will be given to you. Good measure, pressed down, shaken together, running over, will be put into your lap. For with the measure you use it will be measured back to you.',
'John 16:24' => 'Until now you have asked nothing in my name. Ask, and you will receive, that your joy may be full.',
'Psalms 32:7' => 'You are a hiding place for me; you preserve me from trouble; you surround me with shouts of deliverance. Selah',
'Proverbs 3:5-6' => 'Trust in the LORD with all your heart, and do not lean on your own understanding. 6 In all your ways acknowledge him, and he will make straight your paths.',
'John 14:1' => 'Let not your hearts be troubled. Believe in God; believe also in me.'
};
my $out = "The BIBLE is awesome!\n";
return $bibleObj_ref;
}
1;
What am I doing wrong? I suspect it has something to do with hash vs hash reference, but I don't know how to fix it. My dereferencing attempts had failed miserably because I don't really know what I'm doing. I modeled my random getter off of something I saw on perlmonks. #$knockknocks{(keys %knockknocks)[rand keys %knockknocks]};
In the main, you have:
my %bo_ref = $o->getBibleObj();
but, in package EHW_BibleInspiration;, the method getBibleObj returns : return $bibleObj_ref;
You'd do, in the main : my $bo_ref = $o->getBibleObj();
and then call listHash($bo_ref);
Finaly, don't forget to change sub listHash to:
sub listHash
{
my ($hash) = #_;
foreach my $key (sort keys %{$hash}) {
my $value = $hash->{$key};
message("$key => $value\n");
}
}
In your main, you do
listHash(\%bo_ref);
This passes a hash reference to the sub. However, it tries to unpack its arguments like
my %hash = #_;
Oops, it wants a hash.
Either, we pass it a hash: listHash(%bo_ref). This saves us much typing.
Or, we handle the reference inside the sub, like
sub listHash {
my ($hashref) = #_;
foreach my $key (sort keys %$hashref) {
my $value = $hashref->{$key};
print "$key => $value\n";
}
}
Notice how the reference uses the dereference arrow -> to access hash entries, and how it is dereferenced to a hash for keys.
I suspect that your suspicion is correct. In your method sub listHash you're correctly passing in the hash but you're trying to use a hash instead of a hash reference for the internal variable. Try using my ($hash) = #_; instead of my %hash = #_;.
When using references you can use the -> operator to de-reference it to get to the underlying values. The rest of your method should look like this:
sub listHash
{
my ($hash) = #_;
foreach my $key (sort keys %{$hash}) {
my $value = $hash->{$key};
message("$key => $value\n");
}
}
On line 43 of your program I had to tell Perl that the reference should be a hash reference by calling keys %{$hash}. Then on line 44 I de-referenced the hash to get the correct value by calling $hash->{$key}. For more information on Perl and references you can read the through the tutorial.
listHash is expecting a hash and you're passing it a hash reference. Change:
listHash(\%bo_ref);
to:
listHash(%bo_ref);

"Not an ARRAY reference" error starts to happen when I modularize my code

I'm modularizing my code, but when I move a sub out of it's original module, I get the following error:
Couldn't load application from file "foo.pl": Not an ARRAY reference at D.pm line 10.
This was the original file. As is, it's all ok:
FormerC.pm:
package FormerC;
use strict;
my %my_hash = ( key => 'value' );
my #my_array = qw( some strings inside array );
sub problematic_sub {
my ($hash_ref, $array_ref) = #_;
my #an_array = #$array_ref;
return \#an_array;
};
sub uses_problematic_sub {
problematic_sub(\%my_hash, \#my_array);
};
uses_problematic_sub();
1
These are the two new modules. With these I get the error:
D.pm:
package D;
use strict;
sub new { bless {}, shift };
sub problematic_sub {
my ($hash_ref, $array_ref) = #_;
my #an_array = #$array_ref;
return \#an_array;
};
1
C.pm:
package C;
use strict;
use D;
my $d = D->new;
my %my_hash = ( key => 'value' );
my #my_array = qw( some strings inside array );
sub uses_problematic_sub {
$d->problematic_sub(\%my_hash, \#my_array);
};
uses_problematic_sub();
1
You used to call problematic_sub as a sub
problematic_sub(\%my_hash, \#my_array);
but you now call is as a method:
$d->problematic_sub(\%my_hash, \#my_array);
Since you didn't code problematic_sub as a method, this isn't correct. You need to also change problematic_sub's parameters to the following:
my ($self, $hash_ref, $array_ref) = #_;
You are likely to be better off using the Exporter module to export the subroutine names into the calling code's namespace. What you have written here is an object-oriented module, but the object is just a collection of subroutines and doesn't need object-oriented support.
The problem is that a method call like
$d->problematic_sub(\%my_hash, \#my_array)
implicitly passes the object as the first parameter, so it is equivalent to
D::problematic_sub($d, \%my_hash, \#my_array)
All you need to do is account for this in the subroutine
sub problematic_sub {
my ($self, $hash_ref, $array_ref) = #_;
my #an_array = #$array_ref;
return \#an_array;
}
and your code should work.
Also note that a subroutine declaration, like a while or for loop, is not a statement and so doesn't need and shouldn't have a semicolon after it.

How do you create a callback function (dispatch table) in Perl using hashes?

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 => \&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 => \&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);
}