#!/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>
In reply to Object-Oriented programming without classes! by bikeNomad
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |