Suppose i am having class
package Person;
# Class for storing data about a person
#person7.pm
use warnings;
use strict;
use Carp;
my #Everyone;
sub new {
my $class = shift;
my $self = {#_};
bless($self, $class);
push #Everyone, $self;
return $self;
}
# Object accessor methods
sub address { $_[0]->{address }=$_[1] if defined $_[1]; $_[0]->{address } }
sub surname { $_[0]->{surname }=$_[1] if defined $_[1]; $_[0]->{surname } }
sub forename { $_[0]->{forename}=$_[1] if defined $_[1]; $_[0]->{forename} }
sub phone_no { $_[0]->{phone_no}=$_[1] if defined $_[1]; $_[0]->{phone_no} }
sub occupation {
$_[0]->{occupation}=$_[1] if defined $_[1]; $_[0]->{occupation}
}
# Class accessor methods
sub headcount { scalar #Everyone }
sub everyone { #Everyone}
1;
And i am calling like this
#!/usr/bin/perl
# classatr2.plx
use warnings;
use strict;
use Person;
print "In the beginning: ", Person->headcount, "\n";
my $object = Person->new (
surname=> "Galilei",
forename=> "Galileo",
address=> "9.81 Pisa Apts.",
occupation => "Philosopher"
);
print "Population now: ", Person->headcount, "\n";
my $object2 = Person->new (
surname=> "Einstein",
forename=> "Albert",
address=> "9E16, Relativity Drive",
occupation => "Theoretical Physicist"
);
print "Population now: ", Person->headcount, "\n";
print "\nPeople we know:\n";
for my $person(Person->everyone) {
print $person->forename, " ", $person->surname, "\n";
}
Ouput
>perl classatr2.plx
In the beginning: 0
Population now: 1
Population now: 2
People we know:
Galileo Galilei
Albert Einstein
>
Doubt -> I am having doubt in this part of code
for my $person(Person->everyone) {
print $person->forename, " ", $person->surname, "\n";
}
Query -> here $person is a hash reference. Why we are calling like $person->forename . Whereas hash ref should be called as $person->{$forename}
$person is NOT JUST a hash reference; you had this line bless($self, $class); earlier. Per the bless perldoc;
bless REF,CLASSNAME
This function tells the thingy referenced by REF that it is now an object
in the CLASSNAME package.
Regarding the OP's doubts expressed in comments to Elliott Frisch's answer, the difference between $person->{surname} and $person->surname is:
$person->{surname} directly accesses the object's internal data. This violates encapsulation and many people consider it a poor practice as a result.
$person->surname runs sub surname on the $person object and returns the result. In this particular case, the only thing that sub does is return the value of $person->{surname}, but it could do other things. For instance, if your Person class included the Person's parents, then $person->surname would be able to first check whether the Person had a surname defined and, if not, return $person->father->surname (or, in some societies, $person->father->forename . 'sson') instead of undef.
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.
I have two classes, one is the base class(Employee) and the other its subclass which inherits it (Extend) the codes of which are shown below :
package Employee;
require Exporter;
our #EXPORT = ("getattr");
our $private = "This is a class level variable";
sub getattr {
print "Inside the getattr function of Employee.pm module \n";
$self = shift;
$attr = shift;
return ($self->{$attr});
}
1;
================
package Extend;
use base qw(Employee);
sub new {
print "Inside new method of Employee.pm \n";
my $class = shift;
my %data = (
name => shift,
age => shift,
);
bless \%data , $class;
}
sub test {
print "Inside test method of Extend class \n";
}
1;
==================
Now I have another piece of code which is using the Extend class :
use Extend;
my $obj = Extend->new("Subhayan",30);
my $value = $obj->getattr("age");
print ("The value of variable age is : $value \n");
$obj->test();
print "Do i get this : $obj.$private \n";
My question is regarding the variable $private defined in the parent class. As per my concept of inheritance attributes and methods of the parent class should be available through the subclass object . For example the function getattr runs fine . But why am I not being able to access $private variable using the base class Extend object .
What am I missing here ? Can someone please help ?
Variables don't get inherited the same way subs do. To access it, you need to specify the entire package name (and yes, when you declare $private, you need our, not my):
print "$Employee::private\n";
It's much more robust to define accessor methods:
# Employee package
sub private {
return $private;
}
...then in your script:
my $var = private();
To inherit object attributes from Employee, you can do:
# Employee
sub new {
my $self = bless {
dept => 'HR',
hours => '9-5',
}, shift;
return $self;
}
# Extend
sub new {
my $class = shift;
my $self = $class->SUPER::new; # attrs inherited from Employee
$self->{extended} = 1;
return $self;
}
# script
my $extend = Extend->new;
Now $extend looks like:
{
dept => 'HR',
hours => '9-5',
extended => 1,
}
You most likely wouldn't set dept or hours in the base class as it will apply to all employees, but I digress.
I have come across an odd problem in one of my Perl scripts. I have a Perl object. Within a certain scope I want one of the objects attributes to be changed, but I want the attribute to be restored to it's old value after it leaves the scope.
Example:
my $object = Object->new('name' => 'Bob');
{
# I know this doesn't work, but it is the best way
# I can represent what I amd trying to do.
local $object->name('Lenny');
# Prints "Lenny"
print $object->name();
}
# Prints "Bob"
print $object->name();
Is there a way to achieve something like this?
This might not be as much encapsulation as you were asking for, but you can local-ize an attribute of a hash. This outputs "CarlLennyCarl"
sub Object::new { bless { _name => $_[1] }, $_[0] } }
sub Object::name { $_[0]->{_name} }
my $obj = Object->new("Carl");
print $obj->name;
{
local $obj->{_name} = "Lenny";
print $obj->name;
}
print $obj->name;
You could also local-ize the entire method. This also outputs "CarlLennyCarl":
sub Object::new { bless { _name => $_[1] }, $_[0] } }
sub Object::name { $_[0]->{_name} }
my $obj = Object->new("Carl");
print $obj->name;
{
local *Object::name = sub { "Lenny" };
print $obj->name;
}
print $obj->name;
I was completely misunderstanding what was occurring there. You cannot use local on subroutine calls, that is the issue you are having.
Lets use a code example from one that I know works and try to explain what eval is actually doing.
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Cwd;
print getcwd() . "\n";
eval{
local #INC = ('/tmp');
require 'test.pl';
print 'local: ' . Dumper(\#INC);
};
print Dumper(\#INC);
That works because I am modifying a variable, not calling on another subroutine to modify my variable.
In order for it to work as you are expecting, you would have to create a deep copy of the object to modify in local scope or something of the sort. (which I'm pretty sure is what is occurring in the first place)
local creates scope for the given brackets, eval, OR file (your problem there)
If you were able to access the elements directly without the method call (bad practice IMHO) you would likely be able to localize the scope of that element in the object.
Example:
name.pm:
package name;
use strict;
use warnings;
{
sub new {
my ($class,$name) = #_;
my $self = bless {}, $class;
$self->{'name'} = $name if defined $name;
return $self;
}
sub name
{
my ($self,$name) = #_;
$self->{'name'} = $name if defined $name;
return $self->{'name'};
}
}
index.pl:
#!/usr/bin/perl -w
use strict;
use warnings FATAL => 'all';
use name;
my $obj = name->new('test');
print $obj->{'name'} . "\n";
{
local $obj->{'name'} = 'test2';
print $obj->{'name'} . "\n";
}
print $obj->{'name'} . "\n";
#! /usr/bin/perl
# this is the object tester
{package Hate;
sub status {
my $class = shift;
print "-- $_[0] $_[1] $_[2]\n";
print "$class exists and ", $class->stats($_[0]), "and ", $class->type($_[1]), "and ", $class->location($_[2]);
}
}
{package Grudge;
#ISA = "Hate";
sub stats{"$_[0]\n"}
sub type{"$_[0]\n"}
sub location{"$_[0]\n"}
}
Hate::status("Grudge", #ARGV);
i ran ./program one two three
this output is what i expected
Grudge exists and one
and two
and three
this is what i got
Grudge exists and Grudge
and Grudge
and Grudge
However when i use this script
#! /usr/bin/perl
# this is the object tester
{package Hate;
sub status {
my $class = shift;
print "-- $_[0] $_[1] $_[2]\n";
print "$class exists and ", $class->stats($_[0]), "and ", $class->type($_[1]), "and ", $class->location($_[2]);
}
}
{package Grudge;
#ISA = "Hate";
sub stats{"$_[1]\n"}
sub type{"$_[1]\n"}
sub location{"$_[1]\n"}
}
Hate::status("Grudge", #ARGV);
This worked.
In your first example, $class->stats($_[0]) is called as a method and is passed an object as the first argument, which needs to be shifted away as you did in Hate::status. That's why $_[1] works: because the first argument to the method is actually the second item in #_ (after $self).
Things become a lot more clearer, and manageable, if you unpack arguments out of #_ at the beginning of the function, e.g.
{
package Hate;
sub status {
my ($class, $stats, $type, $location) = #_;
print "-- $stats $type $location\n";
print "$class exists and ", $class->stats($stats), ...;
}
}
{
package Grudge;
our #ISA = qw(Hate);
sub stats { my ($self, $stats) = #_; $stats; }
sub type { my ($self, $type) = #_; $type; }
sub location { my ($self, $location) = #_; $location; }
}
Hate::status('Grudge', #ARGV);
As a side note, your use of objects is not typical - if you provided more code, we may be able to provide a more idiomatic Perl solution. For example, none of your objects have constructors, and at the moment the three Grudge methods appear to do the same thing. It's also not clear why Grudge is a subclass of Hate (as indicated by the #ISA).
If you really don't want Grudge to be passed its own name as an argument you can call its methods as functions via &{$class . '::stats'}() but you will have to disable strict subs. It's generally better to call methods as you are doing now.
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.