Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

Object-Oriented programming without classes!

by bikeNomad (Priest)
on Jul 05, 2001 at 01:37 UTC ( [id://93955]=sourcecode: print w/replies, xml ) Need Help??
Category: Language Enhancements
Author/Contact Info by bikeNomad, Ned Konz, perl@bike-nomad.com and Toby Everett. 5.005_03 port by chromatic.
Description: Are you tired of using classes for your OO programming? Realized that all you really need is objects and that classes are just extra baggage? Well, this module (Prototyped.pm) will let you do object-oriented programming without bothering with classes. It's very similar to Class::SelfMethods, but much faster than either Class::SelfMethods or Class::Classless, since it doesn't use AUTOLOAD.

This kind of programming is called prototype-based; the best known examples of languages supporting it are probably Self, NewtonScript, and JavaScript.

There are a couple of tricks here. The primary one is the construction of a new symbol table for every object. There is also some care taken when deleting slots so that inheritance continues to work.

update: added multiple parents, some more documentation. Made data inheritance work right.

update: There is a considerably re-worked version of this available at ftp://ftp.bike-nomad.com/Class-Prototyped-0.11.tar.gz

#!/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>
Replies are listed 'Best First'.
Re: Object-Oriented programming without classes!
by princepawn (Parson) on Jul 05, 2001 at 02:33 UTC
    The other framework for this type of oop, known as prototype-based oop, is Michael Schwern's just-published Class::Object.
      It looks like mine is more complete, with data inheritance, inclusion of external files (which allows explicit loading of functionality into selected objects), and the ability to delete fields or methods.

      At least from the README; I haven't been able to get a copy of it from CPAN yet.

      update: I finally found a copy; it's efficient but doesn't provide for inheritance or data fields; mine is much more complete. And just as fast, as far as I can tell. I also benchmarked against Class::Classless; my code is quite a bit faster (168x as fast for inherited subroutine calls, 20+ times as fast for field access!):

      empty subroutine calls Rate Classless SelfMethods Prototyped Object Pl +ainOleData Classless 4225/s -- -95% -99% -99% + -99% SelfMethods 90540/s 2043% -- -84% -84% + -85% Prototyped 577873/s 13578% 538% -- -1% + -2% Object 582772/s 13694% 544% 1% -- + -1% PlainOleData 587346/s 13802% 549% 2% 1% + -- empty inherited subroutine calls Rate Classless Prototyped Object Classless 3370/s -- -99% -99% Prototyped 568592/s 16772% -- -1% Object 572334/s 16883% 1% -- field reading Rate Classless SelfMethods Prototyped PlainOleD +ata Classless 3969/s -- -88% -95% - +98% SelfMethods 34115/s 760% -- -54% - +84% Prototyped 74488/s 1777% 118% -- - +64% PlainOleData 209199/s 5171% 513% 181% + -- field writing Rate Classless SelfMethods Prototyped PlainOleD +ata Classless 3760/s -- -92% -96% - +98% SelfMethods 47737/s 1170% -- -44% - +74% Prototyped 85151/s 2165% 78% -- - +54% PlainOleData 184470/s 4806% 286% 117% + -- inherited field reading Rate Classless Prototyped Classless 3268/s -- -96% Prototyped 73604/s 2152% -- inherited field writing Rate Classless Prototyped Classless 3231/s -- -96% Prototyped 85301/s 2540% --
Re: Object-Oriented programming without classes!
by clscott (Friar) on Jul 05, 2001 at 18:40 UTC
    Wow!

    Have you seen the discussion in this topic on perl6-language? Archives are here

    Clayton

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://93955]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (6)
As of 2024-03-19 07:56 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found