File Coverage

blib/lib/Class/Object.pm

Criterion	Covered	Total	%
statement	33	33	100.0
branch	4	4	100.0
condition	2	3	66.6
subroutine	6	6	100.0
pod	2	2	100.0
total	47	48	97.9

package Class::Object;

use strict;
no strict 'refs';       # we use symbolic refs all over
use vars qw($VERSION);
$VERSION = '0.01';

=head1 NAME

Class::Object - each object is its own class

=head1 SYNOPSIS

    use Class::Object;

    # Generate an object, give it a method called 'foo'
    my $obj = Class::Object->new;
    $obj->sub('foo', sub { return "FOO, I SAY!\n" });

    # Generate another object, give it a different method called 'foo'.
    my $another_obj = Class::Object->new;
    $another_obj->sub('foo', sub { return "UNFOO!\n" });

    # Get copies of those methods back out, just like any other.
    my $obj_foo = $obj->can('foo');
    my $another_foo = $another_obj->can('foo');

    # Same names, same classes, different methods!
    print $obj->foo;            # "FOO, I SAY!"
    print &$obj_foo;            # "FOO, I SAY!"
    print $another_obj->foo;    # "UNFOO!"
    print &$another_foo;        # "UNFOO!"

    print "Yep\n" if $obj->isa('Class::Object');            # Yep
    print "Yep\n" if $another_obj->isa('Class::Object');    # Yep


    # $obj->new clones itself, so $same_obj->foo comes out as $obj->foo
    my $same_obj = $obj->new;
    print $same_obj->foo;       # "FOO, I SAY!"

=head1 DESCRIPTION

Traditionally in OO, objects belong to a class and that class as
methods.  $poodle is an object of class Dog and Dog might have methods
like bark(), fetch() and nose_crotch().  What if instead of the
methods belonging to the Dog class, they belonged to the $poodle
object itself?

That's what Class::Object does.


=head2 Methods

For the most part, these objects work just like any other.  Things
like can() and isa() work as expected.

=over 4

=item B

    my $obj = Class::Object->new;

Generates a new object which is its own class.

    my $clone_obj = $obj->new;

Generates a new object which is in the same class as $obj.  They share
their methods.

=cut

my $counter = 0;

sub new {
    my($proto) = shift;
    my($class) = ref $proto || $proto;

    my $obj_class;
    if( ref $proto ) {
        $obj_class = ref $proto;
        ${$obj_class.'::_count'}++;
    }
    else {
        $obj_class = $class.'::'.$counter++;
        @{$obj_class.'::ISA'} = $class;
        ${$obj_class.'::_count'} = 1;
    }
    bless {}, $obj_class;
}

=item B

  $obj->sub($meth_name, sub { ...code... });

This is how you declare a new method for an object, almost exactly
like how you do it normally.

Normally you'd do this:

  package Foo;
  sub wibble {
      my($self) = shift;
      return $self->{wibble};
  }

In Class::Object, you do this:

  my $foo = Class::Object->new;
  $foo->sub('wibble', sub {
      my($self) = shift;
      return $self->{wibble};
  });

Only $foo (and its clones) have access to wibble().

=cut

sub sub {
    my($self, $name, $meth) = @_;
    *{ref($self).'::'.$name} = $meth;
}

# When the last object in a class is destroyed, we completely
# annihilate that class, its methods and variables.  Keeps things
# from leaking.
sub DESTROY {
    my($self) = shift;
    my $obj_class = ref $self;
    ${$obj_class.'::_count'}--;
    unless( ${$obj_class.'::_count'} ) {
        undef %{$obj_class.'::'};
    }
}

=back

=head1 BUGS and CAVEATS

This is just a proof-of-concept module.  The docs stink, there's no
real inheritance model... totally incomplete.  Drop me a line if you'd
like to see it completed.

B rebless a Class::Object object.  Bad Things will happen.

=head1 AUTHOR

Michael G Schwern


=head1 SEE ALSO

L is another way to do the same thing (and much more
complete).

=cut


1;