File Coverage

blib/lib/Class/Inner.pm

Criterion	Covered	Total	%
statement	49	50	98.0
branch	6	12	50.0
condition	1	2	50.0
subroutine	11	11	100.0
pod	3	3	100.0
total	70	78	89.7

package Class::Inner;

use vars qw/$VERSION/;

$VERSION = 0.200_001;

use strict;
use Carp;

=head1 NAME

Class::Inner - A perlish implementation of Java like inner classes

=head1 SYNOPSIS

    use Class::Inner;

    my $object = Class::Inner->new(
	parent => 'ParentClass',
        methods => { method => sub { ... } }, },
        constructor => 'new',
        args => [@constructor_args],
    );

=head1 DESCRIPTION

Yet another implementation of an anonymous class with per object
overrideable methods, but with the added attraction of sort of working
dispatch to the parent class's method.

=head2 METHODS

=over 4

=item B

Takes a hash like argument list with the following keys.

=over 4

=item B

The name of the parent class. Note that you can only get single
inheritance with this or B won't work.

=item B

A hash, keys are method names, values are CODEREFs.

=item B

The name of the constructor method. Defaults to 'new'.

=item B

An anonymous array of arguments to pass to the constructor. Defaults
to an empty list.

=back

Returns an object in an 'anonymous' class which inherits from the
parent class. This anonymous class has a couple of 'extra' methods:

=over 4

=item B

If you were to pass something like

    $obj = Class::Inner->new(
	parent  => 'Parent',
	methods => { method =>  sub { ...; $self->SUPER::method(@_) } },
    );

then C<$self-CSUPER::method> almost certainly wouldn't do what you expect,
so we provide the C method which dispatches to the parent
implementation of the current method. There seems to be no good way of
getting the full C functionality, but I'm working on it.

=item B

Because B works by creating a whole new class name for your
object, it could potentially leak memory if you create a lot of them. So we
add a C method that removes the class from the symbol table once
it's finished with.

If you need to override a parent's DESTROY method, adding a call to
C to it. Do it at the
end of the method or your other method calls won't work.

=back

=cut

#'

sub new {
    my $class	    = shift;
    my %args	    = ref($_[0]) ? %{$_[0]} : @_;
    my $parent	    = $args{parent} or
	croak "Can't work without a parent class\n";
    my %methods	    = %{$args{methods}||{}};
    my $constructor = $args{constructor} || 'new';
    my @constructor_args = @{$args{args} || []};

    my $anon_class = $class->new_classname;

    no strict 'refs';

    @{"$anon_class\::ISA"} = $parent;

    foreach my $methodname (keys %methods) {
	*{"$anon_class\::$methodname"} = sub {
	    local $Class::Inner::target_method = $methodname;
	    $methods{$methodname}->(@_);
	};
    }

    # Add the SUPER method.

    unless (exists $methods{SUPER}) {
	*{"$anon_class\::SUPER"} = sub {
	    my $self = shift;
	    my $target_method =
		join '::', $parent, $Class::Inner::target_method;
	    $self->$target_method(@_);
	};
    }

    unless (exists $methods{DESTROY}) {
	*{"$anon_class\::DESTROY"} = sub {
	    my $self = shift;
	    Class::Inner::clean_symbol_table($anon_class);
	    bless $self, $parent;
	}
    }
    # Instantiate
    my $obj = $anon_class->new(@constructor_args);
}

=item B

The helper subroutine that DESTROY uses to remove the class from the
symbol table.

=cut

sub clean_symbol_table {
    my $class = shift;
    no strict 'refs';
    undef %{"${class}::"};
}

=item B

Returns a name for the next anonymous class.

=cut

{
    my $class_counter;

    sub new_classname {
	my $baseclass = shift;
	return "$baseclass\::__A" . $class_counter++;
    }
}

1;
__END__