Example code:
testClass1.pm
package testClass1;
{
my $testClass2Ref;
sub new
{
my($class) = shift;
$testClass2Ref= shift;
bless $self, $class;
return $self;}
}
sub testRef
{
$testClass2Ref->testRef;
}
}
testClass2.pm
package testClass2;
{
sub new
{
my($class) = shift;
bless $self, $class;
return $self;}
}
sub testRef
{
print "Test 2";
}
}
test.pl
use testClass1;
use testClass2;
my $testClass2 = testClass2->new();
my $testClass1 = testClass2->new($testClass2);
$testClass1->testRef;
When I try call $testClass1->testRef, $testClass2Ref=undef.
How can I pass reference on the object from parent?
Update
Oh, sorry, I missed string in example's constructors.
sub new
{
my($class) = shift;
$testClass2Ref = shift;
my $self = {name=>'testClass1'};
bless $self, $class;
return $self;
}
This test is working, but Eclipse debugger show this variables as 'undef'.
Thanks for your help.
Besides the syntax errors, you aren't using strict mode. Turning it on will reveal that $self isn't being declared in either package. By replacing:
bless $self, $class;
with:
my $self = bless {}, $class;
Everything goes through as expected.
When you fix the syntax errors it works.
> ./test.pl
> Test 2
You were missing
my $self = {};
in both new methods.
A useful tool is
perl -wc testClass1.pm
Can one pass Perl object references between modules?
Absolutely!
In this test script I make two classes, one that tests and one to be tested. Remember objects are just references and methods are just subroutines; use them in the same way.
#!/usr/bin/env perl
use strict;
use warnings;
package Tester;
sub new {
my $class = shift;
my ($other) = #_;
my $self = { other => $other };
bless $self, $class;
return $self;
}
sub examine {
my $self = shift;
print "I'm holding a: ", ref( $self->{other} ), "\n";
}
package Candidate;
sub new { return bless {}, shift }
package main;
my $candidate = Candidate->new();
my $tester = Tester->new( $candidate );
$tester->examine();
EDIT: Now using a more modern system, MooseX::Declare (which is based on Moose) with Method::Signatures. This saves a lot of the boilerplate and lets you focus on what you want the objects to do, rather then how they are implemented.
#!/usr/bin/env perl
#technically Moose adds strict and warnings, but ...
use strict;
use warnings;
use MooseX::Declare;
use Method::Signatures::Modifiers;
class Tester {
has 'other' => ( isa => 'Object', is => 'rw', required => 1 );
method examine () {
print "I'm holding a: ", ref( $self->other() ), "\n";
}
}
class Candidate { }
no MooseX::Declare;
package main;
my $candidate = Candidate->new();
my $tester = Tester->new( other => $candidate );
$tester->examine();
For more realistic cases, see how some larger module systems pass object representing complex concepts. Off the top of my head, HTTP::Response object get passed around all through the LWP system
Related
I want to create a hash reference with code references mapped to scalars (strings) as its members.
So far I have a map reference that looks something like this:
my $object;
$object = {
'code1' => sub {
print $_[0];
},
'code2' => sub {
return 'Hello, World!';
},
'code3' => sub {
$object->{code1}->($object->{code2}->());
}
};
$object->{code3}->();
I would like to be able to "bless" the 'code3' reference in $object with $object, so I can do something like:
my $object;
$object = {
'code1' => sub {
print $_[0];
},
'code2' => sub {
return 'Hello, World!';
},
'code3' => sub {
$self = shift;
$self->{code1}->($self->{code2}->());
}
};
$object->{code3}->();
However, bless only works with packages, rather than hash tables.
Is there a way to do this in Perl 5 version 22?
Note: now that I think of it, it's better to pass $object to the method explicitly, as it solves JavaScript's "this" problem. I am just too used to Java's "this" which makes sense in Java where everything is a class and therefore all methods have a "this", but in scripting, it really helps to know if the "this" is actually passed, or is it just called as a function(and you end up accidentally polluting global scope or triggering strict warning) passing $self explicitly makes it clear that you are not calling it as a function, but as a method.
You are doing sub calls (not method calls), so you simply forgot to pass $self as a parameter.
my $object = {
code1 => sub {
print $_[0];
},
code2 => sub {
return 'Hello, World!';
},
code3 => sub {
my $self = shift;
$self->{code1}->( $self, $self->{code2}->($self) );
}
};
$object->{code3}->($object);
But I think you're trying to create JavaScript-like objects. You can start with the following:
package PrototypeObject;
sub new {
my $class = shift;
my $self = bless({}, $class);
%$self = #_;
return $self;
}
sub AUTOLOAD {
my $self = shift;
( my $method = our $AUTOLOAD ) =~ s/^.*:://s;
return $self->{$method}->($self, #_);
}
1;
use PrototypeObject qw( );
my $object = PrototypeObject->new(
code1 => sub {
print $_[1];
},
code2 => sub {
return 'Hello, World!';
},
code3 => sub {
my $self = shift;
$self->code1( $self->code2() );
}
);
$object->code3();
Note that this will slow down your method calls as it must call AUTOLOAD before calling your method. This could be addressed by overloading the method call operator.
Check on CPAN. Someone might already have a more complete implementation.
This is not the exact syntax you want, but Perl 5 supports many ways of making method calls, including method calls via strings. So you could say:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
sub code1 { my $self = shift; print "$_[0]\n" };
sub code2 { "Hello, World!" }
sub code3 {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
}
}
use strict;
use warnings;
my $o = Foo->new;
print "normal call\n";
$o->code3;
print "via string\n";
my $method = "code3";
$o->$method;
Also, remember that a package's symbol table is a hash: %Foo::, so you can always go spelunking in there yourself:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
sub code1 { my $self = shift; print "$_[0]\n" };
sub code2 { "Hello, World!" }
sub code3 {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
}
}
use strict;
use warnings;
print $Foo::{code2}->(), "\n";
However, I would suggest having a really code reason for these techniques as it can make maintenance a nightmare (eg imaging trying to find all of the code calling Foo::approved, you can't just grep for "->approved" because the actual call is ->$state()).
I just read the comments and noticed you said
my concern with packages is that I can't seem to create packages at runtime, but I can create hash tables at runtime
Perl 5 does allow you to create packages at runtime. In fact, depending on how you define runtime, you can do anything at runtime with string eval as it reenters compile time when it is called. But there is also a pure-runtime method of manipulating the symbol tables with typeglobs:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
}
use strict;
use warnings;
my $o = Foo->new;
# here we add functions at runtime to the package Foo
{
no warnings "once";
*Foo::code1 = sub { my $self = shift; print "$_[0]\n" };
*Foo::code2 = sub { "Hello, World!" };
*Foo::code3 = sub {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
};
}
$o->code3;
Because Perl 5 is object oriented (and not object based like JavaScript) these methods are attached to all Foo objects. If you want individual objects have their own symbol tables, then I am there are certainly ways to do that. Off the top of my head, AUTOLOAD comes to mind:
#!/usr/bin/perl
{ package Foo;
use strict;
use Carp;
use warnings;
sub new {
bless {
symtab => {}
}, shift
}
sub AUTOLOAD {
my $self = shift;
our $AUTOLOAD;
my $method = $AUTOLOAD =~ s/.*:://r;
my (undef, $file, $line) = caller();
die "$method does not exist at $file line $line"
unless exists $self->{symtab}{$method};
$self->{symtab}{$method}->($self, #_);
}
sub DESTROY {} # prevent DESTROY method from being hijacked by AUTOLOAD
}
use v5.22;
use warnings;
my $o1 = Foo->new;
my $o2 = Foo->new;
$o1->{symtab}{inc} = sub { my $self = shift; $self->{i}++; };
$o1->inc;
$o1->inc;
$o1->inc;
say "inc called on o1 $o1->{i} times";
$o2->inc; #dies because we haven't defined inc for $o2 yet
Perl 5 is very flexible and will let you do just about anything you want (after all the motto is TIMTOWTDI), but you should always keep in mind the future programmer tasked with maintaining your code who may want to hunt you down and wear your skin for doing some of these tricks.
This question has a definite XY problem feel. It seems like you are trying to solve a problem in Perl 5 the same way you would have solved it in JavaScript. While Perl 5 will let you do that (as I have demonstrated), there may be a more idiomatic way of achieving the same effect. Can you describe what you are trying to do (not how you want to do it) in a different question and we can suggest the ways in which we would solve your problem.
This is my first time using OOP with perl. I am in the processes of refactoring a 4k line procedural program at work. It seems pretty straight forward but I am having an issue with inheritance and SUPER.
Error message:
"Can't locate object method "New" via package "Module::SUPER" at Module.pm line 10"
I have tried, use base, parent and setting #ISA but they all get the same error. I'm sure I have to be overlooking something.
(This is not code from the program I am working on. Just an example that produces the same error)
All .pm and .pl files are in the same directory in this example. In the program I am working on the main program is in bin and the modules will be in ../modules(relative to bin).
I would assume this would be all I need to make that work:
use lib "../modules";
If I am wrong in thinking that please let me know.
Parent Module
package BaseModule;
use strict;
use warnings;
sub new {
my $class = shift;
my $self = {
ARRAY => shift,
DIVIDER => ","
};
bless ($self, $class);
return $self;
}
sub array {
my $self = shift;
if(#_) { $self->{ARRAY} = shift };
return $self->{ARRAY};
}
sub divider {
my $self = shift;
if(#_) { $self->{DIVIDER} = shift };
return $self->{DIVIDER};
}
sub testSub {
my $self = shift;
print join($self->{DIVIDER}, #{ $self->{ARRAY} } );
return 1;
}
1;
Child Module
package Module;
use strict;
use warnings;
#use base qw(BaseModule);
#require BaseModule;
#our #ISA = qw(BaseModule);
use parent qw(BaseModule);
sub new {
my $class = shift;
my $self = $class->SUPER::New(#_);
$self->{STRING} = shift;
bless ($self, $class);
return $self;
}
sub string {
my $self = shift;
if(#_) { $self->{STRING} = shift };
return $self->{STRING};
}
sub testSub {
my $self = shift;
print "$self->{STRING}:\n";
$self->SUPER::testSub();
return 1;
}
1;
Do I need to bless the child class if the parent class returns an already blessed $self?
Main Script
#!/usr/bin/perl
use strict;
use warnings;
use Module;
my $module = Module->new([1, 2, 3, 4, 5], "Example");
$module->divider(" | "); # Test Changing divider;
$module->testSub();
Any help is greatly appreciated.
"Can't locate object method "New" via package "Module::SUPER" at Module.pm line 10"
You try to call BaseModule::New whis hasn't been defined (did you mean BaseModule::new? Perl is case sensitive).
Do I need to bless the child class if the parent class returns an
already blessed $self?
No, $self at that point is already blesses (you could check that by means of Scalar::Util::blessed().
I'm just trying to do this: http://modernperlbooks.com/mt/2011/08/youre-already-using-dependency-injection.html. Really not deviating too much at all from that example code.
Here's what I've got:
package M;
use Moose;
use Exporter;
use Data::Dumper;
sub new {
print "M::new!\n";
my $class = shift;
return bless {}, $class;
}
sub x {
my ($self, $stuff) = #_;
print Dumper($stuff);
}
#################################
package Foo;
use Moose;
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = ();
has 'mS', is => 'ro', default => sub { M->new };
sub new {
my $class = shift;
return bless {}, $class;
}
sub bar {
my ($self, $data) = #_;
# do stuff here...
# ...
my $foo = $self->mS;
# this...
$foo->x($data);
# ...causes "Can't call method "x" on an undefined value at Foo.pm line 45."
}
1;
It's worth noting that the M::new! message never appears, so I'm guessing that it's never reached. What's going on?
With Moose, you shouldn't write sub new. Moose provides the constructor for you.
Also, using Exporter makes no sense with object-oriented modules. The following program works for me:
#!/usr/bin/perl
{ package M;
use Moose;
use Data::Dumper;
sub x {
my ($self, $stuff) = #_;
print Dumper($stuff);
}
}
{ package Foo;
use Moose;
has mS => ( is => 'ro', default => sub { 'M'->new } );
sub bar {
my ($self, $data) = #_;
my $foo = $self->mS;
$foo->x($data);
}
}
my $foo = 'Foo'->new;
$foo->bar('test');
You have a solution - don't write your own new() method when you're using Moose. But there's one other little point that might be worth making.
The constructor that Moose will give you for your Foo class will work pretty well as a drop-in replacement for your new() method. But the one that Moose gives you for your M class will be missing a feature - it won't print your "M::new!\n" message. How do we get round that?
In Moose, you can define a BUILD() method which will be called immediately after new() has returned a new object. That's a good place to put any extra initialisation that your new object needs. It would also be be a good place for your print() call (although it happens after object construction, not before - so it's not an exact replacement).
I've got a base object called RuleObject and an object that inherits from that called RuleObjectString. I have a new method in RuleObjectString that I want to call in my code that uses that object. But I get the error. 'Can't locate object method "compare" via package "RuleObject" at ./testobject.pl line 10.' But I'm not creating a RuleObject. I'm creating a RuleObjectString. What am I doing wrong here?
testobject.pl
1 #! /usr/bin/perl
2
3 use strict;
4
5 use RuleObjectString;
6
7 my $s = RuleObjectString->new();
8 $s->value('stuff goes here');
9
10 if ($s->compare('stuff')){
11 print "MATCH!\n";
12 }else{
13 print "no match :(\n";
14 }
RuleObject.pm
package RuleObject;
our #ISA = qw/Exporter/;
our #EXPORT = qw/new/;
use strict;
sub new{
my $class = shift;
my $self;
$self->{value} = undef;
bless $self;
return $self;
}
sub value{
my $self = shift;
my $value = shift;
if ($value){
$self->{value} = $value;
}else{
return $self->{value};
}
}
RuleObjectString.pm
package RuleObjectString;
our #ISA = qw/RuleObject/;
our #EXPORT = qw/compare/;
use strict;
sub compare{
my $self = shift;
my $compareto = shift;
return $self->value() =~ /$compareto/;
}
I think jmcneirney is on the right track. In your RuleObject constructor, you say
bless $self;
which is the same as
bless $self, __PACKAGE__;
or
bless $self, 'RuleObject'
but what you want is for the object to blessed as a RuleObjectString. So what you want to do is say
bless $self, $class
Now
RuleObject->new()
RuleObjectString->new()
will both call the same constructor, but the object returned by the first call will be blessed as a RuleObject and the second object will be blessed as a RuleObjectString.
This is 2012, so you should consider using proper OOP solutions instead of reinventing the wheel all over again.
By using Moose, the solution would look something like this (untested):
RuleObject.pm
package RuleObject;
use Moose;
has 'value' => ( isa => 'Str', is => 'rw', required => 0, default => '' );
1;
RuleObjectString.pm
package RuleObjectString;
use Moose;
extends 'RuleObject';
sub compare {
my $self = shift;
my $compareto = shift;
return $self->value =~ /$compareto/;
}
1;
Simple! :)
Try dumping the object and see what it is.
print Dumper( $s )
It's going to be a RuleObject.
You might need to define a new() in RuleObjectString
and have it call Super::new().
I am writing a class that is linked to an external resource. One of the methods is a delete method that destroys the external resource. No further method calls should be made on that object. I was thinking of setting a flag and die'ing inside of all of the methods if the flag is set, but is there a better, easier way? Something involving DESTROY maybe?
So far, I am really liking Axeman's suggestion, but using AUTOLOAD because I am too lazy to recreate all of the methods:
#!/usr/bin/perl
use strict;
use warnings;
my $er = ExternalResource->new;
$er->meth1;
$er->meth2;
$er->delete;
$er->meth1;
$er->meth2;
$er->undelete;
$er->meth1;
$er->meth2;
$er->delete;
$er->meth1;
$er->meth2;
$er->meth3;
package ExternalResource;
use strict;
use warnings;
sub new {
my $class = shift;
return bless {}, $class;
}
sub meth1 {
my $self = shift;
print "in meth1\n";
}
sub meth2 {
my $self = shift;
print "in meth2\n";
}
sub delete {
my $self = shift;
$self->{orig_class} = ref $self;
return bless $self, "ExternalResource::Dead";
}
package ExternalResource::Dead;
use strict;
use Carp;
our $AUTOLOAD;
BEGIN {
our %methods = map { $_ => 1 } qw/meth1 meth2 delete new/;
}
our %methods;
sub undelete {
my $self = shift;
#do whatever needs to be done to undelete resource
return bless $self, $self->{orig_class};
}
sub AUTOLOAD {
my $meth = (split /::/, $AUTOLOAD)[-1];
croak "$meth is not a method for this object"
unless $methods{$meth};
carp "can't call $meth on object because it has been deleted";
return 0;
}
Is there a problem with simply considering the object in an invalid state. If the users hang on to it, isn't that their problem?
Here are some considerations:
Have you already decided whether it's worth dying over?
Chances are that if you have a function that is encapsulated enough, you really don't want to have the users parse through your code. For that purpose, you probably wouldn't like to use what I call the Go-ahead-and-let-it-fail pattern. 'Can't call method "do_your_stuff" on an undefined value' probably won't work as well for encapsulation purposes. Unless you tell them "Hey you deleted the object!
Here are some suggestions:
You could rebless the object into a class whose only job is to indicate an invalid state. It has the same basic form, but all symbols in the table point to a sub that just says "Sorry can't do it, I've been shut down (You shut me down, remember?)."
You could undef $_[0] in the delete. Then they get a nice 'Can't call method "read_from_thing" on an undefined value' from a line in their code--provided that they aren't going through an elaborate decorating or delegation process. But as pointed out by chaos, this doesn't clear up more than one reference (as I've adapted by example code below to show).
Some proof of concept stuff:
use feature 'say';
package A;
sub speak { say 'Meow!'; }
sub done { undef $_[0]; }
package B;
sub new { return bless {}, shift; }
sub speak { say 'Ruff!' }
sub done { bless shift, 'A'; }
package main;
my $a = B->new();
my $b = $a;
$a->speak(); # Ruff!
$b->speak(); # Ruff!
$a->done();
$a->speak(); # Meow!
$b->speak(); # Meow! <- $b made the switch
$a->done();
$b->speak(); # Meow!
$a->speak(); # Can't call method "speak" on an undefined value at - line 28
Ideally, it should fall out of scope. If, for some reason, a proper scope can't be deliniated, and you're worried about references accidentally keeping the resource active, might consider weak references (Scalar::Util is core in at least 5.10).
You could make the users only get weakrefs to the object, with the single strong reference kept inside your module. Then when the resource is destroyed, delete the strong reference and poof, no more objects.
Following on from the comments in my first answer here is "one way" to amend an object behaviour with Moose.
{
package ExternalResource;
use Moose;
with 'DefaultState';
no Moose;
}
{
package DefaultState;
use Moose::Role;
sub meth1 {
my $self = shift;
print "in meth1\n";
}
sub meth2 {
my $self = shift;
print "in meth2\n";
}
no Moose::Role;
}
{
package DeletedState;
use Moose::Role;
sub meth1 { print "meth1 no longer available!\n" }
sub meth2 { print "meth2 no longer available!\n" }
no Moose::Role;
}
my $er = ExternalResource->new;
$er->meth1; # => "in meth1"
$er->meth2; # => "in meth2"
DeletedState->meta->apply( $er );
my $er2 = ExternalResource->new;
$er2->meth1; # => "in meth1" (role not applied to $er2 object)
$er->meth1; # => "meth1 no longer available!"
$er->meth2; # => "meth2 no longer available!"
DefaultState->meta->apply( $er );
$er2->meth1; # => "in meth1"
$er->meth1; # => "in meth1"
$er->meth2; # => "in meth2"
There are other ways to probably achieve what you after in Moose. However I do like this roles approach.
Certainly food for thought.
With Moose you can alter the class using its MOP underpinnings:
package ExternalResource;
use Moose;
use Carp;
sub meth1 {
my $self = shift;
print "in meth1\n";
}
sub meth2 {
my $self = shift;
print "in meth2\n";
}
sub delete {
my $self = shift;
my %copy; # keeps copy of original subref
my #methods = grep { $_ ne 'meta' } $self->meta->get_method_list;
for my $meth (#methods) {
$copy{ $meth } = \&$meth;
$self->meta->remove_method( $meth );
$self->meta->add_method( $meth => sub {
carp "can't call $meth on object because it has been deleted";
return 0;
});
}
$self->meta->add_method( undelete => sub {
my $self = shift;
for my $meth (#methods) {
$self->meta->remove_method( $meth );
$self->meta->add_method( $meth => $copy{ $meth } );
}
$self->meta->remove_method( 'undelete' );
});
}
Now all current and new instances of ExternalResource will reflect whatever the current state is.