I have this perl object. After the object is instantiated, I'm trying to add a new method to the object within a loader method, that can then be called later.
I've tried a whole bunch of stuff that hasn't worked. Examples include:
sub loader {
my ($self) = #_;
sub add_me {
my ($self, $rec) = #_
warn "yayyyyyy";
return $rec;
}
#here are the things I've tried that dont work:
# &{$self->{add_me}} = \&add_me;
# \&{$self->{add_me}} = \&add_me;
# assuming the class definition is in Holder::Class try to add it to symblol table
# *{Holder::Class::add_me} = \&add_me;
}
EDIT:
The reason that I need to do this is I'm adding a hook in my code where the user of my software will have the ability to inject their own sub to edit a data structure as they will.
To do this, they will be able to edit a secondary file that will only contain one sub and get the data structure in question passed in, so something like:
sub inject_a_sub {
my ($self, $rec) = #_;
#do stuff to $rec
return $rec;
}
then inside my original object upon its instantiation, I check to see if the above mentioned file exists, and if so read its contents and eval them. Lastly, I want to make the eval'd code which is just a sub, a method of my object. To be precise, my object is already inheriting a method called do_something and i want to make the sub read in by the eval override the do_something method being inherited so that when called the sub from the external file runs.
its a weird problem :/
and it hurts me :(
Obi wan kenobi you're my only hope!
Cheers!
If you just want to attach functionality to a specific object, and don't need inheritance, you can store a code ref in the object and call it.
# Store the code in the object, putting it in its own
# nested hash to reduce the chance of collisions.
$obj->{__actions}{something} = sub { ... };
# Run the code
my #stuff = $obj->{__actions}{something}->(#args);
Problem is, you need to check that $obj->{__actions}{something} contains a code reference. What I would suggest is to wrap a method around this procedure.
sub add_action {
my($self, $action, $code) = #_;
$self->{__actions}{$action} = $code;
return;
}
sub take_action {
my($self, $action, $args) = #_;
my $code = $self->{__actions}{$action};
return if !$code or ref $code ne 'CODE';
return $code->(#$args);
}
$obj->add_action( "something", sub { ... } );
$obj->take_action( "something", \#args );
If you already know the class name you want to inject a method into, write the subroutine as normal but use the fully qualified name.
sub Some::Class::new_method {
my $self = shift;
...
}
Note that any globals inside that subroutine will be in the surrounding package, not in Some::Class. If you want persistent variables use state inside the subroutine or my outside the subroutine.
If you don't know the name at compile time, you'll have to inject the subroutine into the symbol table, so you were close with that last one.
sub inject_method {
my($object, $method_name, $code_ref) = #_;
# Get the class of the object
my $class = ref $object;
{
# We need to use symbolic references.
no strict 'refs';
# Shove the code reference into the class' symbol table.
*{$class.'::'.$method_name} = $code_ref;
}
return;
}
inject_method($obj, "new_method", sub { ... });
Methods in Perl are associated with a class, not an object. In order to assign a method to a single object, you have to put that object into its own class. Similar to the above, but you have to create a subclass for every instance.
my $instance_class = "_SPECIAL_INSTANCE_CLASS_";
my $instance_class_increment = "AAAAAAAAAAAAAAAAAA";
sub inject_method_into_instance {
my($object, $method_name, $code_ref) = #_;
# Get the class of the object
my $old_class = ref $object;
# Get the special instance class and increment it.
# Yes, incrementing works on strings.
my $new_class = $instance_class . '::' . $instance_class_increment++;
{
# We need to use symbolic references.
no strict 'refs';
# Create its own subclass
#{$new_class.'::ISA'} = ($old_class);
# Shove the code reference into the class' symbol table.
*{$new_class.'::'.$method_name} = $code_ref;
# Rebless the object to its own subclass
bless $object, $new_class;
}
return;
}
I left out the code to check whether or not the instance has already had this treatment by checking if its class matches /^${instance_class}::/. I leave that as an exercise for you. Creating a new class for every object is not cheap and will cost memory.
There are valid reasons to do this, but they are exceptional. You should really, really question whether you should be doing this sort of monkey patching. In general, action at a distance should be avoided.
Can you accomplish the same thing using a subclass, delegation or role?
There already exist Perl OO systems which will do this for you and much much more. You should be using one. Moose, Moo (via Role::Tiny) and Mouse can all add roles to an instance.
Related
My program creates an object, which, in turn, creates another object
MainScript.pm
use module::FirstModule qw ($hFirstModule);
$hFirstModule->new(parametres);
$hFirstModule->function();
FirstModule.pm
use Exporter ();
#EXPORT = qw($hFirstModule);
use module::SecondModule qw ($hSecondModule);
sub new {
my $className = shift;
my $self = { key => 'val' };
bless $self, $classname;
return $self;
}
sub function{
$hSecondModule->new(parametres);
#some other code here
}
I want to acces $hSecondModule from MainScript.pm.
It depends.
We would have to see the actual code. What you've shown is a bit ambiguous. However, there are two scenarios.
You can't
If your code is not exactly like what you have shown as pseudo-code, then there is no chance to do that. Consider this code in &module1::function.
sub function {
my $obj = Module2->new;
# ... more stuff
return;
}
In this case, you are not returning anything, and the $obj is lexically scoped. A lexical scope means that it only exists inside of the closest {} block (and all blocks inside that). That's the block of the function sub. Once the program returns out of that sub, the variable goes out of scope and the object is destroyed. There is no way to get to it afterwards. It's gone.
Even if it was not destroyed, you cannot reach into a different scope.
You can
If you however return the object from the function, then you'd have to assign it in your script, and then you can access it later. If the code is exactly what you've shown above, this works.
sub function {
my $obj = Module2->new;
# nothing here
}
In Perl, subs always return the last true statement. If you don't have a return and the last statement is the Module2->new call, then the result of that statement, which is the object, is returned. Of course it also works if you actually return explicitly.
sub function {
return Module2->new;
}
So if you assign that to a variable in your script, you can access it in the script.
my $obj = module1->function();
This is similar to the factory pattern.
This is vague, but without more information it's impossible to answer the question more precicely.
Here is a very hacky approach that takes your updated code into consideration. It uses Sub::Override to grab the return value of the constructor call to your SecondModule thingy. This is something that you'd usually maybe do in a unit test, but not in production code. However, it should work. Here's an example.
Foo.pm
package Foo;
use Bar;
sub new {
return bless {}, $_[0];
}
sub frobnicate {
Bar->new;
return;
}
Bar.pm
package Bar;
sub new {
return bless {}, $_[0];
}
sub drink {
return 42; # because.
}
script.pl
package main;
use Foo; # this will load Bar at compile time
use Sub::Override;
my $foo = Foo->new;
my $bar; # this is lexical to the main script, so we can use it inside
my $orig = \&Bar::new; # grab the original function
my $sub = Sub::Override->new(
"Bar::new" => sub {
my $self = shift;
# call the constructor of $hSecondModule, grab the RV and assign
# it to our var from the main script
$bar = $self->$orig(#_);
return $bar;
}
);
$foo->frobnicate;
# restore the original sub
$sub->restore;
# $bar is now assigend
print $bar->drink;
Again, I would not do this in production code.
Let's take a look at the main function. It first creates a new Foo object. Then it grabs a reference to the Bar::new function. We need that as the original, so we can call it to create the object. Then we use Sub::Override to temporarily replace the Bar::new with our sub that calls the original, but takes the return value (which is the object) and assigns it to our variable that's lexical to the main script. Then we return it.
This function will now be called when $foo->frobnicate calls Bar->new. After that call, $bar is populated in our main script. Then we restore Bar::new so we don't accidentally overwrite our $bar in case that gets called again from somewhere else.
Afterwards, we can use $bar.
Note that this is advanced. I'll say again that I would not use this kind of hack in production code. There is probably a better way to do what you want. There might be an x/y problem here and you need to better explain why you need to do this so we can find a less crazy solution.
I have come across code with the following syntax:
$a -> mysub($b);
And after looking into it I am still struggling to figure out what it means. Any help would be greatly appreciated, thanks!
What you have encountered is object oriented perl.
it's documented in perlobj. The principle is fairly simple though - an object is a sort of super-hash, which as well as data, also includes built in code.
The advantage of this, is that your data structure 'knows what to do' with it's contents. At a basic level, that's just validate data - so you can make a hash that rejects "incorrect" input.
But it allows you to do considerably more complicated things. The real point of it is encapsulation, such that I can write a module, and you can make use of it without really having to care what's going on inside it - only the mechanisms for driving it.
So a really basic example might look like this:
#!/usr/bin/env perl
use strict;
use warnings;
package MyObject;
#define new object
sub new {
my ($class) = #_;
my $self = {};
$self->{count} = 0;
bless( $self, $class );
return $self;
}
#method within the object
sub mysub {
my ( $self, $new_count ) = #_;
$self->{count} += $new_count;
print "Internal counter: ", $self->{count}, "\n";
}
package main;
#create a new instance of `MyObject`.
my $obj = MyObject->new();
#call the method,
$obj->mysub(10);
$obj->mysub(10);
We define "class" which is a description of how the object 'works'. In this, class, we set up a subroutine called mysub - but because it's a class, we refer to it as a "method" - that is, a subroutine that is specifically tied to an object.
We create a new instance of the object (basically the same as my %newhash) and then call the methods within it. If you create multiple objects, they each hold their own internal state, just the same as it would if you created separate hashes.
Also: Don't use $a and $b as variable names. It's dirty. Both because single var names are wrong, but also because these two in particular are used for sort.
That's a method call. $a is the invocant (a class name or an object), mysub is the method name, and $b is an argument. You should proceed to read perlootut which explains all of this.
Suppose I have a function that returns a closure:
sub generator
{
my $resource = get_resource();
my $do_thing = sub
{
$resource->do_something();
}
return $do_thing;
}
# new lexical scope
{
my $make_something_happen = generator();
&$make_something_happen();
}
I would like to be able to ensure that when $make_something_happen is removed from scope, I am able to call some $resource->cleanup();
Of course, if I had a class, I could do this with a destructor, but that seems a bit heavyweight for what I want to do. This isn't really an "object" in the sense of modelling an object, it's just a functiony thing that needs to execute some code on startup and immediately prior to death.
How would I do this in Perl( and, out of curiosity, does any language support this idea)?
I'd just use a class for this. Bless the subroutine reference and still use it like you are. The get_resource then uses this class. Since I don't know what that looks like, I'll leave it up to you to integrate it:
package Gozer {
sub new {
my( $class, $subref );
bless $subref, $class;
}
sub DESTROY {
...; #cleanup
}
}
If every thing can have it's own cleanup, I'd use the class to group two code refs:
package Gozer {
sub new {
my( $class, $subref, $cleanup );
bless { run => $subref, cleanup => $cleanup }, $class;
}
sub DESTROY {
$_[0]{cleanup}();
}
}
In Perl, I don't think this is heavyweight. The object system simply attaches labels to references. Not every object needs to model something, so this is a perfectly fine sort of object.
It would be nice to have some sort of finalizers on ordinary variables, but I think those would end up being the same thing, topologically. You could do it with Perl as a tie, but that's just an object again.
I think I understand your question. In my case I want:
* A global variable that may be set at any point during the script's runtime
* To last right up to the end of the life of the script
* Explicitly clean it up.
It looks like I can do this by defining an END block; It will be run "as late as possible".
You should be able to do your $resource->cleanup(); up in there.
More here:
http://perldoc.perl.org/perlmod.html#BEGIN%2c-UNITCHECK%2c-CHECK%2c-INIT-and-END
The begincheck program on that page has the code.
package a::b::c:d
my $res = a::b::c:e->new(); # i am doing like this
# is there any othere to do this
sub new {
...
my $self = {
#result = a::b::c:e->new();
}
}
sub test {
}
sub test2 {
}
1;
package a::b::c:e
sub new {
...
}
sub testresult {
}
1;
My question is:
how to initalize the e module in d in new itself rather creating every function and
how to use that to store some results into e:testresult
There are two strategies -- either examine the symbol table to initialize on creation, or make use of AUTOLOAD and test with can. AUTOLOAD can be messier as you have to deal with the case where the method isn't there:
sub AUTOLOAD {
my $self = shift;
my $method = $AUTOLOAD;
$method =~ s/.*://; # strip package name
if ( $self->{'result'}->can($method) ) {
return $self->{'result'}->$method(#_);
} else {
croak "Unknown method : $method";
}
}
But the symbol table trick is brittle, as if they're using inheritance, you won't see the inherited methods without walking up #ISA, too. (and even if they're not -- they might start using inheritance in the future, which results in things breaking)
...
Typically, when you're trying to copy another module's interface, you've got a case of inheritance, so you might want to ask yourself what the relationship is between ::d and ::e :
a::b::c::d is an a::b::c::e
a::b::c::d uses a::b::c::e
If it's an is-a relationship, it's typically better suited to inheritance (although you might have wrappers around each of the methods, and still need to go through this whole exercise anyway). If it's a uses relationship, odds are you don't want to inherit from every last method they have, and can just hard code a list (although, the list might change if the used class is updated)
foreach my $method ( #list_of_methods_to_copy ) {
*{$method} = sub {
my $self = shift;
return $self->{'results'}->$method(#_);
}
}
Provided that you're not looking for inheritance between the two classes, it looks to me that you might want to use Class::Delegator for composing your class. That way, you can create the delegation routines by putting the following in a::b::c::d.
use Class::Delegator send => 'testresult', to => '{result}';
But you'd need to fix your constructor anyway:
my $self
= bless {
result => a::b::c::e->new()
}, $class_name
;
return $self;
Having done that, you'd have a field '{result}' to delegate to.
I want to put some subs that are within an OO package into an array - also within the package - to use as a dispatch table. Something like this
package Blah::Blah;
use fields 'tests';
sub new {
my($class )= #_;
my $self = fields::new($class);
$self->{'tests'} = [
$self->_sub1
,$self->_sub2
];
return $self;
}
_sub1 { ... };
_sub2 { ... };
I'm not entirely sure on the syntax for this?
$self->{'tests'} = [
$self->_sub1
,$self->_sub2
];
or
$self->{'tests'} = [
\&{$self->_sub1}
,\&{$self->_sub2}
];
or
$self->{'tests'} = [
\&{_sub1}
,\&{_sub2}
];
I don't seem to be able to get this to work within an OO package, whereas it's quite straightforward in a procedural fashion, and I haven't found any examples for OO.
Any help is much appreciated,
Iain
Your friend is can. It returns a reference to the subroutine if it exists, null otherwise. It even does it correctly walking up the OO chain.
$self->{tests} = [
$self->can('_sub1'),
$self->can('_sub2'),
];
# later
for $tn (0..$#{$self->{tests}}) {
ok defined $self->{tests}[$tn], "Function $tn is available.";
}
# and later
my $ref = $self->{tests}[0];
$self->$ref(#args1);
$ref = $self->{tests}[1];
$self->$ref(#args2);
Or, thanks to this question (which happens to be a variation of this question), you can call it directly:
$self->${\$self->{tests}[0]}(#args1);
$self->${\$self->{tests}[1]}(#args1);
Note that the \ gives us a reference to a the subref, which then gets dereferenced by the ${} after $self->. Whew!
To solve the timeliness issue brain d foy mentions, an alternative would be to simply make the {test} a subroutine itself, that returns a ref, and then you could get it at exactly the time you need it:
sub tests {
return [
$self->can('_sub1'),
$self->can('_sub2')
];
}
and then use it:
for $tn (0..$#{$self->tests()}) {
...
}
Of course, if you have to iterate over the refs anyway, you might as well just go straight for passing the reference out:
for my $ref (0..$#{$self->tests()}) {
$self->$ref(#args);
}
Although Robert P's answer might work for you, it has the problem of fixing the dispatch very early in the process. I tend to resolve the methods as late as I can, so I would leave the things in the tests array as method names until you want to use them:
$self->{tests} = [
qw( _sub1 _sub2 )
];
The strength of a dynamic language is that you can wait as long as you like to decide what's going to happen.
When you want to run them, you can go through the same process that Robert already noted. I'd add an interface to it though:
foreach my $method_name ( $obj->get_test_methods )
{
$obj->$method_name();
}
That might even be better as not tying the test to an existing method name:
foreach my $method_name ( $obj->get_test_methods )
{
$obj->run_test_named( $method_name );
}
That run_test_named could then be your dispatcher, and it can be very flexible:
sub run_test_named
{
my( $self, $name ) = #_;
# do anything you want, like in Robert's answer
}
Some things you might want to do:
Run a method on an object
Pass the object as an argument to something else
Temporarily override a test
Do nothing
etc, etc
When you separate what you decide to do from its implementation, you have a lot more freedom. Not only that, the next time you call the same test name, you can do something different.
use lib Alpha;
my $foo = Alpha::Foo->new; # indirect object syntax is deprecated
$foo->bar();
my %disp_table = ( bar => sub { $foo->bar() } );
$disp_table{bar}->(); # call it
You need a closure because you want to turn a method call into an ordinary subroutine call, so you have to capture the object you're calling the method on.
There are a few ways to do this. Your third approach is closest. That will store a reference to the two subs in the array. Then when you want to call them, you have to be sure to pass them an object as their first argument.
Is there a reason you are using the use fields construct?
if you want to create self contained test subs, you could do it this way:
$$self{test} = [
map {
my $code = $self->can($_); # retrieve a reference to the method
sub { # construct a closure that will call it
unshift #_, $self; # while passing $self as the first arg
goto &$code; # goto jumps to the method, to keep 'caller' working
}
} qw/_sub1 _sub2/
];
and then to call them
for (#{ $$self{test} }) {
eval {$_->(args for the test); 1} or die $#;
}