testboss1.pl

#!/usr/bin/perl
use strict;
use warnings;
use Boss1;
use Data::Dumper;

Boss1->debug(1);
my $boss = Boss1->new();

$boss->fullname->title("Don");
$boss->fullname->surname("Pichon Alvarez");
$boss->fullname->christian("Federico Jesus");
$boss->fullname->nickname("Fred");
$boss->salary(40000);

$boss->age(47);
$boss->peers("Frank", "Felipe", "Faust");

printf "%s is age %d.\n", $boss->fullname->as_string, $boss->age;
printf "His peers are: %s\n", join(", ", $boss->peers);

print "here is the boss\n";
print Dumper($boss);
[download]

Boss1.pm

package Boss1;
use Employee4;
@ISA = qw(Employee4);

1;
[download]

Employee4.pm

package Employee4;
##
## An example of inheritance with both some further methods defined fo
+r the derived class
## and overridden methods demonstrating polymorphism.
## See testemp3.pl .
use Person5;  ## load this class
@ISA = ("Person5"); ## inherit the class methods as needed.

use Carp;
my $Debugging = 0; ## global in Employee3 ...

## need to initialise the new fields provided by this class
sub new {
  my $class = shift;
  my $self = $class->SUPER::new();
  $self->{SALARY} = undef;
  $self->{ID} = undef;
  $self->{START_DATE};
  return $self;
}

## Unique Employee methods
sub salary {
  my $self = shift;
  if (@_) { $self->{SALARY} = shift }
  return $self->{SALARY};
}

sub id_number {
  my $self = shift;
  if (@_) { $self->{ID} = shift }
  return $self->{ID};
}

sub start_date {
  my $self = shift;
  if (@_) { $self->{START_DATE} = shift }
  return $self->{START_DATE};
}

## Overridden methods - polymorphism
## This completely overrides Person5->peers.
sub peers {
  my $self = shift;
  if (@_) { @{$self->{PEERS}} = @_; }
  return map { "PEON=\U$_" } @{ $self->{PEERS} };
}

## subclass/superclass
sub debug {
  my $self = shift;
  confess "usage: thing->debug(level)" unless @_ = 1;
  my $level = shift;
  if (ref($self)) {
    $self->{_DEBUG} = $level;
  } else {
    $Debugging = $level;
  }
  $self->SUPER::debug($Debugging);
}
1;
[download]

Person5.pm

package Person5;
##
## This package is created while following the Perl OO tutorial perloo
+tut.
##
## This fifth class demonstrates inheritance - see the derived classes
+ Employeen, n=1,...
##
## In Person1, global data was accessed directly within the class and 
+object methods.
## This behaviour prevents both scalability and inheritance.
## In Person2 access to global data is acheived by defining a class me
+mber which is a reference to the
## global data.  This member is then part of the class definition and 
+can be carried forward in
## inheritance.
## Person3 added a bimodal (class or object) debugging technique and t
+he END routine, executed
## implicitly when a program quits.
## Person4 added improved pod and demonstrated class aggregation using
+ the Fullname class.
## Aggregation is where a class is part of another class.  It is not i
+nheritance.
##
## Q.  If this class is inherited, then what does Census apply to?
use strict;

## Examples of class data : $Census and $Debugging
##
my $Census = 0; ## a file scoped lexical class datum
##
use Carp;
my $Debugging = 0;## oh look another file-scoped lexical variable, dee
+ply bound so it won't go out of scope until it isn't needed anymore

use Fullname; ## making this class aware of the Fullname class
## The constructor
## - built as a class method
## - designed to be inheritable
## - there is no restriction on the constructor name, could have calle
+d this method Person
## - this constructor works on class data and does it well.
sub new {
  my $class= shift; ## this exploits the class method nature of invoca
+tion.
  my $self = {};         ## a hash reference
  $self->{FULLNAME} = Fullname->new(); ## fullname field support intro
+duced. The FULLNAME field is a hash ref to a Fullname object.
                                       ## This enables us to use this 
+syntax : $him->fullname->nickname;
  $self->{NAME} = undef; ## define some elements in the hash
  $self->{AGE} = undef;
  $self->{PEERS} = [];
  $self->{"_CENSUS"} = \$Census;   ## Take a reference to the global v
+ariable.  Preceding underscore indicative of magic.
                                   ## This is 'private' data and now t
+he object being created contains a reference to
                                   ## global data i.e. the global data
+ is not accessed directly.
  bless($self,$class); ## tell the reference it is an object in the $c
+lass namespace
                       ## this class becomes inheritable because we us
+e the $class passed in, and not the current (Person1) class/namespace
  ++ ${ $self->{"_CENSUS"} };
  return $self;
}

## a new "bimodal" method (class or object) which sets the global vari
+able $Debugging either by direct access for the class method
## or sets up a reference to the debug level within the object.
## This maintains scalability and keeps the class inheritable.
sub debug {
  my $self = shift;
  confess "usage: thing->debug(level)"  unless @_ = 1;
  my $level = shift;
  if (ref $self)  {
    $self->{"_DEBUG"} = $level; ## just set the debug level for the ob
+ject;
  }  else {
    $Debugging = $level; ## do it for the whole class
  }
}

## These methods access per-object data
##  - all will set the item concerned where an argument is given
##  - all will return the item value
##  - all these methods work directly on the hash value

sub fullname {
  my $self = shift;
  return $self->{FULLNAME}; ## Returns the hash ref of the fullname ob
+ject so can use $him->fullname->title etc..
}

sub name {
  ## this method changes to accomodate the new information.
  my $self = shift; ## move the object off the argument stack
  ## if (@_) { $self->{NAME} = shift } ##if there is anything left ass
+ume the first is the name
  return $self->{FULLNAME}->nickname(@_) || $self->{FULLNAME}->christi
+an(@_);
}

sub age {
  my $self = shift; ## again shift the object off the stack
  if (@_) { $self->{AGE} = shift } ## if any left assume it is the obj
+ect's age.
  return $self->{AGE};
}

sub peers {
  my $self = shift; ## once more shift the object off the argument sta
+ck
  if (@_) { $self->{PEERS} = @_ } ## This is a list/array of peers
  return $self->{PEERS};
}

## Other methods in the class
##
##  Use the previously defined data access methods
##  which will be slower but will protect against changes in internal 
+representation
##
sub exclaim {
  my $self = shift;
  return sprintf "Hi I'm %s, age %d, working with %s",
         $self->name, $self->age, join(",",$self->peers);
}
sub happy_birthday {
  my $self = shift;
  return $self->age($self->age() +1 );
}

## return either the value of $self->{"_CENSUS"}'s referent or the val
+ue of the global data
## when no object has been passed in.
sub population {
  my $self = shift;
  if ( ref $self ) {   ## if a reference has called this, i.e. an obje
+ct.
    printf $self->name."\n";
    return ${$self->{"_CENSUS"} } ; ## return a reference to the scala
+r value
  } else {
    return $Census;
  }
}

## when a Person object dies need to delete them from the population
## use the implicitly called DESTROY method
## only called when an object has to be destroyed so no need to check 
+the status of $self.
sub DESTROY {
  my $self = shift;
  if ($Debugging || $self->{"_DEBUG"}) { carp 'Destroying $self ' . $s
+elf->name() }

  -- ${ $self->{"_CENSUS"} };
}

##
## The END function is the final end of the class, typically called in
+ a LIFO order when the program exits
## which is why we use print because Carp will have already ENDed.
sub END {
  if ($Debugging) {
    print "All persons are going away now\n";
  }
}


=head1 NAME

Person - class to implement people

=head1 SYNOPSIS

 use Person;

 #################
 # class methods #
 #################

 $ob    = Person->new;
 $count = Person->population;


 #######################
 object data methods #
 #######################

 ### get versions ###
 $who   = $ob->name;
 $years = $ob->age;
 @pals  = $ob->peers;

 ### set versions ###
 $ob->name("Jason");
 $ob->age(23);
 $ob->peers( "Norbert", "Rhys", "Phineas" );

 ########################
 # other object methods #
 ########################
 $phrase = $ob->exclaim;
 $ob->happy_birthday;
=head1 DESCRIPTION

 The Person class implements dah dee dah dee dah....
=cut
1;
[download]