view release on metacpan or  search on metacpan

lib/Object/Prototype.pm  view on Meta::CPAN

package Object::Prototype;

# $Id: Prototype.pm,v 0.2 2007/04/07 01:57:59 dankogai Exp dankogai $
use 5.008001;
use strict;
use warnings;
use Carp;
use Scalar::Util qw(refaddr);
use Storable ();

our $VERSION = sprintf "%d.%02d", q$Revision: 0.2 $ =~ /(\d+)/g;
our $DEBUG = 0;
my %constructor_of;
my %prototype_of;

sub new($$;$) {
    my $class       = shift;
    my $constructor = shift;
    my $self        = Storable::dclone($constructor);
    my $id          = refaddr $self;
    $constructor_of{$id} = $constructor;
    $prototype_of{$id}   = {};
    bless $self => $class;
    for my $method ( keys %{ $_[0] } ) {
        $self->prototype( $method, $_[0]->{$method} );
    }
    return $self;
}

sub prototype($$;$) {
    my $self   = shift;
    my $id     = refaddr $self;
    my $method = shift;
    $prototype_of{$id}{$method} = shift if @_;
    return $prototype_of{$id}{$method};
}

sub constructor($) {
    my $self   = shift;
    my $id     = refaddr $self;
    return $constructor_of{$id}
}

sub DESTROY {
    my $id = refaddr shift;
    carp "DESTROY: $id" if $DEBUG;
    delete $constructor_of{$id};
    delete $prototype_of{$id};
}

sub AUTOLOAD {
    my $self   = shift;
    my $method = our $AUTOLOAD;
    $method =~ s/.*:://o;
    my $id = refaddr $self;
    warn "$id -> $method" if $DEBUG;
    my $code = $prototype_of{$id}{$method};
    return $self->$code(@_) if $code;
    while ( my $constructor = $constructor_of{$id} ) {
        warn "$constructor -> $method" if $DEBUG;
        $id = refaddr $constructor;
        $code = ref $constructor eq ref $self
          ? $prototype_of{$id}{$method}    # Prototypal
          : $constructor->can($method);    # Classical Perl Obj.
        return $self->$code(@_) if $code;
    }
    confess "unknown method : $method" if !$code;
}

1;
__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Object::Prototype - Prototypal Object Model a la JavaScript

=head1 SYNOPSIS

  use Object::Prototype;
  use What::Ever;
  my $classical = What::Ever->new();
  $classical->foo("bar");