#!/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 class
    $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 programming
in Perl. You can provide different subroutines for each object, and also
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 name

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 slots

  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 inherited)

  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 parents.

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>