#!/usr/bin/perl -w
# Simple Self-like (prototype-based) programming for Perl
# $Revision: 1.4 $
# $Log: Prototyped.pm,v $
# Revision 1.4 2001/07/06 19:43:35 ned
# Added better test routines; got fields working right.
# Fixed DESTROY (was not destroying symbol tables).
#
# Revision 1.3 2001/07/06 04:46:19 ned
# added ability to overload ref to provide "parent".
# Not sure this is useful yet. Also added class field
# pointing back at package for efficiency.
#
# Revision 1.2 2001/07/06 00:49:36 ned
# Made Data::Dumping work; removed memory leak.
#
package Class::Prototyped;
use strict;
use Carp();
$Class::Prototyped::VERSION = '0.01';
my $prefix = 'PKG';
use constant FULL_PREFIX => 'PKG0x';
use constant FULL_PREFIX_LENGTH => 5;
# re-define ref() to return first parent's class.
# call this in a BEGIN block if you want this behavior
# BEGIN { Class::Prototyped::useNewRef() }
sub useNewRef
{
*CORE::GLOBAL::ref = sub
{
no strict 'refs';
my $package = CORE::ref( $_[0] );
return
substr( $package, 0, FULL_PREFIX_LENGTH ) eq FULL_PREFIX ?
CORE::ref( $_[0]->{__parents}->[0] )
|| ${"$package\::ISA"}[0] : $package;
};
}
sub useStandardRef
{
*CORE::GLOBAL::ref = *CORE::ref;
}
# Call this before using Data::Dumper->Dump to allow
# Prototyped objects to be serialized (scalars only).
sub allowDataDumping
{
$Data::Dumper::Freezer = '_freezer';
$Data::Dumper::Toaster = '_toaster';
}
# Constructor. Pass in field definitions.
sub new
{
my $class = shift;
my $self = {
__parents => [],
};
( my $packageName = "$self" ) =~ s/^.*HASH\(([^)]+)\)/$prefix$1/;
bless $self, $packageName; # in my own package
$self->{__class} = $packageName;
no strict 'refs';
push @{"$packageName\::ISA"}, $class; # inherit from given clas
+s
$self->addSlots(@_);
$self;
}
# Given one object and an optional list of
# fields and/or subroutines, return a new
# object that inherits from the given object.
sub clone
{
my $original = shift;
my $self = new( __PACKAGE__, @_ );
$self->addParent($original);
# copy parent scalar slots
while ( my ( $key, $value ) = each(%$original) )
{
$self->{$key} = $value if !exists( $self->{$key} );
}
$self;
}
# Return my first parent or undef.
sub prototype
{
$_[0]->{__parents}->[0];
}
# Return a CODE ref if I define the given name
# in my own symbol table (no inheritance).
sub canI
{
no strict 'refs';
# *{"$class\::$name"}{CODE};
*{ $_[0]->{__class} . '::' . $_[1] }{CODE};
}
# Return the type of my slot ('scalar' or CODE ref or undef)
sub typeOf
{
my $self = shift;
my $slotName = shift;
return 'scalar' if exists( $self->{$slotName} );
return $self->can($slotName);
}
# Symbol table for scalar access routines.
# Key is name, value is closure.
my %scalarClosures;
sub addSlots
{
my $self = shift;
my $packageName = $self->{__class};
my %slots = (@_);
while ( my ( $slot, $value ) = each(%slots) )
{
no strict 'refs';
next if substr( $slot, 0, 2 ) eq '__';
if ( UNIVERSAL::isa( $value, 'CODE' ) ) # allow for blessed
+ subs
{
local $^W = 0; # suppress redefining messages.
*{"$packageName\::$slot"} = $value;
}
else
{
# Want to add a scalar slot.
# The way we do this is to make a closure that accesses
# a named field in the receiver, and stick that closure
# into a package global. Then we copy the CODE ref into
# the receiver's namespace.
# We have to do this even if a parent has defined a slot
# accessor because the parent could re-define the slot.
$self->{$slot} = $value;
my $closure = ( $scalarClosures{$slot} ||= sub
{
( @_ > 1 ) ? $_[0]->{$slot} = $_[1] : $_[0]->{$slot}
+;
} );
*{"$packageName\::$slot"} = $closure;
}
}
}
sub deleteSlots
{
my $self = shift;
my $packageName = $self->{__class};
foreach my $slot (@_)
{
Carp::carp "won't delete slot named $slot\n", next
if substr( $slot, 0, 2 ) eq '__';
no strict 'refs';
my $name = "$packageName\::$slot";
# save the glob...
local *old = *{$name};
# and restore everything else
local *new;
foreach my $type (qw(HASH IO FORMAT SCALAR ARRAY))
{
my $elem = *old{$type};
next if !defined($elem);
*new = $elem;
}
*{$name} = *new;
delete( $self->{$slot} );
}
}
# Return the names of my slots
sub mySlotNames
{
my $self = shift;
my %retval;
my $key;
my $pkg = $self->{__class};
no strict 'refs';
foreach $key ( keys( %{"$pkg\::"} ) )
{
$retval{$key}++ if defined( *{"$pkg\::$key"}{CODE} );
}
return sort keys(%retval);
}
# may return dups
sub allSlotNames
{
my $self = shift;
my @retval;
foreach my $parent ( $self->withAllParents() )
{
push ( @retval, $parent->mySlotNames() );
}
return wantarray ? @retval : \@retval;
}
sub myScalarSlotNames
{
my $self = shift;
my @scalars = grep { !/^__/ } sort keys(%$self);
return wantarray ? @scalars : \@scalars;
}
# may return dups
sub allScalarSlotNames
{
my $self = shift;
my @retval;
foreach my $parent ( $self->withAllParents() )
{
push ( @retval, $parent->myScalarSlotNames() );
}
return wantarray ? @retval : \@retval;
}
# Get or set the objects that are my parents.
# This will at least include my prototype.
# If I have no prototype, then also add Class::Prototyped
# to my @ISA.
# This will filter out parents that would create circular
# inheritance.
# Note that all parents set by mixIn will be pushed to the end.
sub parents
{
my $self = shift;
my $class = $self->{__class};
no strict 'refs';
my $isa = \@{"$class\::ISA"};
if (@_) # set
{
my @old = grep {
$_ ne __PACKAGE__
and substr( $_, 0, FULL_PREFIX_LENGTH ) ne FULL_PREFIX;
} @$isa;
@$isa = map { $_->{__class} } grep {
UNIVERSAL::isa( $_, $class ) ?
( Carp::carp("attempt at recursive inheritance"), 0 ) :
+1;
} @_;
push @$isa, @old, __PACKAGE__;
$self->{__parents} = [@_];
}
else # get
{
return wantarray ? @{ $self->{__parents} } : $self->{__parents
+};
}
}
# assumes that there are no inheritance cycles.
sub allParents
{
my $self = shift;
my $retval = shift || [];
my $seen = shift || {};
foreach my $parent ( @{ $self->{__parents} } )
{
next if $seen->{$parent}++;
push @$retval, $parent;
$parent->allParents( $retval, $seen );
}
return wantarray ? @$retval : $retval;
}
sub withAllParents
{
my $self = shift;
my $retval = [$self];
my $seen = { $self => 1 };
$self->allParents( $retval, $seen );
}
# Return the first parent satisfying the predicate
# Assumes that there are no inheritance cycles.
sub firstParentThat
{
my $self = shift;
my $pred = shift;
my $seen = shift || {};
foreach my $parent ( @{ $self->{__parents} } )
{
next if $seen->{$parent}++;
return $parent if $pred->($parent);
my $found = $parent->firstParentThat( $pred, $seen );
return $found if defined($found);
}
return undef;
}
# Add one or more parents to me.
sub addParent
{
my $self = shift;
my @parents = ( $self->parents(), @_ );
$self->parents(@parents);
}
# Mix in another package[s] (may load the package)
# Note that we don't call import; including the package
# in ISA will import everything!
sub mixIn
{
my $self = shift;
my $class = $self->{__class};
foreach my $package (@_)
{
eval <<EOF;
package $class;
require $package;
push \@$class\::ISA, '$package';
EOF
}
}
# load the given file or package in the receiver's namespace
# Note that no import is done.
# Returns an error message if bad, or undef if OK.
sub include
{
my $self = shift;
my $name = shift;
$name = "'$name'" if $name =~ /\.p[lm]$/i;
my $pkg = $self->{__class};
eval <<EOF;
package $pkg;
require $name;
EOF
$@;
}
# Remove my symbol table
sub DESTROY
{
my $self = shift;
my $class = $self->{__class};
if ( substr( $class, 0, FULL_PREFIX_LENGTH ) eq FULL_PREFIX )
{
delete( $main::{ $class . '::' } );
}
}
# called before storing
sub _freezer
{
my $self = shift;
# TODO save subs somewhere
$self;
}
# called after retrieving (need to re-bless, make closures)
sub _toaster
{
my $self = shift;
my $newSelf = Class::Prototyped->new(%$self);
$newSelf->parents( @{ $self->{__parents} } );
# TODO remove subs defined for inherited fields
# TODO stub subs
$newSelf;
}
1;
__END__
=head1 NAME
Class::Prototyped - Fast prototype-based OO programming in Perl
=head1 SYNOPSIS
use strict;
use Class::Prototyped;
$, = ' ';
$\ = "\n";
my $p = Class::Prototyped->new(
field1 => 123,
sub1 => sub { print "this is sub1 in p" },
sub2 => sub { print "this is sub2 in p" }
);
$p->sub1;
print ref($p), $p->field1;
$p->field1('something new');
print ref($p), $p->field1;
print ref($p), "is prototyped from", $p->prototype;
my $p2 = $p->clone(
field2 => 234,
sub2 => sub { print "this is sub2 in p2" }
);
$p2->sub1;
$p2->sub2;
print ref($p2), $p2->field1, $p2->field2;
$p2->field1('and now for something different');
print ref($p2), $p2->field1;
$p2->addSlots( sub1 => sub { print "this is sub1 in p2" } );
$p2->sub1;
print ref($p2), "is prototyped from", $p2->prototype;
$p2->include('xx.pl');
$p2->aa();
$p2->deleteSlots('sub1');
$p2->sub1;
=head1 DESCRIPTION
This package provides for efficient and simple prototype-based program
+ming
in Perl. You can provide different subroutines for each object, and al
+so
have objects inherit their behavior and state from another object.
Field access is provided by closures. As a result, it uses normal Perl
inheritance for access to both data and subroutines.
Unlike Class::SelfMethods, this does not use AUTOLOAD.
As a result, it is about
120% faster for field writes,
150% faster for field reads,
and 500% faster for subroutine calls
than Class::SelfMethods.
=head1 METHODS
=over 4
=item new() - Construct a new Class::Prototyped object.
Any arguments will be taken as field definitions;
subroutines will be installed in a private symbol table,
and the new object will be set to inherit from the given
class (which is some subclass of Class::Prototyped, of course).
For instance, the following:
my $p = Class::Prototyped->new(
field1 => 123,
sub1 => sub { print "this is sub1 in p" },
sub2 => sub { print "this is sub2 in p" }
);
will define a new Class::Prototyped object with two subroutine
definitions and one named field.
=item clone() - Duplicate me
b<clone()> duplicates an object, and allows you to add or override
slots. The slot definition is the same as in B<new()>.
my $p2 = $p1->clone(
sub1 => sub { print "this is sub1 in p2" },
);
Methods (and fields) inherited from prototypes are available
using the usual Perl $self->SUPER::something() mechanism:
my $p1 = Class::Prototyped->new(
sub1 => sub { print "this is sub1 in p1" },
);
my $p2 = $p1->clone(
sub1 => sub { print "this is sub1 in p2" },
# The following calls $p1.sub1(), not $p2.sub1():
sub2 => sub { my $self = shift; $self->SUPER::sub1() },
);
=item prototype() - Return the receiver's prototype or undef
This returns the object that the receiver is using as a prototype.
my $p1 = Class::Prototyped->new;
$p1->prototype; # returns undef
my $p2 = $p1->clone;
$p2->prototype; # returns $p1
=item addSlots() - Add or override slot definitions
b<addSlots()> allows you to add or override slot definitions
in the receiver.
$p->addSlots(
fred => 'this is fred',
doSomething => sub { print 'doing something with ' . $_[1] },
);
$p->doSomething( $p->fred );
=item deleteSlots() - Delete one or more of the receiver's slots by na
+me
This will let you delete existing slots in the receiver.
If those slots were defined earlier in the prototype chain,
those earlier definitions will now be available.
my $p1 = Class::Prototyped->new(
field1 => 123,
sub1 => sub { print "this is sub1 in p1" },
sub2 => sub { print "this is sub2 in p1" }
);
my $p2 = $p1->clone(
sub1 => sub { print "this is sub1 in p2" },
);
$p2->sub1; # calls $p2.sub1
$p2->deleteSlots('sub1');
$p2->sub1; # calls $p1.sub1
$p2->deleteSlots('sub1');
$p2->sub1; # still calls $p1.sub1
=item mySlotNames() - Return all of the receiver's locally defined slo
+ts
my $p1 = Class::Prototyped->new(
field1 => 123,
sub1 => sub { print "this is sub1 in p1" },
sub2 => sub { print "this is sub2 in p1" }
);
$p1->mySlotNames(); # returns ('field1', 'sub1', 'sub2')
=item allSlotNames() - Return all of the receiver's slots (local and i
+nherited)
my $p1 = Class::Prototyped->new(
field1 => 123,
sub1 => sub { print "this is sub1 in p1" },
sub2 => sub { print "this is sub2 in p1" }
);
my $p2 = $p1->clone(
sub3 => sub { print "this is sub3 in p2" },
);
$p2->allSlotNames(); # returns ('sub3', 'field1', 'sub1', 'sub2')
=item include() - Include a Perl source file in the receiver's context
This allows you to use already-written Perl code to supply
behavior for one or more of your objects. For instance, you could
make a file called 'myfuncs.pl' that contains:
sub a { 'a' }
sub b { 'b' }
1;
And then you could add those definitions of a() and b() to
any of your Class::Prototyped objects by using B<include()>:
my $p1 = Class::Prototyped->new;
my $p2 = $p1->clone;
$p1->include('myfuncs.pl');
$p1->a(); # returns 'a'
$p2->a(); # same here, because of inheritance.
=item addParent() - Add an object to the receiver's parents list.
You can have more than one prototype; inheritance works just like
multiple inheritance in Perl. If the receiver doesn't respond to
a message, the parent list is searched.
Checks for attempts at circular inheritance.
my $p1 = Class::Prototyped->new(
sub1 => sub { print "this is sub1 in p1" },
);
my $p2 = $p1->clone(
sub2 => sub { print "this is sub2 in p2" },
);
my $p3 = Class::Prototyped->new(
sub3 => sub { print "this is sub3 in p3" },
);
$p2->sub1; # searches first in $p2, then in $p1 for sub1()
$p2->addParent($p3);
$p2->sub3; # searches first in $p2, then in $p1, then in $p3 for
+sub3()
$p3->addParent($p2); # warns and does nothing (circular)
=item parents() - Get or set the objects that are the receiver's paren
+ts.
Get or set the objects that are the receiver's parents.
If called with no arguments: return the receiver's parents.
This will at least include the receiver's prototype.
This will filter out parents that would create circular
inheritance.
When called in an array context, returns a list;
when called in a scalar context, returns an array reference.
my $p1 = Class::Prototyped->new;
$p1->parents; # returns ()
my $p2 = $p1->clone;
$p2->parents; # returns ($p1)
my $p3 = Class::Prototyped->new;
$p2->addParent($p3);
$p2->parents; # returns ($p1, $p3)
If called with arguments: set the receiver's parents.
If I have no prototype, then also add Class::Prototyped
to the receiver's @ISA.
Checks for attempts at circular inheritance.
my $p1 = Class::Prototyped->new;
my $p2 = $p1->clone;
my $p3 = Class::Prototyped->new;
my $p4 = Class::Prototyped->new;
$p2->parents(); # returns ($p1)
$p2->parents($p3, $p4);
$p2->parents(); # returns ($p3, $p4)
$p3->parents($p2); # warns and does nothing (circular)
=back
=head1 AUTHOR
Written by Ned Konz, perl@bike-nomad.com
=head1 LICENSE
Copyright (c) 2001 Ned Konz. All rights reserved.
This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<Class::SelfMethods>
L<Class::Object>
L<Class::Classless>
|