Object Oriented Perl

Using Perl in an Object Oriented Fashion

Object Creation
Simple Constructor
Constructor with Arguments
Constructor with Named Arguments
Specifying Default Attributes
Attributes
Class Data
Object Destructors
Duplicating objects
Inheritance
Polymorphism
Adding Class Methods on the Fly
UNIVERSAL
AUTOLOAD

If you're planning to do Object Oriented programming in Perl, then you're better off diving straight into Moose. If you want to know some of the theory of OO in Perl then read on.

Object Creation

Top Bottom

Packages are used to create classes, subroutines implement methods, and objects are implemented as blessed references.

All objects are stored in references. The bless function is used to mark a variable as belonging to a particular class. The bless function takes two arguments: a reference to bless, and the name of the class to which it will belong. 'bless' returns a reference to the object that was blessed. The 'ref' function can be used to determine the package name for an object.

To create an object (an instance of a class), call the class constructor:

my $object = CLASSNAME->class_constructor

The class constructor is typically called 'new' but this is not mandatory. The constructor will return a reference that has been blessed into the class. Attributes for the object can be set at creation time by specifying parameters to the constructor. The arrow notation insures that the first argument to the constructor is the classname, followed by any parameters specified.

#!/usr/bin/env perl

use Test::More tests => 2;
use Robot;

my $robot = Robot->new(make => 'A1 Robots', model => 'ZX 21');

ok(defined($robot), "Robot object created");
ok(ref($robot) eq "Robot", "Object Class is Robot");

Simple Constructor

Top Bottom

The simplest object constructor will return nothing more thatn a reference blessed into the class:

package Robot;

sub new {
	my $self = {};
	bless $self, "Robot";
	return $self;
}

1;

This constructor ignores its argument and parameters and blesses a reference into the Robot class. The following test script tests object creation works and that the resulting object belongs to the Robot class:

use strict;
use warnings;

use Robot;
use Test::More tests => 2;

ok(my $robot = Robot->new);
isa_ok($robot, 'Robot');

The constructor is so simple, that it could be re-written as follows:

package Robot;

sub new { bless {} }

1;

Because bless has not been provided a second argument to specify the classname to bless the reference into, bless defaults to using the current package name ('Robot')

Constructor with Arguments

Top Bottom

Using the arrow notation to call a method, ensures that the first argument to the subroutine is the identifier on the left-hand side of the arrow operator, followed by any additional arguments provided to the subroutine. We can use this feature of the arrow operator to capture the classname and arguments from the constructor call:

package Robot;

sub new {
	my $class = shift;
	my @args = @_;
	bless \@args, $class;
}

1;

This constructor returns an array reference blessed into the Robot class

use strict;
use warnings;

use Robot;
use Test::More tests => 5;

ok(my $robot = Robot->new(qw[First Second Third]));
isa_ok($robot, 'Robot');
cmp_ok($robot->[0], 'eq', 'First', "Direct access to First Parameter");
cmp_ok($robot->[1], 'eq', 'Second', "Direct access to Second Parameter");
cmp_ok($robot->[2], 'eq', 'Third', "Direct access to Third Parameter");

The test scripts shows that we can access the data in the object directly by their index in the array reference.

Constructor with Named Arguments

Top Bottom

Any type of reference can be used to create an object in Perl. Arrays can provide advantages in terms of performance, but the objects properties need to be specified in a specific order. Hash references provide the opportunity to provide named argument lists to ease use and maintenance:

package Robot;

sub new {
	my $class = shift;
	my %args = @_;
	bless \%args, $class;
}

1;

This constructor returns a hash reference, and attributes can be specified in any order and accessed by name:

use strict;
use warnings;

use Robot;
use Test::More tests => 5;

ok(my $robot = Robot->new(name => 'Robby', created => '1956', 
	creator => 'Dr Edward Morbius'));
isa_ok($robot, 'Robot');
cmp_ok($robot->{creator}, 'eq', 'Dr Edward Morbius', 'Direct access to creator attribute');
cmp_ok($robot->{name}, 'eq', 'Robby', 'Direct access to name attribute');
cmp_ok($robot->{created}, 'eq', '1956', 'Direct access to created attribute');

Specifying Default Attributes

Top Bottom

The constructor can also specify default attributes should they be omitted during object creation:

package Robot;

sub new {
	my $class = shift;
	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
		created => '1956');
	my $self = {%defaults, @_};
	bless $self, $class;
}

1;

Now we can call the constructor without attributes and accepting the defaults, or specifying our own attributes to override the defaults:

use strict;
use warnings;

use Robot;
use Test::More tests => 6;

my $robot = Robot->new();
cmp_ok($robot->{creator}, 'eq', 'Dr Edward Morbius', 'Default creator attribute');
cmp_ok($robot->{name}, 'eq', 'Robby', 'Default name attribute');
cmp_ok($robot->{created}, 'eq', '1956', 'Default created attribute');

my $other_bot = Robot->new(name => 'Robbie', creator => 'Morbius',
	created => '1955');
cmp_ok($other_bot->{creator}, 'eq', 'Morbius', 'Specified creator attribute');
cmp_ok($other_bot->{name}, 'eq', 'Robbie', 'Specified name attribute');
cmp_ok($other_bot->{created}, 'eq', '1955', 'Specified created attribute');

Attributes

Top Bottom

To obey Object Oriented programming principles, the attributes should not be accessed directly from the object, but via the 'accessor' methods. The data stored in the object reference is still directly accessible but the accessor methods are part of the public interface of the class and should still work even when the implementation changes.

package Robot;

sub new {
	my $class = shift;
	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
		created => '1956');
	my $self = {%defaults, @_};
	bless $self, $class;
}

sub get_name {
	my $self = shift;
	return $self->{name};
}

sub get_creator {
	my $self = shift;
	return $self->{creator};
}

sub get_created {
	my $self = shift;
	return $self->{created};
}

1;

use strict;
use warnings;

use Robot;
use Test::More tests => 6;

my $robot = Robot->new();

my $other_bot = Robot->new(name => 'Robbie', creator => 'Morbius',
	created => '1955');

cmp_ok($robot->get_creator, 'eq', 'Dr Edward Morbius', 'Creator accessor');
cmp_ok($robot->get_name, 'eq', 'Robby', 'Name accessor');
cmp_ok($robot->get_created, 'eq', '1956', 'Created accessor');

cmp_ok($other_bot->get_creator, 'eq', 'Morbius', 'Creator accessor');
cmp_ok($other_bot->get_name, 'eq', 'Robbie', 'Name accessor');
cmp_ok($other_bot->get_created, 'eq', '1955', 'Created accessor');

Mutator methods can be added to change an attribute of an object, even though direct access is still possible. Both mutator and accessor methods have also been made a little more concise in this version:

package Robot;

sub new {
	my $class = shift;
	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
		created => '1956');
	my $self = {%defaults, @_};
	bless $self, $class;
}

sub get_name { return $_[0]->{name} }
sub get_creator { return $_[0]->{creator} }
sub get_created { return $_[0]->{created} }

sub set_name { $_[0]->{name} = $_[1] if $_[1] }
sub set_creator { $_[0]->{creator} = $_[1] if $_[1] }
sub set_created { $_[0]->{created} = $_[1] if $_[1] }

1;

use strict;
use warnings;

use Robot;
use Test::More tests => 14;

my $robot = Robot->new();


cmp_ok($robot->get_creator, 'eq', 'Dr Edward Morbius', 'Creator accessor');
ok($robot->set_creator('Morbius'), 'Creator mutator');
cmp_ok($robot->get_creator, 'eq', 'Morbius', 'Changed Creator value');
cmp_ok($robot->get_name, 'eq', 'Robby', 'Name accessor');
ok($robot->set_name('Robert'), 'Name mutator');
cmp_ok($robot->get_name, 'eq', 'Robert', 'Changed name value');
cmp_ok($robot->get_created, 'eq', '1956', 'Created accessor');
ok($robot->set_created('1955'), 'Created mutator');
cmp_ok($robot->get_created, 'eq', '1955', 'Changed created value');

my $other_bot = Robot->new(name => 'Robbie', creator => 'Morbius',
	created => '1955');
cmp_ok($other_bot->get_creator, 'eq', 'Morbius', 'Creator accessor');
cmp_ok($other_bot->get_name, 'eq', 'Robbie', 'Name accessor');
cmp_ok($other_bot->get_created, 'eq', '1955', 'Created accessor');
ok($other_bot->set_created('1956'), 'Created mutator');
cmp_ok($other_bot->get_created, 'eq', '1956', 'Changed created value');

Mutator and accessors can be combined:

package Robot;

sub new {
	my $class = shift;
	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
		created => '1956');
	my $self = {%defaults, @_};
	bless $self, $class;
}

sub name {
	my $self = shift;
	$self->{name} = shift if @_;
	return $self->{name};
}

sub creator {
	my $self = shift;
	$self->{creator} = shift if @_;
	return $self->{creator};
}

sub created {
	my $self = shift;
	$self->{created} = shift if @_;
	return $self->{created};
}

1;

The same method is called to get or set an attribute. The method checks if a parameter has been supplied and if it has this parameter is assigned to the corresponding attribute.

use strict;
use warnings;

use Robot;
use Test::More tests => 9;

my $robot = Robot->new();

cmp_ok($robot->creator, 'eq', 'Dr Edward Morbius', 'Default creator attribute');
cmp_ok($robot->name, 'eq', 'Robby', 'Default name attribute');
cmp_ok($robot->created, 'eq', '1956', 'Default created attribute');

ok($robot->creator('Morbius'), 'Creator mutator');
ok($robot->name('Robbie'), 'Name mutator');
ok($robot->created(1955), 'Created mutator');

cmp_ok($robot->creator, 'eq', 'Morbius', 'Creator attribute changed');
cmp_ok($robot->name, 'eq', 'Robbie', 'Name attribute changed');
cmp_ok($robot->created, 'eq', '1955', 'Created attribute changed');

Class Data

Top Bottom

Class data represents data about the class rather than specific instances or objects of the class. Class Data might contain:

A count of objects created
A list of objects created
The name or file descriptor of a log file
Collective data, for example min, max, average values
Reference to last object created
A lookup table for objects based on an attribute value

Suppose we wanted to keep a count of the number of objects that have been created. We wouldn't want to store this in each object or we'd have to change it in each object whenever an object is created or destroyed. Instead we can store this data in the class itself using a package variable. To access the class data, we'll also want to create class accessors.

package Robot;

our $population = 0;
sub get_population { return $population }
sub raise_population { ++$population }


sub new {
	my $class = shift;
	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
		created => '1956');
	my $self = {%defaults, @_};
	$class->raise_population;
	bless $self, $class;
}

sub name {
	my $self = shift;
	$self->{name} = shift if @_;
	return $self->{name};
}

sub creator {
	my $self = shift;
	$self->{creator} = shift if @_;
	return $self->{creator};
}

sub created {
	my $self = shift;
	$self->{created} = shift if @_;
	return $self->{created};
}

1;

use strict;
use warnings;

use Robot;
use Test::More tests => 5;

my $robot1 = Robot->new(name => 'Robby');
my $robot2 = Robot->new(name => 'Robert');
my $robot3 = Robot->new(name => 'Robbie');

ok($Robot::population == 3, 'Direct access to class data');
ok(Robot->get_population == 3, 'Class data via accessor');
ok($robot3->get_population == 3, 'Class data via instance');

cmp_ok(Robot->raise_population, '==', 4, 'Access raise population via class');
cmp_ok($robot3->raise_population, '==', 5, 'Access raise population via object');

With this arrangement class data is directly accessible via the class name. Class methods are also directly accessible via instances of the class. But we might want to keep some methods private to the class. We shouldn't really be able to call raise_population unless we are creating a new object. We can protect class data from unwanted external access by assigning the data and methods to lexical variables inside an anonymous block.

package Robot;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };


  sub new {
  	my $class = shift;
  	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
  		created => '1956');
  	my $self = {%defaults, @_};
  	$class->$raise_population;
  	bless $self, $class;
  }
}

sub name {
	my $self = shift;
	$self->{name} = shift if @_;
	return $self->{name};
}

sub creator {
	my $self = shift;
	$self->{creator} = shift if @_;
	return $self->{creator};
}

sub created {
	my $self = shift;
	$self->{created} = shift if @_;
	return $self->{created};
}

1;

The lexical variable $population is only accessible to code within the same block as its definition. However the value of $population is accessible via the get_population method which is visible globally. A second anonymous subroutine is assigned to a lexically scoped variable, $raise_population. This subroutine reference is also only visible to code within its defining block. Since it is intended to be called via the constructor, the constructor is also placed within the same block.

Object Destructors

Top Bottom

The DESTROY subroutine is a special subroutine that is called whenever the last reference to an object is removed either by going out of scope, or being undefined or re-assigned. Normally, Perl will handle memory management for you, but you might need to create a DESTROY method to handle other clean-up activities not directly related to the memory used by an object when it disappears. In our current example, when an object is destroyed, the population count should be reduced by one. Destroy is the ideal place to do this:

package Robot;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };
  my $scrap_robot = sub { --$population };


  sub new {
  	my $class = shift;
  	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
  		created => '1956');
  	my $self = {%defaults, @_};
  	$class->$raise_population;
  	bless $self, $class;
  }

  sub DESTROY {
	my $self = shift;
	$self->$scrap_robot;
  }
}

sub name {
	my $self = shift;
	$self->{name} = shift if @_;
	return $self->{name};
}

sub creator {
	my $self = shift;
	$self->{creator} = shift if @_;
	return $self->{creator};
}

sub created {
	my $self = shift;
	$self->{created} = shift if @_;
	return $self->{created};
}

1;

The $scrape_robot lexical is a reference to a subroutine that decrements the $population variable. Since $population is lexically scoped, $scrap_robot is also defined in the same block. $scrap_robot is intended to be called by the DESTROY routine, which must also be defined in the same enclosing block

use strict;
use warnings;

use Robot;
use Test::More tests => 5;

my $robot1 = Robot->new(name => 'Robby');
my $robot2 = Robot->new(name => 'Robert');
my $robot3 = Robot->new(name => 'Robbie');

ok(Robot->get_population == 3, 'Initial population count');
$robot1 = undef;
ok(Robot->get_population == 2, 'Population count after object destruction');

{
  my $robo_ref = $robot2;
  $robot2 = undef;
  ok($robo_ref->name eq 'Robert', 'Robot2 still accessible via reference');
  ok(Robot->get_population == 2, 'Population count still includes Robot2');
}

ok(Robot->get_population == 1, 'Population decreased when last reference to Robot2 goes out of scope');

Note that the DESTROY method is only called when the last reference to an object disappears.

Duplicating objects

Top Bottom

Assigning an object to another variable, merely creates a new reference to the same object. To create a new object from an existing object, you can modify the constuctor to check if it is being called by reference to another existing object or by the class name. Use ref() to determine how the call was made: if made via an existing object, ref() returns the class name; if made via a Class method, then ref() returns an empty string.

package Robot;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };
  my $scrap_robot = sub { --$population };


  sub new {
  	my ($caller, %arg) = @_;
	my $self;
	if (ref($caller)) {
		$self = {%$caller, %arg};
	}
	else {
		my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
			created => '1956');
		$self = {%defaults, %arg};
	}
	my $class = ref($caller) || $caller;
	$class->$raise_population;
  	bless $self, $class;
  }

  sub DESTROY {
	my $self = shift;
	$self->$scrap_robot;
  }
}

sub name {
	my $self = shift;
	$self->{name} = shift if @_;
	return $self->{name};
}

sub creator {
	my $self = shift;
	$self->{creator} = shift if @_;
	return $self->{creator};
}

sub created {
	my $self = shift;
	$self->{created} = shift if @_;
	return $self->{created};
}

1;

The new constructor can now be called as a Class method or as an Object method. If called by an object (ref($caller) returns a true value), the objects attributes are copied and then any arguments supplied are used to override these properties. If called as a Class method, then defaults are applied and overridden by any arguments supplied, as before.

use strict;
use warnings;

use Robot;
use Test::More tests => 10;

my $robot1 = Robot->new(name => 'Robby', creator => 'Morbius');
ok($robot1->created == 1956, "Defaults still applied for Class->new");
ok($robot1->name eq 'Robby', 'Specified name set for Class->new');
ok($robot1->creator eq 'Morbius', 'Specified creator set for Class->new');

ok(Robot->get_population == 1, 'Initial population count');
my $robo_ref = $robot1;
ok(Robot->get_population == 1, 'Population unchanged after creating reference to existing object');

my $new_bot = $robot1->new(name => 'Roberto');
ok(Robot->get_population == 2, 'Population raised when constructor used as Object method');
cmp_ok($new_bot->name,  'eq', 'Roberto', 'Specified name set for object->new');
cmp_ok($robot1->name,  'eq', 'Robby', 'Original object properties not changed by copy');
ok($new_bot->creator eq 'Morbius', 'Creator property copied from object in Object->new');
ok($new_bot->created eq '1956', 'Created property copied from object in Object->new');

As an alternative to altering the Class constructor, a seperate 'clone' method can be created for cloning a new object from an existing object.

package Robot;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };
  my $scrap_robot = sub { --$population };


  sub new {
  	my $class = shift;
  	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
  		created => '1956');
  	my $self = {%defaults, @_};
  	$class->$raise_population;
  	bless $self, $class;
  }

  sub DESTROY {
	my $self = shift;
	$self->$scrap_robot;
  }
  
  sub clone { 
	my $self = shift;
	my %arg  = @_;
	my $class = ref($self);
	$class->$raise_population;
	bless { %{$self}, %arg }, $class;
  }
}

sub name {
	my $self = shift;
	$self->{name} = shift if @_;
	return $self->{name};
}

sub creator {
	my $self = shift;
	$self->{creator} = shift if @_;
	return $self->{creator};
}

sub created {
	my $self = shift;
	$self->{created} = shift if @_;
	return $self->{created};
}

1;

The clone method copies the properties from the original to the clone, but uses any supplied arguments to override those copied properties.

use strict;
use warnings;

use Robot;
use Test::More tests => 10;

my $robot1 = Robot->new(name => 'Robby', creator => 'Morbius');
ok($robot1->created == 1956, "Defaults still applied for new as Class method");
ok($robot1->name eq 'Robby', 'Specified name set for Class->new');
ok($robot1->creator eq 'Morbius', 'Specified creator set for Class->new');

ok(Robot->get_population == 1, 'Initial population count');

my $new_bot = $robot1->clone(name => 'Roberto');
isa_ok($new_bot, 'Robot');
ok(Robot->get_population == 2, 'Population raised by clone method');
cmp_ok($new_bot->name,  'eq', 'Roberto', 'Name set by parameter to clone method');
cmp_ok($robot1->name,  'eq', 'Robby', 'Original object properties not changed by cloning');
ok($new_bot->creator eq 'Morbius', 'Creator property copied in clone method');
ok($new_bot->created eq '1956', 'Created property copied in clone method');

Inheritance

Top Bottom

The @ISA array (pronounced 'is a') can be used to define an inheritance tree for a package. When perl searches a package for a method, if it is not found in the package definition, then the @ISA array is searched.

Suppose that we want to extend the Robot module, by creating some subclasses. For instance we may want Robot::Companion for robots that serve as pets, Robot::Domestic for robot cleaners and so on. We can build our sub-classes to inherit from the Robot class and later add specific functionality unique to the subclass in the subclass module. There are several ways to build the subclass module, setting up inheritance along the way:

package Robot::Companion;

require Robot;

our @ISA = qw(Robot);

1;

@ISA is declared as a package global and 'Robot' is added. Two alternative ways to declare @ISA as a global package variable are:

@Robot::Companion::ISA = 'Robot';
use vars qw/@ISA/; @ISA = 'Robot';

The 'base' pragma will both require the superclass and add it to @ISA in one step:

package Robot::Companion;

use base 'Robot';

1;

Our final version uses the 'parent' pragma, which does the same thing as the 'base' pragma. According to the documentation for base and parent, the parent pragma is to be preferred over base.

package Robot::Companion;

use parent 'Robot';

1;

All three versions of the Robot::Companion module set up an inheritance tree but define none of their own methods. Because of inheritance, all the methods of Robot are available via Robot::Companion. The following test script passes for each version of the module:

use strict;
use warnings;

use Robot::Companion;
use Test::More tests => 11;

ok(my $robot1 = Robot::Companion->new(name => 'Robby', creator => 'Morbius'),
	'Constructor inherited from base class');
cmp_ok(ref($robot1), 'eq', 'Robot::Companion', "Constructor creates Robot::Companion object");
ok($robot1->created == 1956, "created method inherited");
ok($robot1->name eq 'Robby', "name method inherited");
ok($robot1->creator eq 'Morbius', "creator method inherited");

my $new_bot = $robot1->clone(name => 'Roberto');
cmp_ok(ref($new_bot), 'eq', 'Robot::Companion', 'Cloned Robot is a Companion');
ok(Robot::Companion->get_population == 2, 'Get_population Class method inherited');
cmp_ok($new_bot->name,  'eq', 'Roberto', 'Name set by parameter to clone method');
cmp_ok($robot1->name,  'eq', 'Robby', 'Original object properties not changed by cloning');
ok($new_bot->creator eq 'Morbius', 'Creator property copied in clone method');
ok($new_bot->created eq '1956', 'Created property copied in clone method');

Methods found via @ISA are cached in the current class to for efficiency. The @ISA assignment is normally performed at run-time, but the base and parent pragmas set these up at compile-time.

Polymorphism

Top Bottom

Having defined an inheritance tree for a module, methods inherited from the parent class can be over-ridden in the child class simply by providing an alternative definition of the same method within the child package. However if we want to modify the method, use 'SUPER' to call the first instance of the method in the package's inheritance tree. Super is used as follows:

package Robot::Companion;

use parent 'Robot';
{
  sub new
  {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{specialties} = $arg{specialties} || [qw/nothing/];
    return $self;
  }
}

sub get_specialties { $_[0]->{specialties} }
	

1;

The modified subroutine uses the fully qualified name (SUPER::new) of the constuctor subroutine that it uses as a base for its own constructor. The base subroutine is called as a method of the current caller, so the first parameter recieved by the base constructor will be Robot::Companion. Parameters provided to the sub-class are also passed to the superclass via the @_ array. This includes a new attribute 'specialties', which is avaiable in Robot::Companion but not in Robot. If this new property is not specified in the constructor call, a default value is set in the subclass constructor only. Finally an accessor for the new attribute of the subclass is defined in the subclass. Note that their is no need to bless the object return by the subclass - this has already been done in the superclass.

use strict;
use warnings;

use Robot::Companion;
use Test::More tests => 19;

ok(my $robot1 = Robot::Companion->new(name => 'Robbie', creator => 'Morbius'),
	'Constructor inherited from base class');
cmp_ok(ref($robot1), 'eq', 'Robot::Companion', "Constructor creates Robot::Companion object");
ok($robot1->created == 1956, "created method inherited");
ok($robot1->name eq 'Robbie', "name method inherited");
ok($robot1->creator eq 'Morbius', "creator method inherited");
ok($robot1->get_specialties->[0] eq 'nothing', 'Child object holds additional attribute'); 

my $new_bot = $robot1->clone(name => 'Roberto');
cmp_ok(ref($new_bot), 'eq', 'Robot::Companion', 'Cloned Robot is a Companion');
ok(Robot::Companion->get_population == 2, 'Population raised by clone method');
cmp_ok($new_bot->name,  'eq', 'Roberto', 'Name set by parameter to clone method');
ok($new_bot->creator eq 'Morbius', 'Creator property copied in clone method');
ok($new_bot->created eq '1956', 'Created property copied in clone method');
ok($new_bot->get_specialties->[0] eq 'nothing', 'Cloned child object holds additional attribute'); 

my $next_bot = $new_bot->clone(specialties => [qw/Fashion Photography Literature/]);
cmp_ok($next_bot->name,  'eq', 'Roberto', 'Clone of clone name set by original clone');
ok($next_bot->creator eq 'Morbius', 'Clone of clone creator property set by original clone');
ok($next_bot->created eq '1956', 'Clone of clone created property set by original clone');
ok($next_bot->get_specialties->[0] eq 'Fashion', 'Clone of clone specialty set by parameter'); 
ok($next_bot->get_specialties->[1] eq 'Photography', 'Clone of clone specialty set by parameter'); 
ok($next_bot->get_specialties->[2] eq 'Literature', 'Clone of clone specialty set by parameter'); 
my $last_bot = $next_bot->clone();
ok($last_bot->get_specialties->[2] eq 'Literature', 'Clone of clone copies specialty from clone source');

If the subclass mentions more than one package in its @ISA, then SUPER::new will refer to the first new() subroutine found via the @ISA search. To use another new() subroutine, you would have to specify it by name:

$self->Android::new(@_)

Adding Class Methods on the Fly

Top Bottom

Adding methods to a class involves defining a new subroutine in the package. This definition does not have to occur in the package's module file: the subroutine can be defined within a package declaration within any script. This can be useful when testing new methods in test scripts before adding them to the class file.

use strict;
use warnings;

use Robot::Companion;
use Test::More tests => 3; 

my $robot1 = Robot->new(name => 'Robbie', creator => 'Morbius');
my $new_bot = Robot::Companion->new(name => 'Roberto');
my $next_bot = $new_bot->clone(
	specialties => [qw/Fashion Photography Literature/]
);

package Robot;
sub speak_to_maker {
	my $self = shift;
	print $self->name, " says: 'Hello ", $self->creator, "'\n";
	print "I have no special powers to entertain you with\n";
}

package Robot::Companion;
sub speak_to_maker {
	my $self = shift;
	print $self->name, " says: 'Hello ", $self->creator, "'\n";
	print "I am perfectly equipped to talk about: ";
	print join(", ", @{$self->get_specialties}), "\n"; 
}
package main;

ok($robot1->speak_to_maker, "Robot speaks");
ok($new_bot->speak_to_maker, "Robot::Companion speaks");
ok($next_bot->speak_to_maker, "Robot::Companion speaks");

UNIVERSAL

Top Bottom

If a method is not found in the package or the package's @ISA, perl will then search for a subroutine named UNIVERSAL::methodname. UNIVERSAL is thus the ultimate ancestor that all classes inherit from.

UNIVERSAL comes with three pre-defined methods:

isa(CLASS): Returns true if caller belongs to CLASS
can(METHOD): Returns undef if no METHOD subroutine is found in caller, otherwise returns a reference to the subroutine that would have been called
VERSION(REQUIRED): Returns version number of caller's class. If REQUIRED is supplied, then raises an exception if the version number is less than REQUIRED

Methods can be added to UNIVERSAL by defining subroutines in the UNIVERSAL namespace, as you would for any other package

use strict;
use warnings;

use Robot::Companion;
use Test::More tests => 5; 

my $robot1 = Robot->new(name => 'Robbie', creator => 'Morbius');
my $new_bot = Robot::Companion->new(name => 'Roberto');
my $next_bot = $new_bot->clone(
	specialties => [qw/Fashion Photography Literature/]
);

package UNIVERSAL;
sub speak_to_maker {
	my $self = shift;
	print $self->name, " says: 'Hello ", $self->creator, "'\n";
	print "All robots shall speak with the same voice\n";
}
package main;

ok(Robot->can('speak_to_maker'), "Robot speak_to_maker available");
ok(Robot::Companion->can('speak_to_maker'), "Robot::Companion speak_to_maker available");

ok($robot1->speak_to_maker, "Robot speaks");
ok($new_bot->speak_to_maker, "Robot::Companion speaks");
ok($next_bot->speak_to_maker, "Robot::Companion speaks");

AUTOLOAD

Top Bottom

If a method is not found in the classes inheritance tree, then Perl will search for an AUTOLOAD method in the class and then in the class's inheritance tree. If an AUTOLOAD subroutine is found, then it is called as a method, thus setting the first parameter to the caller and providing any parameters in @_. Additionally the $AUTOLOAD variable is set to the name of the original method that was requested.

Since our accessor/mutator methods all follow a similar pattern, we can use AUTOLOAD to define all these methods in one go:

package Robot;
use Carp;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };
  my $scrap_robot = sub { --$population };


  sub new {
  	my $class = shift;
        my %arg = @_;
  	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
  		created => '1956');
  	my $self = {%defaults, %arg};
  	$class->$raise_population;
  	bless $self, $class;
  }

  sub DESTROY {
	my $self = shift;
	$self->$scrap_robot;
  }

  sub clone { 
	my $self = shift;
	my %arg  = @_;
	my $class = ref($self);
	$class->$raise_population;
	bless { %{$self}, %arg }, $class;
  }
}

sub AUTOLOAD {
	my $self = shift;
	my ($attr) = $AUTOLOAD =~ /.*::(\w+)$/;
	$self->{$attr} = shift if @_;
	return $self->{$attr};
}

1;

There is a problem with the existing AUTOLOAD subroutine though. This version of AUTOLOAD will create the 'creator', 'name' and 'created' methods for us, but it will also create any other methods that it sees.

use strict;
use warnings;

use Robot;
use Robot::Companion;
use Test::More qw/no_plan/;

my $robot = Robot->new();
my $robo_comp = Robot::Companion->new();

my @known_attrs = qw/creator name created/;

for my $attr( @known_attrs ) {
	ok($robot->$attr(1), ref($robot) . " has $attr autoload mutator");
	ok($robo_comp->$attr(1), ref($robo_comp) . " has $attr autoload mutator");
	ok($robot->$attr == 1, ref($robot) . " has $attr autoload accessor");
	ok($robo_comp->$attr == 1, ref($robo_comp) . " has $attr autoload accessor");
}

my @unknown_attrs = qw/hop skip jump/;
for my $attr ( @unknown_attrs) {
	ok(!$robot->$attr, ref($robot) . " can't $attr yet");
}
for my $attr ( @unknown_attrs) {
	ok($robot->$attr(1), "Make " . ref($robot) . " $attr");
	ok($robot->$attr == 1, ref($robot) . " can now $attr ");
}

In our test script, we've also managed to create 'hop', 'skip' and 'jump' methods for our Robots. We can easily modify the AUTOLOAD to check which attributes we want to allow for our Robots. At the same time we can add logic that will check if the attribute is read only:

package Robot;
use Carp;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };
  my $scrap_robot = sub { --$population };


  sub new {
  	my $class = shift;
        my %arg = @_;
  	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
  		created => '1956');
  	my $self = {%defaults, %arg};
  	$class->$raise_population;
  	bless $self, $class;
  }

  sub DESTROY {
	my $self = shift;
	$self->$scrap_robot;
  }

  sub clone { 
	my $self = shift;
	my %arg  = @_;
	my $class = ref($self);
	$class->$raise_population;
	bless { %{$self}, %arg }, $class;
  }
}

sub AUTOLOAD {
	my $self = shift;
	my $value = shift;
	my $known_attrs = { name => 'read/write', 
		creator => 'read',
		created => 'read/write'};
	my ($attr) = $AUTOLOAD =~ /.*::(\w+)$/;
	if (!$known_attrs->{$attr}) {
		carp "No such attribute $attr";
		return 0;
	}
	if ($value) {
		if ( $known_attrs->{$attr} =~ /write/) {
			$self->{$attr} = $value;
		}
		else {
			carp "Attempt to set read only attribute $attr failed\n";
			return 0;
		}
	}
	return $self->{$attr};
}

1;

We've used Carp::carp to provide a message when an error occurs and allow processing to continue for our test script. Use Carp::croak it you would rather the script died at an illegal attempt to access a property

use strict;
use warnings;

use Robot;
use Robot::Companion;
use Test::More qw/no_plan/;

my $robot = Robot->new();
my $robo_comp = Robot::Companion->new();

my @read_only_attrs = qw/creator /;
my @read_write_attrs = qw/name created/;

for my $attr( @read_write_attrs ) {
	ok($robot->$attr(1), ref($robot) . " has $attr autoload mutator");
	ok($robo_comp->$attr(1), ref($robo_comp) . " has $attr autoload mutator");
	ok($robot->$attr == 1, ref($robot) . " has $attr autoload accessor");
	ok($robo_comp->$attr == 1, ref($robo_comp) . " has $attr autoload accessor");
}

for my $attr (@read_only_attrs) {
	ok($robot->$attr, ref($robot) . " has $attr autoload accessor");
	ok($robo_comp->$attr, ref($robo_comp) . " has $attr autoload accessor");
	ok(!$robot->$attr(1), ref($robot) . " has no $attr autoload mutator");
	ok(!$robo_comp->$attr(1), ref($robo_comp) . " has no $attr autoload mutator");
}


my @unknown_attrs = qw/hop skip jump/;
for my $attr ( @unknown_attrs) {
	ok(!$robot->$attr, ref($robot) . " can't $attr yet");
}

The above autoload method has a processing overhead: each time a method is called and not found, it must be searched for in the class's inheritance tree. It is possible to use the symbol table to create the method on the first call, which will then be available on subsequent calls

package Robot;
use Carp;

{
  my $population = 0;
  sub get_population { return $population }
  my $raise_population = sub { ++$population };
  my $scrap_robot = sub { --$population };


  sub new {
  	my $class = shift;
        my %arg = @_;
  	my %defaults =  (name => 'Robby', creator => 'Dr Edward Morbius',
  		created => '1956');
  	my $self = {%defaults, %arg};
  	$class->$raise_population;
  	bless $self, $class;
  }

  sub DESTROY {
	my $self = shift;
	$self->$scrap_robot;
  }

  sub clone { 
	my $self = shift;
	my %arg  = @_;
	my $class = ref($self);
	$class->$raise_population;
	bless { %{$self}, %arg }, $class;
  }
}

sub AUTOLOAD {
	no strict 'refs';
	my ($self, $value) = @_;
	my $known_attrs = { 
		name => 'read/write', 
		creator => 'read',
		created => 'read/write'};
	if ($AUTOLOAD =~ /.*::get_(\w+)$/) {
		my $attr = $1;
		if  ($known_attrs->{$attr} =~ /read/) {
			*$AUTOLOAD = sub { $_[0]->{$attr} };
			return $self->{$attr};
		}
	}
	elsif ($AUTOLOAD =~ /.*::set_(\w+)$/) {
		my $attr = $1;
		if ($known_attrs->{$attr} =~ /write/) {
			*$AUTOLOAD = sub { $_[0]->{$attr} = $_[1] };
			$self->{$attr} = $value;
		}
		else {
			carp "Attempt to set non-writable attribute: $attr";
			return 0;
		}
	}
	else {
		carp "No such method: $AUTOLOAD";
		return 0;
	}
}

1;

In this version of AUTOLOAD we've created both get and set methods, since we want add a different subroutine to the symbol table for each type of action

use strict;
use warnings;

use Robot;
use Robot::Companion;
use Test::More qw/no_plan/;

my $robot = Robot->new();

cmp_ok($robot->get_creator, 'eq', 'Dr Edward Morbius', 'robot get_creator accessor');
ok($robot->get_name eq 'Robby', 'robot get_name accessor');
ok($robot->set_name('Roberto'), 'robot set_name mutator');
ok($robot->get_name eq 'Roberto', 'robot get_name accessor');
ok($robot->set_created(1954), 'robot set_created mutator');
ok($robot->get_created == 1954, 'robot get_created accessor');
ok(!$robot->set_creator('Altaira'), "can't create mutator for read-only attribute");
ok(!$robot->break_creator("Now"), "can't create random method");

With inheritance from multiple packages, you may wish to specify the package containing the AUTOLOAD method to use for your package, instead of inheriting the AUTOLOAD found first in the inheritance tree. You can do this by pre-declaring the subroutines in the package whose AUTOLOAD you want to use. You can declare the subroutine without defining it by naming the subroutine without providing a code block:

package Android;
sub hop;
sub skip;
sub jump;

When your package calls the methods 'hop', 'skip' or 'jump', Perl will find them first in the Android package, before attempting to query for AUTOLOAD routines. When it tries to execute the methods, and finds no definition for them in the Android package, it will call the AUTOLOAD package from Android.

Menu

Object Oriented Perl

Using Perl in an Object Oriented Fashion

Contents

Object Creation

Simple Constructor

Constructor with Arguments

Constructor with Named Arguments

Specifying Default Attributes

Attributes

Class Data

Object Destructors

Duplicating objects

Inheritance

Polymorphism

Adding Class Methods on the Fly

UNIVERSAL

AUTOLOAD