package Class::Methods;
use Devel::Pointer ();
require 5.005_62;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
# This allows declaration use Class::Methods ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '0.062';
# class: returns this object's class.
sub class ($) {
my $self = shift;
# Return the anonymous class object of a given object.
return Devel::Pointer::unsmash_hv(substr(ref $self, 2+length(__PACKAGE__)));
}
# extend: adds methods to this object's class.
sub extend ($;%) {
my $self = shift;
# Get the anonymous class object out of the object.
my $class = $self->class;
# To muddle with the symbol table, we have to turn some strict down.
no strict 'refs';
# While we have methods on the stack,
while (@_) {
# Get them off of the stack.
my($method, $coderef) = (shift, shift);
# Put them into the class object.
$class->{$method} = $coderef;
# And then into the symbol table.
*{__PACKAGE__ . "::" . (0+$class) . "::" . $method} = $coderef;
}
# We're done, give back the object we started with.
return $self;
}
# remove: removes methods from this object's class
sub remove ($;@) {
my $self = shift;
# Get the anonymous class object out of the object.
my $class = $self->class;
# To muddle with the symbol table, we have to turn some strict down.
no strict 'refs';
# While we have methods on the stack,
while (@_) {
# Get them off of the stack.
my($method) = shift;
# Remove them from the class object.
delete $class->{$method};
# And then from the symbol table.
undef *{__PACKAGE__ . "::" . (0+$class) . "::" . $method};
}
}
# base: tell this object's class to inherit from another class
sub base ($;@) {
my $self = shift;
# Get the anonymous class object out of the object.
my $class = class($self);
# Tell the new anonymous class to inherit from the passed modules.
{ eval "package " . __PACKAGE__ . '::' . (0+$class) . "; use base qw(" . join(' ', map { ref($_) || $_ } @_) . ");" }
}
# new: create and return a new object attached to a new (empty) class.
sub new ($;%) {
# I suppose I should care what package the user thinks we are, but I don't.
shift;
# Create our anonymous class.
my $class = {};
# Make it self-referential, so it stays around forever.
$class->{""} = $class;
# Bless the class object into its own (anonymous) class, for the moment, so we can use extend.
my $package = bless $class, __PACKAGE__ . '::' . (0+$class);
# Tell the new anonymous class to inherit from us.
base($class, __PACKAGE__);
# Add the user provided methods, if any.
$class->extend(@_) if @_;
# Return the package name of the newly created anonymous class.
return ref($class);
}
1;
__END__
=head1 NAME
Class::Methods - Object methods for working with classes
=head1 SYNOPSIS
use Class::Methods;
my $container = bless [], Class::Methods->new(
count => sub { return scalar @{$_[0]} },
);
print $container->count; # prints 0
$container->extend( push => sub { push @{$_[0]}, $_[1..$#_] } );
$container->push( qw[apples oranges] );
$container->remove( "push" );
print $container->count; # prints 2
# XXX: $container->base('ARRAY'); # import push(), pop(), splice(), etc.
=head1 DESCRIPTION
After discussing Ruby with Simon, I wrote this module to implement OO in
Perl via the builtin inheritance-based method system.
It seems to be pretty fun to work with. Kind of resesmbles ruby, though, and
I suspect it might start enroaching on Perl 6.
This is the first release, to share the madness with y'all. I've planned
serious uses of this module, so perhaps it'll find a good home.
test.pl is the only code example right. The core's small, and fun to read.
=head1 AUTHOR
Richard Soderberg, rsod@cpan.org
=head1 SEE ALSO
Class::Object
=cut