How to create (or not) class instance methods at construction time based on inputs? - perl

How would I create my class such that some methods will exist in the instance only if certain values were passed to the constructor?
Perhaps a more generic way of asking is: How can I add a method to an existing class instance?

You can attach an anonymous sub to an object based on flags:
use strict;
use warnings;
package Object;
sub new {
my $class = shift;
my $self = bless {}, $class;
my %args = #_;
if ($args{method}) {
$self->{method} = sub { print "hello\n" }
}
return $self;
}
sub method {
my $self = shift;
if (not defined $self->{method}) {
warn "Not bound\n";
return;
}
$self->{method}->();
}
1;
to use:
use Object;
my $obj1 = Object->new(method=>1);
$obj1->method();
my $obj2 = Object->new();
$obj2->method();
You can extend this to a number of methods through the same interface.

You can use Moose to apply a role at runtime.
package My::Class;
use Moose;
has foo => ( isa => 'Str', is => 'ro', required => 1 );
sub BUILD {
my $self = shift;
if ($self->foo eq 'bar') {
My::Class::Role->meta->apply($self);
}
}
no Moose;
package My::Class::Role;
use Moose::Role;
sub frobnicate {
my $self = shift;
print "Frobnicated!\n";
}
no Moose;
my $something = My::Class->new( foo => 'bar' );
print $something, "\n";
$something->frobnicate;
my $something_else = My::Class->new( foo => 'baz' );
print $something_else, "\n";
$something_else->frobnicate;
Gives:
Moose::Meta::Class::__ANON__::SERIAL::1=HASH(0x2fd5a10)
Frobnicated!
My::Class=HASH(0x2fd2c08)
Can't locate object method "frobnicate" via package "My::Class" at testmoose.pl line 32.

use AUTOLOAD to define the function. As a example method foo is called if $self->{foo} exists
sub AUTOLOAD {
my $methodname = $AUTOLOAD;
if ($methodname eq "foo" && exists($_[0]->{foo})){
goto &fooimplementationsub;
}
return;
}
An alternative technique is to use globs to define a new method at runtime
*PACKAGE::method = sub {
#code here
};
This has the disadvantage that the method is now visible to all instances of the class so is not quite what you want.
A third and possibly more risky/inefficient method is to use string eval
eval <<EOF
sub foo {
#code here
};
EOF
Again this has the disadvantage that the method is now visible to all instances of the class so is not quite what you want.

Methods are just subroutines in a package, and a package is just a hash holding typeglobs. And hashes can be modified at runtime.
So you could, in theory, add or remove methods given values in a constructor.
package WeirdClass;
sub new {
my ($class, $name, $code) = #_;
if ($name) {
no strict;
*{__PACKAGE__ . "::$name"} = $code;
}
bless {} => $class;
}
And then use it like:
my $object = WeirdClass->new(foo => sub {say "foo"});
$object->foo(); # prints "foo\n";
However, this method is available for all objects of that class:
my $another_object = WeirdClass->new();
$another_object->foo; # works too.
Using autoload, one can mock arbitrary methods:
package BetterClass;
sub new {
my ($class, %args) = #_;
bless \%args => $class;
}
# destructor will be called at cleanup, catch with empty implementation
sub DESTROY {};
sub AUTOLOAD {
my $self = shift;
(my $method = our $AUTOLOAD) =~ s/.*://; # $AUTOLOAD is like "BetterClass::foo"
# check if method is allowed
die "forbidden method $method" unless $self->{can}{$method};
# mock implementations
given ($method) {
say "foo" when "foo";
say "bar" when "bar";
when ("add") {
my ($x, $y) = #_;
return $x + $y;
}
default { die "unknown method $method" }
}
}
Then:
my $o = BetterClass->new(can => { foo => 1, bar => 0});
$o->foo;
my $p = BetterClass->new(can => {bar => 1, add => 1});
$p->bar;
say $p->add(5, 6);
Of course, these techniques can be combined freely.
Edit: can()
To make the AUTOLOAD work with can, the protected methods should be moved into a data structure:
my %methods;
BEGIN {
%methods = (
foo => sub {say "foo"},
bar => sub {say "bar"},
add => sub {
my ($self, $x, $y) = #_;
$x + $y;
},
);
}
Then override the can method:
# save a reference to the origional `can` before we override
my $orig_can;
BEGIN{ $orig_can = __PACKAGE__->can("can") }
sub can {
my ($self, $meth) = #_;
# check if we have a special method
my $code = $methods{$meth} if ref $self and $self->{can}{$meth};
return $code if $code;
# check if we have a normal method
return $self->$orig_can($meth);
}
And AUTOLOAD would change to
my ($self) = #_; # do not `shift`
(my $method = our $AUTOLOAD) =~ s/.*://;
my $code = $self->can($method) or die "unknown method $method";
goto &$code; # special goto. This is a AUTOLOAD idiom, and avoids extra call stack frames

Don't do too much magic. I've gotten away from AUTOLOAD because it causes maintenance issues where mysterious methods suddenly appear and disappear.
One way to handle what you want is to define all the methods you need, and if a particular object is of the wrong type, simply cause that method to croak:
sub Foo {
my $self = shift;
my $parameter = shift;
if ( $self->Class_type ne "Foo" ) {
croak qq(Invalid method 'Foo' on object #{[ref $self]});
}
print "here be dragons\";
return "Method 'Foo' successfully called";
}
The above will not allow method Foo to be called unless the class type is Foo.
If your objects won't change (or you don't want them to change) once an object is created, you can define that object as a sub-class.
Before you bless a newly created object, check that special value and decide whether or not you need to create a specific sub-class instead.
package My_class;
sub new {
my $class = shift;
my $class_type = shift;
my $self = shift;
if ( $class_type eq "Foo" ) {
bless $self, "My_class::Foo";
}
else {
bless $self, $class;
}
package My_class::Foo;
use base qw(My_class);
sub Foo {
my $self = shift;
return "Foo Method successfully called!";
}
Notice that my class My_class::Foo is a sub-class of My_class via the use base pragma. That means all methods for My_class are valid with objects of My_class::Foo. However, only objects of My_class::Foo can call the Foo method.
When I create my object (via the new subroutine), I look at the $class_type parameter. If it's a type Foo, I bless the class as My_class::Foo.
Here's an example where I use sub-classes to do what you want.
Every object is a class type of Question. You can see my constructor on line 1129. I pass in a question type as one of the parameters to my constructor.
In line 1174 to 1176, I create my object, but then append the question type to the class, and then bless the question as that sub-class type. All of my subclasses are a type Question (see my use base qw(Question); below each package declaration. However, only questions of sub-class Question::Date and Question::Regex have a method Format. And, only objects of type Question::Words have a method Force.
Hope this helps.

None of the answers so far given actually handle the question actually asked.
Adding methods to an instance in Perl is not directly supported. Object instances are always instances of some class, and that class is the thing that actually has methods. You cannot add a method to a single instance of a class, without making that method also available on every other instance of the same class.
For your problem you have two basic solutions:
Provide the methods always, but test a flag to see whether the method should apply to the given instance or not. This is by far the simplest.
Bless each object into subclasses depending on the flags. Subclass the main class to provide those methods as appropriate.
If you truely want to add methods on individual instances, then what you'll have to do is arrange that every instance is a single instance of a newly-derived class for every object. This gets harder to arrange for, doubly-so if you want to avoid leaking memory and cleaning up the classes once the objects are DESTROYed. This would however allow truely per-instance methods.
Since it is highly unlikely you'll truely need this third option it is far better to go with one of the first.

Related

Using Perl's Method::Signatures, why can't I invoke methods on an object instance?

I followed what friedo said here.
Now, when I try to call the method testScript I get the error global symbol $obj requires explicit package name and it fails to call testScriptTwo.
use strict;
use warnings;
package Test;
use Method::Signatures;
method new {
my $obj = bless {}, $self;
return $obj;
}
method testScript {
$obj->testScriptTwo(); # Error happens here
}
method testScriptTwo { ... }
Test script:
use Test;
my $class = Test->new();
$class->testScript();
How do I make use of $obj to call methods within the package itself?
Use this instead:
method testScript {
$self->testScriptTwo();
}
The first argument is in the variable $self, not $obj
Your questions seem to indicate you do not understand the basics of scope, and how plain Perl objects work.
In Perl, when you use the ->method syntax on a package name or blessed reference, the subroutine method in that package is invoked. The first argument to the subroutine is the thing on which you invoked method.
So, if you do
My::Friend->new('Alfred');
the new subroutine in the package My::Friend receives two arguments. My::Friend and Alfred.
In a new method, it is customary to refer to the first argument as $class, but that is completely up to you. You could use $basket_case if you were so inclined:
sub new {
my $basket_case = shift;
my $basket = shift;
my $obj = bless { name => $basket } => $basket_case;
return $obj;
}
If you then invoke a method on the returned reference, that method will receive said reference as its first argument, allowing you to access data stored in that reference:
sub blurb {
my $schmorp = shift;
print $schmorp->{name}, "\n";
return;
}
Putting it all together:
#!/usr/bin/env perl
package My::Package;
use strict;
use warnings;
sub new {
my $basket_case = shift;
my $basket = shift;
my $obj = bless { name => $basket } => $basket_case;
return $obj;
}
sub blurb {
my $schmorp = shift;
print $schmorp->{name}, "\n";
return;
}
sub derp {
my $herp = shift;
printf "%s derp derp\n", $herp->{name};
return;
}
package main;
my $x = My::Package->new('Alfred');
$x->blurb;
$x->derp;
Output:
Alfred
Alfred derp derp
You need to understand these basics. Trying to put another layer of abstraction on top of the basics before understanding what is underneath will not make things any easier.
Now, if you are using Method::Signatures, it, by convention, puts that implicit first argument in a lexically scoped variable which, by default, it calls $self.
You can override that name in specific methods, and doing so in new might be a good idea to convey the fact that it doesn't expect an object instance; instead it returns a new instance.
Whatever you called that lexically scoped instance variable in one sub does not affect what it is called in another sub. For example:
#!/usr/bin/env perl
use strict;
use warnings;
sub a_number {
my $number = int(rand(10));
return $number;
}
sub square_that_number {
my $x = shift;
return $x * $x;
}
my $bzzzt = a_number();
my $trrrp = square_that_number($bzzzt);
print $trrrp, "\n";
Output:
$ ./zt.pl
36
OK, you need to backtrack a bit - you're new method is broken in the first place, which indicates that you don't really understand what's going on with OO perl.
A very simple object looks like this:
package Foo;
sub new {
#when Foo -> new is called, then 'Foo' is passed in as the class name
my ( $class ) = #_;
#create an empty hash reference - can be anything, but $self is the convention
my $self = {};
#tell perl that $self is a 'Foo' object
bless ( $self, $class );
#return the reference to your `Foo` object
return $self;
}
sub set_name {
my ( $self, $new_name ) = #_;
$self -> {name} = $new_name;
}
sub get_name {
my ( $self ) = #_;
return $self -> {name};
}
When you call this in your code:
use Foo;
my $new_instance = Foo -> new();
The class is passed into the new method, which you then use bless to create an instantiated object.
Then you can 'do stuff' with it - when you 'call' a method using -> then the first argument into the subroutine is the object reference.
So
$new_instance -> set_name ( "myname" );
print $new_instance -> get_name();
Is equivalent to:
Foo::set_name($new_instance, "myname" );
print Foo::get_name($new_instance);
You act on $new_instance which is a sort of magic hash that allows you to include code.
Method::Signatures is largely irrelevant until you understand the basics of OO. But what that does is 'simply' expand the functions within a module, such that you don't have to extract self/class etc.
By default, a method defined as method provides $self automatically. no $obj like you're using. That's a variable that's local to you new method, and simply doesn't exist outside that.

Extending a Perl non-Moose respecting encapsulation

I have a legacy project and I would like to extend a couple of classes in it with a few attributes and methods. I have access to the source code and know that the class uses a blessed hashref. I can of course go ahead and extend that hashref adding the keys that I want and re-bless into my class. But obviously this breaks encapsulation and I would like to avoid it as much as I can.
Is there a way to extend a (non-Moose) Perl class with attributes, not just methods, in a way that does not break encapsulation of the orginal class? The option to use Moose to do this is not available. Thank you.
First, one best practice for writing objects based on hashrefs is to prefix all fields with the package name, e.g.
package Parent;
sub new {
my ($class, $x, $y) = #_;
bless { "Parent::x" => $x, "Parent::y" => $y } => $class;
}
sub x { shift()->{"Parent::x"} }
sub y { shift()->{"Parent::y"} }
In that case, the issue doesn't arise, as every class has its own attribute namespace. But who writes his classes that way?
There are two ways I can think of to circumvent any problems: Proxying the original object via Autoload, or using inside-out object patterns. The third solution is to use prefixed attributes in your class, and hope that the parent never ever uses these names.
Inside-Out Objects
An inside-out object uses the blessed reference as an ID, and stores the attributes in lexical variables inside your class:
package Child;
use Scalar::Util qw/refaddr/;
use parent 'Parent';
my %foo;
sub new {
my ($class, $foo, #args) = #_;
my $self = $class->SUPER::new(#args);
$foo{refaddr $self} = $foo;
return $self;
}
sub foo {
my ($self) = #_;
$foo{refaddr $self};
}
sub set_foo {
my ($self, $val) = #_;
$foo{refaddr $self} = $val;
}
sub DESTROY {
my ($self) = #_;
# remove entries for this object
delete $foo{refaddr $self};
$self->SUPER::DESTROY if $self->SUPER::can('DESTROY');
}
This is a slightly dated pattern, but it works extremely well for your use case.
Proxy objects
We can contain a parent instance in a field of our class (i.e. both has-a and is-a relationship). Whenever we encounter unknown methods, we delegate to that object:
package Child;
use Parent ();
our $SUPER = 'Parent';
use Carp;
sub new {
my ($class, $foo, #args) = #_;
bless {
parent => $SUPER->new(#args),
foo => $foo,
} => $class;
}
sub foo {
my ($self) = #_;
$self->{foo};
}
sub set_foo {
my ($self, $val) = #_;
$self->{foo} = $val;
}
# manually establish pseudo-inheritance
# return true if our class inherits a given package
sub isa {
my ($self, $class) = #_;
return !!1 if $class eq __PACKAGE__;
return +(ref $self ? $self->{parent} : $SUPER)->isa($class);
}
# return a coderef to that method, or false
sub can {
my ($self, $meth) = #_;
my %methods = (new => \&new, foo => \&foo, set_foo => \&set_foo, DESTROY => \&DESTROY);
if (my $code = $methods{$meth}) {
return $code;
}
# check parent
my $code = ( ref $self ? $self->{parent} : $SUPER)->can($meth);
return undef unless $code;
return sub {
my $self = shift;
unshift #_, ref $self ? $self->{parent} : $self;
goto &$code;
};
}
# write explicit destroy to satisfy autoload
sub DESTROY {
my ($self) = #_;
$self->{parent}->DESTROY if ref $self and $SUPER->can('DESTROY');
}
sub AUTOLOAD {
# fetch appropriate method coderef
my $meth = our $AUTOLOAD;
$meth =~ s/.*:://; # clean package name from name
my $code = $_[0]->can($meth);
$code or croak qq(Can't locate object method "$meth" via package "#{[__PACKAGE__]}");
goto &$code;
}
The ugly part is to fake methods defined in superclasses in the can code: We have to wrap the actual method inside a anonymous sub that unpacks our object to call the method on the proxied object. The gotos make our extra levels invisible to the called code, which is neccessary when somebody uses caller.
Most of this boilerplate proxying code can be abstracted into another module (and probably is, somewhere on CPAN).

Perl encapsulate class variable?

I'm pretty new to perl, and I'm getting stuck on a homework problem. I have an object with a class variable that counts the number of instances created. Then I have a subclass with an instance variable.
My first question is, how do I make the class variable hidden from the user? I tried using closures but couldn't figure out how to make inheritance work with that. And the fact that it's a class variable made it worse because the code that increments it executed twice and it said I had two instances when I had one. Not exactly sure why it happened but it makes sense. I tried using scalars but the variable again wasn't incrementing correctly. Haven't tried "inside-out objects" yet and I'm not sure I want to, it seems way over my head. I'm getting the feeling that encapsulating class variables is different than encapsulating instance variables, but I can't find anything that explains how to do it.
My second questions is, as I mentioned, I can't get encapsulation to work with inheritance. With closures when you call the super constructor from the subclass you get a reference to the subroutine right, so there's no way (that I know of) to add the instance variables to that.
Here's my base class:
#!/usr/bin/perl -w
use strict;
package Base;
my $count = 1;
sub new {
my $class = shift;
my $self = {
_Count => $count # not hidden
};
$count++; # increment count
bless $self, $class;
return $self;
}
sub Count { # getter
my $self = shift;
return $self->{_Count};
}
1;
Here's my subclass:
#!/usr/bin/perl -w
use strict;
package Sub;
use Base;
our #ISA = qw(Base);
sub new {
my $class = shift;
my $self = $class->SUPER::New();
$self->{_Name} = undef; # not hidden
return $self;
}
sub Name { #getter/setter
my($self, $name) = #_;
$self->{_Name} = $name if defined($name);
return $self->{_Name};
}
1;
If you are using bare Perl 5 (rather than employing an OO framework), the usual way to do class variables is as a lexical visible only to the accessor:
{
my $count = 0;
sub Count {
my ($self, $new_count) = #_;
if (defined $new_count) { # NB only works if undef is not a legit value
$count = $new_count;
}
return $count;
}
}
$count is only visible in the enclosing block; not even other methods on the same class can see it. But anyone can manipulate it with either $base_obj->Count or Base->Count, and any such manipulation will affect the shared variable.
You can also employ closure to provide really-hidden instance variables. This is not worth doing unless you are fulfilling the arbitrary rules of a homework assignment.
package Base;
sub new {
my ($class, $name) = #_;
die "Need name!" unless defined $name;
my $age;
return bless sub {
my ($attribute, #args) = #_;
if ($attribute eq 'name') {
if (#args) {
die "Attempt to set read-only attribute!";
}
return $name;
}
if ($attribute eq 'age') {
if (#args) {
($age) = #args;
}
return $age;
}
die "Unknown attribute $attribute";
} => $class;
}
sub name {
my ($self, #args) = #_;
return $self->(name => #args);
}
sub age {
my ($self, #args) = #_;
return $self->(age => #args);
}
What happens here is that the blessed sub returned by new closes over two lexicals, $name and $age. When new returns, those lexicals go out of scope and the only way to access them from that point forward is through the closure. The closure can inspect its arguments to permit or deny access to the values it holds. So long as it never returns a reference, it can be sure that it has the only direct access to those variables.
This works with inheritance, too, without too much added subtlety:
package Derived;
use base 'Base';
sub new {
my ($class, $name, $color) = #_;
my $base_instance = $class->SUPER::new($name);
return bless sub {
my ($attribute, #args) = #_;
if ($attribute eq 'color') {
if (#args) {
($color) = #args;
}
return $color;
}
# base class handles anything we don't, possibly by dying
return $base_instance->($attribute, #args);
} => $class;
}
This emulates what languages with distinct storage for base- and derived-class instance data do, either handling the request locally or passing it on to the base class instance, which has been added to the closure. Deeper inheritance trees will result in closures that close over closures that close over closures, each of them optionally also closing over instance variables needed by that particular class.
This is a pretty big mess to produce and really hard to inspect and debug, which is why I'm going to emphasize one more time that you should never do this. But it is very useful to understand, to which end I refer you to SICP.
As a module-local my variable, $count is already hidden from users of the module/class. It appears as if you're using instance variable _Count as a "current ID" type variable, so that each object (instance) created gets a new ID starting from 1. (If instead it is meant to track the number of active instances, then you need to decrement it in DESTROY and there's no need to store a copy in the object.) If your test code is only creating one instance then its Count() method should return 1 but $count will be 2, since it started as 1 and was incremented after storing the old value in the object.
It is typical in perl to store instance variables in the $self hash as you are doing, without hiding them, although sometimes a prefix is used to avoid collisions. They are protected more by convention (it's not safe to rely on implementation details because they might change) than language features.
Take a look at the Moose suite of modules if you want higher-level control over perl classes.
To quote perldoc perlmodlib, "Perl does not enforce private and public parts of its modules as you may have been used to in other languages like C++, Ada, or Modula-17. Perl doesn't have an infatuation with enforced privacy. It would prefer that you stayed out of its living room because you weren't invited, not because it has a shotgun."
The standard convention in Perl is to put everything into the $self hash and use an underscore prefix to indicate which items should be treated as private... and then trust users of the class to respect that indication. The same convention is also applied to methods. If you use one of my modules and you choose to peek under the covers and modify the contents of $self directly or call $obj->_some_private_method, then you're going off into the woods and may break something, or what works fine in this version may break when you upgrade to the next version; if that happens, you get to keep both pieces.
If you're going to insist on making data inaccessible to anyone outside the class itself, there are ways to do that, but a) they add complexity which is, in almost all cases, unnecessary and b) as you've already seen, they have a tendency to make inheritance a lot more of a hassle to work with.
My question to you, then, is what are you actually attempting to accomplish and why do you feel the need to make your object data Sooper-Sekret and completely inaccessible? What benefit will you gain by doing so which isn't provided by simply marking things that you think should be treated as private, then trusting others to leave them alone (unless they have good reason to do otherwise)?
In Perl, fields are not usually hidden by enforcing this through the semantics of the language, but rather through a contract in the form of documentation. However, fields can be hidden through the use of closures. It is also worth noting that Perl does not semantically differentiate between class methods and instance methods.
One of the standard ways to implement objects is a blessed hash, like you do. This hash contains all instance variables / fields. It is customary to start "private" fields with an underscore. Usually, the contract (the documentation) will not state how these fields are stored, but will require the user of the class to go through various method calls.
Class variables should not be stored with the instance. It is better to use global variables, or lexical variables. In the code you gave, $count is just a counter, but you never access it as a class variable. Instead, you assign each instance an unique ID. To use it as a class variable, provide an appropriate accessor (I stripped out unneccessary stuff like returns):
{
package Base;
my $count = 0;
sub new {
my ($class) = #_;
my $self = {
ID => $count++,
};
bless $self, $class;
}
sub Count { $count }
sub ID { my ($self) = #_; $self->{ID} }
sub report { my ($self) = #_; "I am the Base object ".($self->ID)."." }
}
=head1 Base
A generic base class
=head2 Base->Count
Return the object count.
=head2 $base->ID
Give the unique ID of this object.
=head2 $base->report
Returns a string containing a short description.
=cut
The subclass has no business meddling with the count. This is enforced by the scope of the variable $count above, denoted via the outer curly braces. The subs are closures over this variable.
{
package Sub;
use parent -norequire, qw(Base); # remove `-norequire` if Base in different file
sub new {
my ($class) = #_;
my $self = $class->SUPER::new;
$self->{Name} = undef;
$self;
}
sub Name :lvalue {
my ($self) = #_;
$self->{Name};
}
sub report {
my ($self) = #_;
"I am the Sub object ".($self->ID)." called ".($self->Name).".";
}
}
=head1 Sub
A generic subclass. It subclasses Base.
=head2 $sub->Name [= SCALAR]
Gets or sets the name of $sub.
my $oldname = $sub->Name;
$sub->name = "new name";
=cut
As you can see, the Sub constructor calls the Base initializer, then adds a new field. It has no class methods or class variables. The class has no access to the $count variable, except via the accessor class method. The contract is stated via POD documentation.
(In the Name method, I use an :lvalue annotation. This allows me to simply assign to the appropriate field in the object. However, this disallows argument checking.)
The testcase
my $base1 = Base->new; my $base2 = Base->new;
print "There are now " . Base->Count . " Base objects\n";
my $sub1 = Sub->new; my $sub2 = Sub->new;
print "There are now " . Base->Count . " Base objects\n";
$sub2->Name = "Fred";
print $_->report . "\n" for ($base1, $sub1, $base2, $sub2);
prints
There are now 2 Base objects
There are now 4 Base objects
I am the Base object 0.
I am the Sub object 2 called .
I am the Base object 1.
I am the Sub object 3 called Fred.
Beautiful, isn't it? (Except $sub1, that object is missing its name.)
The documentation can be viewed with perldoc -F FILENAME, and would output something like
Base
A generic base class
Base->Count
Return the object count.
$base->ID
Give the unique ID of this object.
$base->report
Returns a string containing a short description.
Sub
A generic subclass. It subclasses Base.
$sub->Name [= SCALAR]
Gets or sets the name of $sub.
my $oldname = $sub->Name;
$sub->name = "new name";
only typeset more nicely, if you are on a *nix system.
Tested under v5.12.4.
Edit: Inside-out objects
While inside-out objects provide better encapulation, they are a bad idea: difficult to understand, difficult to debug, and difficult to inherit they provide more problems than solutions.
{
package Base;
my $count = 0;
sub new { bless \do{my $o = $count++}, shift }
sub Count { $count }
sub ID { ${+shift} }
sub report { my ($self) = #_; "I am the Base object ".($self->ID)."." }
}
{
package Sub;
my #_obj = ();
my $count = 0;
sub new {
my ($class) = #_;
$count++;
$_obj[$count - 1] = +{
parent => Base->new(),
Name => undef,
};
bless \do{my $o = $count - 1}, shift;
}
sub Name :lvalue { $_obj[${+shift}]{Name} }
sub AUTOLOAD {
my $self = shift;
my $package = __PACKAGE__ . "::";
(my $meth = $AUTOLOAD) =~ s/^$package//;
$_obj[$$self]{parent}->$meth(#_)
}
sub report {
my ($self) = #_;
"I am the Sub object ".($self->ID)." called ".($self->Name).".";
}
}
This implementation has the exact same interface, and completes the test case with the same output. This solution is far from optimal, supports only single inheritance, does some intermediate stuff (autoloading, dynamic method calls), but it does suprisingly work. Each object is actually just a reference to an ID that can be used to look up the actual hash containing the fields. The array holding the hashes is not accessible from the outside. The Base class has no fields, therefore no object array had to be created.
Edit2: Objects as coderefs
Yet another bad idea, but it is fun to code:
{
package Base;
my $count = 0;
sub new {
my ($class) = #_;
my $id = $count++;
bless sub {
my ($field) = #_;
die "Undefined field name" unless defined $field;
if ($field eq "ID") { return $id }
else { die "Unrecognised name $field" }
}, $class;
}
sub Count { $count }
sub ID { my ($self) = #_; $self->("ID") }
sub report { my ($self) = #_; "I am the Base object " . $self->ID . "." }
}
{
package Sub;
use parent -norequire, qw(Base);
sub new {
my ($class) = #_;
my $name = undef;
my $super = $class->SUPER::new;
bless sub {
my ($field, $val ) = #_;
die "Undefined field name" unless defined $field;
if ($field eq "Name") { defined $val ? $name = $val : $name }
else { $super->(#_) }
}, $class;
}
sub Name { my $self = shift; $self->("Name", #_) }
sub report {
my ($self) = #_;
"I am the Sub object ".($self->ID)." called ".($self->Name).".";
}
}
The test case has to be adapted to $sub2->Name("Fred"), and the documentation updated accordingly, as we cannot use an lvalue annotation here safely.
First, I'm not sure exactly what you mean by "hidden from the user", but it looks like you may be looking for package scoped variables (our) vs. instance scoped.
package MyBaseClass;
use warnings;
use strict;
our $counter = 0;
sub new {
my $class = shift;
$counter++;
return bless {}, $class;
}
sub howManyInstances {
return $counter;
}
1;
On your second question, I'm not sure what closures have to do with inheritance.
Here's a simple subclass:
package MySubClass;
use warnings;
use strict;
use parent 'MyBaseClass'; # use parent schema, don't mess with #ISA
sub new {
my $class = shift;
my $self = $class->SUPER::new(#_);
$self->{_name} = undef;
return $self;
}
# Your setter/getter looks ok as is, though lowercase is tradional for methods/subs
1;
Now, if this were real code you would not do it like this - you would use Moo or Moose.

How to make "universal" getters and setters in an object in perl?

How do you make one setter method, and one getter method to manage access to fields of an object? The new subroutine looks like this:
sub new {
my $class = shift;
my $self = {#_};
bless($self,$class); # turns this into an object
}
Creation of a new object looks like this:
$foo = Package::new("Package",
"bar", $currentBar,
"baz", $currentBaz,
);
This is not a good idea.
Perl instituted the use of use strict; to take care of problems like this:
$employee_name = "Bob";
print "The name of the employee is $employeeName\n";
Mistyped variable names were a common problem. Using use strict; forces you to declare your variable, so errors like this can be caught at compile time.
However, hash keys and hash references remove this protection. Thus:
my $employee[0] = {}
$employee[0]->{NAME} = "Bob";
print "The name of the employee is " . $employee[0]->{name} . "\n";
One of the reasons to use objects when you start talking about complex data structures is to prevent these types of errors:
my $employee = Employee->new;
$employee->name("Bob");
print "The name of the employee is " . $employee->Name . "\n";
This error will get caught because the method name is name and not Name.
Allowing users to create their own methods at random removes the very protection we get by using objects:
my $employee = Employee->new;
$employee->name("Bob"); #Automatic Setter/Getter
print "The name of the employee is " . $employee->Name . "\n"; #Automatic Setter/Getter
Now, because of automatic setters and getters, we fail to catch the error because any method the user names is valid -- even if that user made a mistake.
In fact, I setup my objects so my object doesn't necessarily know how it's structured. Observe the following class with methods foo and bar:
sub new {
my $class = shift;
my $foo = shift;
my $bar = shift;
my $self = {};
bless $self, $class;
$self->foo($foo);
$self->bar($bar);
return $self;
}
sub foo {
my $self = shift;
my $foo = shift;
my $method_key = "FOO_FOO_FOO_BARRU";
if (defined $foo) {
$self->{$method_key} = $foo;
}
return $self->{$method_key};
}
sub bar {
my $self = shift;
my $bar = shift;
my $method_key = "BAR_BAR_BAR_BANNEL";
if (defined $bar) {
$self->{$method_key} = $bar;
}
return $self->{$method_key};
}
I can set the class values for foo and bar in my constructor. However, my constructor doesn't know how those values are stored. It simply creates the object and passes it along to my getter/setter methods. Nor, do my two methods know how they store each other's value. That's why I can have such crazy names for my method's hash keys because that is only available in the method and no where else.
Instead, my methods foo and bar are both setters and getters. If I give them a value for foo or bar, that value is set. Otherwise, I simply return the current value.
However, I'm sure you already know all of this and will insist this must be done. Very well...
One way of handling what you want to do is to create an AUTOLOAD subroutine. The AUTOLOAD subroutine automatically is called when there's no other method subroutine by that name. The $AUTOLOAD contains the class and method called. You can use this to setup your own values.
Here's my test program. I use two methods bar and foo, but I could use any methods I like and it would still work fine
One change, I use a parameter hash in my constructor instead of a list of values. No real difference except this is considered the modern way, and I just want to be consistent with what everyone else does.
Also notice that I normalize my method names to all lowercase. That way $object->Foo, $object->foo, and $object-FOO are all the same method. This way, I at least eliminate capitalization errors.
use strict;
use warnings;
use feature qw(say);
use Data::Dumper;
my $object = Foo->new({ -bar => "BAR_BAR",
-foo => "FOO_FOO",
}
);
say "Foo: " . $object->foo;
say "Bar: " . $object->bar;
$object->bar("barfu");
say "Bar: " . $object->bar;
say Dumper $object;
package Foo;
sub new {
my $class = shift;
my $param_ref = shift;
my $self = {};
bless $self, $class;
foreach my $key (keys %{$param_ref}) {
# May or may not be a leading dash or dashes: Remove them
(my $method = $key) =~ s/^-+//;
$self->{$method} = $param_ref->{$key};
}
return $self;
}
sub AUTOLOAD {
my $self = shift;
my $value = shift;
our $AUTOLOAD;
( my $method = lc $AUTOLOAD ) =~ s/.*:://;
if ($value) {
$self->{$method} = $value;
}
return $self->{$method};
}
Something like this...
sub get {
my $self = shift;
my $field = shift;
return $self->{$field};
}
sub set {
my $self = shift;
my $field = shift;
$self->{$field} = shift;
}
...makes it possible to write
$obj->set(foo => 'my foo value');
print $obj->get('foo');
But nowadays, it is very common to just use Moose.

perl subroutine reference

I have a set of fields with each field having different set of validation rules.
I have placed the subroutine reference for validating a hash-ref.
Currently its in my constructor, but I want to take it out of my constructor in a private sub.
I have done it as below
sub new {
my $class = shift;
my $self = {#_};
$class = (ref($class)) ? ref $class : $class;
bless($self, $class);
$self->{Validations} = {
Field1 => {name => sub{$self->checkField1(#_);},args => [qw(a b c)]}
Field2 => {name => sub{$self->checkField2(#_);},args => {key1, val1}}
..
..
..
..
};
return $self;
}
Now I want to take out all this validation rules out of my constructor and want to do some thing like below, so that I have some better control over my validation rules based on types fields.(Say some rules are common in one set of fields and I can overwrite rules for other rules just by overwriting the values of fields.)
bless($self, $class);
$self->{Validations} = $self->_getValidation($self->{type});
return $self;
}
sub _getValidation{
my ($self,$type) = #_;
my $validation = {
Field1 => {name => sub {$self->checkField1(#_);}, args => {key1 => val1}},};
return $validation;
}
But I am getting Can't use string ("") as a subroutine ref while "strict refs" in use at... Can anybody tell me why is this behavior with sub ref. If I check my name key, its coming to be null or sub {DUMMY};
It looks to me like you are getting close to reinventing Moose poorly. Consider using Moose instead of building something similar, but less useful.
The error message means that you are passing in a string in a place where your code expects a code reference. Get a stack trace to figure out where the error is coming from.
You can do this by using Carp::Always, overriding the $SIG{__DIE__} handler to generate a stack trace, or inserting a Carp::confess into your code.
Here's a sigdie solution, stick this in your code where it will run before your module initialization:
$SIG{__DIE__} = sub { Carp::confess(#_) };
You may need to put it in a BEGIN block.
I'd really like to discourage you from taking this approach to building objects. You happily bless any random crap passed in to the constructor as part of your object! You blithely reach into your object internals. Field validation rules *do not belong in the constructor--they belong in the attribute mutators.
If you must use a DIY object, clean up your practices:
# Here's a bunch of validators.
# I set them up so that each attribute supports:
# Multiple validators per attribute
# Distinct error message per attribute
my %VALIDATORS = (
some_attribute => [
[ sub { 'foo1' }, 'Foo 1 is bad thing' ],
[ sub { 'foo2' }, 'Foo 2 is bad thing' ],
[ sub { 'foo3' }, 'Foo 3 is bad thing' ],
],
other_attribute => [ [ sub { 'bar' }, 'Bar is bad thing' ] ],
);
sub new {
my $class = shift; # Get the invocant
my %args = #_; # Get named arguments
# Do NOT make this a clone method as well
my $self = {};
bless $class, $self;
# Initialize the object;
for my $arg ( keys %args ) {
# Make sure we have a sane error message on a bad argument.
croak "Bogus argument $arg not allowed in $class\n"
unless $class->can( $arg );
$self->$arg( $args{$arg} );
}
return $self;
}
# Here's an example getter/setter method combined in one.
# You may prefer to separate get and set behavior.
sub some_attribute {
my $self = shift;
if( #_ ){
my $val = shift;
# Do any validation for the field
$_->[0]->($val) or croak $_->[1]
for #{ $VALIDATORS{some_attribute} || [] };
$self->{some_attribute} = $val;
}
return $self->{some_attribute};
}
All this code is very nice, but you have to repeat your attribute code for every attribute. This means a lot of error-prone boilerplate code. You can get around this issue by learning to use closures or string eval to dynamically create your methods, or you can use one of Perl's many class generation libraries such as Class::Accessor, Class::Struct, Accessor::Tiny and so forth.
Or you can learn [Moose][3]. Moose is the new(ish) object library that has been taking over Perl OOP practice. It provides a powerful set of features and dramatically reduces boilerplate over classical Perl OOP:
use Moose;
type 'Foo'
=> as 'Int'
=> where {
$_ > 23 and $_ < 42
}
=> message 'Monkeys flew out my butt';
has 'some_attribute' => (
is => 'rw',
isa => 'Foo',
);
I haven't read everything you had, but this struck me:
sub new {
my $class = shift;
my $self = {#_};
$class = (ref($class)) ? ref $class : $class;
bless($self, $class);
Normally, when you create a new object, the user doesn't pass $self as one of the objects. That's what you're creating.
You usually see something like this:
sub new {
my $class = shift; #Contains the class
my %params = #_; #What other parameters used
my $self = {}; #You're creating the $self object as a reference to something
foreach my $param (keys (%params)) {
$self->{$param} = $params{$param};
}
bless ($self, $class) #Class is provided. You don't have to check for it.
return $self #This is the object you created.
}
Now, $self doesn't have to be a reference to a hash as in the above example. It could be a reference to an array. Or maybe to a function. But, it's usually a reference. The main point, is that the user doesn't pass in $self because that's getting created by your new subroutine.
Nor, do you have to check the value of $class since that's given when the new subroutine is called.
If you want to do your verification in a private class (an excellent idea, by the way), you can do so after the bless:
sub new {
my $class = shift; #Contains the class
my %params = #_; #What other parameters used
my $self = {}; #You're creating the $self object as a reference to something
foreach my $param (keys (%params)) {
$self->{$param} = $params{$param};
}
bless ($self, $class) #Class is provided. You don't have to check for it.
#Now you can run your verifications since you've blessed the object created
if (not $self->_validate_parameters()) {
croak qq(Invalid parameters passed in class $class);
}
return $self #This is the object you created.
}