File Coverage

blib/lib/Class/Closure.pm

Criterion	Covered	Total	%
statement	120	126	95.2
branch	12	18	66.6
condition	3	9	33.3
subroutine	31	32	96.8
pod	0	6	0.0
total	166	191	86.9

package Class::Closure;
$Class::Closure::VERSION = '0.302';
# ABSTRACT: Encapsulated, declarative class style

use 5.006;
use warnings;
use strict;

use Exporter ();
use Carp ();
use Symbol ();

our @ISA = qw(Exporter);

our @EXPORT = qw(
	has
	public
	method
	accessor
	extends
	does
	destroy
);

our $PACKAGE;
our $EXTENDS;

sub import { _make_new( scalar caller ); goto &Exporter::import }

sub _install ($$) {
	my ( $name, $thing ) = @_;
	no strict 'refs';
	*{ "$PACKAGE\::$name" } = $thing;
}

sub _make_new {
	my ( $pkg ) = @_;

	$PACKAGE = $pkg;
	_install new => sub {
		my $base = ref $_[0] || $_[0];
		local $PACKAGE = my $package = _make_package();

		_install ISA => [ $base ];

		my ( @reblessed, @subisa, %subobj );

		_install DESTROY => sub {
			bless $_->[0], $_->[1] for @reblessed; # bless them back into their original class
			Symbol::delete_package( $package );
		};

		_install isa => sub {
			my ( $self, $class ) = @_;
			do { return 1 if $base->isa( $class ) };
			do { return 1 if $_->isa( $class ) } for @subisa;
			return;
		};

		local $EXTENDS = sub {
			my ( $var ) = @_;

			$var = $var->new if not ref $var;

			my $pkg = ref $var;
			bless $var, $PACKAGE;  # Rebless for virtual behavior

			push @reblessed, [ $var, $pkg ];  # bookkeeping for DESTROY

			push @subisa, $pkg;
			$subobj{ $pkg } = $var;

			return;
		};

		_install can => sub {
			my ( $self, $method ) = @_;

			my $code = do { no strict 'refs'; *{ "$package\::$method" }{'CODE'} };
			return $code if $code;

			for my $pkg ( @subisa ) {
				my $obj = $subobj{ $pkg };
				$code = $pkg->can( $method ) or next;
				my $delegate = sub {
					splice @_, 0, 1, $obj;
					goto &$code;
				};
				{ no strict 'refs'; *{ "$package\::$method" } = $delegate };
				return $delegate;
			}

			return;
		};

		_install AUTOLOAD => sub {
			our $AUTOLOAD =~ s/.*:://;
			if ( my $code = $_[0]->can( $AUTOLOAD ) ) {
				goto &$code;
			}
			elsif ( my $fallback = $_[0]->can( 'FALLBACK' ) ) {
				no strict 'refs';
				local *{ "$base\::AUTOLOAD" } = \$AUTOLOAD;
				goto &$fallback;
			}
			else {
				Carp::croak "Method $AUTOLOAD not found in class $base";
			}
		};

		$pkg->can( 'CLASS' )->( @_ );

		my $self = bless {}, $PACKAGE;

		$self->BUILD( @_[ 1 .. $#_ ] ) if $self->can( 'BUILD' );

		$self;
	};
}

{
my $counter = 0;
sub _make_package {
	"Class::Closure::_package_" . $counter++;
}
}

sub _find_name {
	my ( $var, $code ) = @_;
	require PadWalker;
	my %names = reverse %{ PadWalker::peek_sub( $code ) };
	my $name = $names{ $var } || Carp::croak "Couldn't find lexical name for $var";
	$name =~ s/^[\$\@%]//;
	$name;
}

sub has (\$) : lvalue {
	my ( $var ) = @_;

	require Devel::Caller;
	my $name = _find_name $var, Devel::Caller::caller_cv(1);

	_install $name, sub { $$var };
	$$var;
}

sub public (\$) : lvalue {
	my ( $var ) = @_;

	require Devel::Caller;
	my $name = _find_name $var, Devel::Caller::caller_cv(1);

	_install $name, sub : lvalue { $$var };
	$$var;
}

sub method ($&) {
	&_install;
	return;
}

sub accessor ($@) {
	my ( $name, %arg ) = @_;
	Carp::croak "accessor needs 'get' and 'set' attributes" unless $arg{'get'} && $arg{'set'};
	require Sentinel;
	_install $name, sub : lvalue {
		my $self = shift;
		Sentinel::sentinel(
			get => sub { $arg{'get'}->( $self ) },
			set => sub { $arg{'set'}->( $self, @_ ) },
		);
	};
	return;
}

sub extends($) { &$EXTENDS }

sub destroy(&) { _install DESTROY => \Class::Closure::DestroyDelegate->new( $_[0] ) }

package Class::Closure::DestroyDelegate;
$Class::Closure::DestroyDelegate::VERSION = '0.302';
sub new { bless $_[1] }
sub DESTROY { goto &{$_[0]} }

1;

__END__