File Coverage

blib/lib/Class/Methods.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	3	4	75.0
condition			n/a
subroutine	13	13	100.0
pod	0	5	0.0
total	69	75	92.0

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__