ObjectTemplate.pm
===================================================
package ObjectTemplate;
require Exporter;
@ObjectTemplate::ISA = qw(Exporter);
@ObjectTemplate::EXPORT = qw(attributes);
my $debugging = 1; # assign 1 to it to see code generated on the fly
# Create accessor functions, and new()
sub attributes {
my ($pkg) = caller(0);
@{"${pkg}::_ATTRIBUTES_"} = @_;
my $code = "";
foreach my $attr (get_attribute_names($pkg)) {
# If a field name is "color", create a global list in the
# calling package called @color
@{"${pkg}::_$attr"} = ();
# Define accessor only if it is not already present
unless ($pkg->can("$attr")) {
$code .= _define_accessor ($pkg, $attr);
}
}
$code .= _define_constructor($pkg);
eval $code;
if ($@) {
die "ERROR defining constructor and attributes for '$pkg':"
. "\n\t$@\n"
. "-----------------------------------------------------"
. $code;
}
}
# $obj->set_attributes (name => 'John', age => 23);
# Or, $obj->set_attributes (['name', 'age'], ['John', 23]);
sub set_attributes {
my $obj = shift;
my $attr_name;
if (ref($_[0])) {
my ($attr_name_list, $attr_value_list) = @_;
my $i = 0;
foreach $attr_name (@$attr_name_list) {
$obj->$attr_name($attr_value_list->[$i++]);
}
} else {
my ($attr_name, $attr_value);
while (@_) {
$attr_name = shift;
$attr_value = shift;
$obj->$attr_name($attr_value);
}
}
}
# @attrs = $obj->get_attributes (qw(name age));
sub get_attributes {
my $obj = shift;
my (@retval);
map $obj->${_}(), @_;
}
sub get_attribute_names {
my $pkg = shift;
$pkg = ref($pkg) if ref($pkg);
my @result = @{"${pkg}::_ATTRIBUTES_"};
if (defined (@{"${pkg}::ISA"})) {
foreach my $base_pkg (@{"${pkg}::ISA"}) {
push (@result, get_attribute_names($base_pkg));
}
}
@result;
}
sub set_attribute {
my ($obj, $attr_name, $attr_value) = @_;
my ($pkg) = ref($obj);
${"${pkg}::_$attr_name"}[$$obj] = $attr_value;
}
sub get_attribute {
my ($obj, $attr_name, $attr_value) = @_;
my ($pkg) = ref($obj);
return ${"${pkg}::_$attr_name"}[$$obj];
}
sub DESTROY {
# release id back to free list
my $obj = $_[0];
my $pkg = ref($obj);
local *_free = *{"${pkg}::_free"};
my $inst_id = $$obj;
# Release all the attributes in that row
local(*attributes) = *{"${pkg}::_ATTRIBUTES_"};
foreach my $attr (@attributes) {
undef ${"${pkg}::_$attr"}[$inst_id];
}
$_free[$inst_id] = $_free;
$_free = $inst_id;
}
sub initialize { }; # dummy method, if subclass doesn’t define one.
#################################################################
sub _define_constructor {
my $pkg = shift;
my $code = qq {
package $pkg;
sub new {
my \$class = shift;
my \$inst_id;
if (defined(\$_free[\$_free])) {
\$inst_id = \$_free;
\$_free = \$_free[\$_free];
undef \$_free[\$inst_id];
} else {
\$inst_id = \$_free++;
}
my \$obj = bless \\\$inst_id, \$class;
\$obj->set_attributes(\@_) if \@_;
\$obj->initialize;
\$obj;
}
};
$code;
}
sub _define_accessor {
my ($pkg, $attr) = @_;
# This code creates an accessor method for a given
# attribute name. This method returns the attribute value
# if given no args, and modifies it if given one arg.
# Either way, it returns the latest value of that attribute
# qq makes this block behave like a double-quoted string
my $code = qq{
package $pkg;
sub $attr { # Accessor ...
\@_ > 1 ? \$_${attr} \[\${\$_[0]}] = \$_[1] # set
: \$_${attr} \[\${\$_[0]}]; # get
}
if (!defined \$_free) {
# Alias the first attribute column to _free
\*_free = \*_$attr;
\$_free = 0;
};
};
$code;
}
1;
Employee.pm
=====================================================
#---------------------------------------------------------------------------
package Employee;
#---------------------------------------------------------------------------
# This package uses the ObjectTemplate package to declare an Employee object
#
#
# It consists
use ObjectTemplate;
@ISA = qw(ObjectTemplate);
&attributes qw(name age sex);
sub print {
my $obj = $_[0];
print "Employee[$$obj] ... Free index: $_free\n";
print "\tName => ", $obj->name ,"\n";
print "\tAge => ", $obj->age ,"\n";
}
sub name {
# Example of a custom accessor function
# Allows the name attribute to be set only once
my $obj = shift;
my $name = $obj->get_attribute("name");
if (@_) {
if ($name) {
die "Cannot update name \n";
} else {
$obj->set_attribute("name", $_[0]);
}
}
$name;
}
#-----------------------------------------------------------------------
# Sample inherited Class
#-----------------------------------------------------------------------
package HourlyEmployee;
@ISA = qw (Employee);
use ObjectTemplate;
attributes qw(wage);
#-----------------------------------------------------------------------
# TESTING CODE
# Simply invoke as "perl Employee.pm"
#-----------------------------------------------------------------------
if (! caller()) {
package main;
#-----------------------------------------------------------
# Check create
$e1 = Employee->new(name => 'test1', age => 43);
$e2 = Employee->new(name => 'test2', age => 50);
if ($e1->name ne 'test1' || $e2->age != 50) {
print "ERROR. Accessors not working\n";
} else {
print "OK. Accessors working\n";
}
#-----------------------------------------------------------
# Check that deleting one object doesn't mess the other
undef $e1;
if ($e2->name ne 'test2' || $e2->age != 50) {
print "ERROR ... Delete messing up other objects\n";
} else {
print "OK. Delete doesn't affect other objects\n";
}
#-----------------------------------------------------------
# Check creation of object after delete
$e1 = Employee->new(name => 'test1', age => 43);
if ($e1->name ne 'test1' || $e2->age != 50) {
print "ERROR .... Object not created correctly after delete\n";
} else {
print "OK. Object created correctly after delete\n";
}
#-----------------------------------------------------------
# Check if custom accessor called
eval {$e1->name("foo")};
if ($@ !~ /Cannot update name/) {
print "ERROR. Custom accessor not called\n";
} else {
print "OK. Custom accessor called\n";
}
#-----------------------------------------------------------
# Check if inherited properly
$e2 = HourlyEmployee->new(name => 'Joe', age => 47, wage => 40);
if ($e2->name ne 'Joe' || $e2->age != 47) {
print "ERROR. Accessors of inherited classes not working\n";
} else {
print "OK. Accessors of inherited classes working\n";
}
eval {$e2->name("foo")};
if ($@ !~ /Cannot update name/) {
print "ERROR. Inherited custom accessor not called\n";
} else {
print "OK. Inherited custom accessor works\n";
}
}
1;
#!/usr/bin/perl -w
use Employee;
use Benchmark;
package HashEmp;
sub new {
bless {name => 'ram', age => 23};
}
sub age {
$_[0]->{age};
}
package main;
$o = Employee->new(name => "ram", age => 32);
$o1 = HashEmp->new();
print ref($_);
print $o->age, " ", $o1->{age},"\n";
# Measure speed of accessors for objects built using ObjectTemplate
# and an ordinary hash
timethese (100000,
{"Employee", '$x = $o->age',
"HashEmp" , '$x = $o1->age'
}
);
