view release on metacpan or  search on metacpan

lib/Class/Closure.pm  view on Meta::CPAN

			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;
our $VERSION = '0.304';

sub new { bless $_[1] }
sub DESTROY { goto &{$_[0]} }

1;

__END__

=pod