File Coverage

blib/lib/Data/Thunk/Object.pm

Criterion	Covered	Total	%
statement	44	53	83.0
branch	8	16	50.0
condition	0	3	0.0
subroutine	14	15	93.3
pod	0	5	0.0
total	66	92	71.7

#!/usr/bin/perl

package Data::Thunk::Object;
BEGIN {
  $Data::Thunk::Object::AUTHORITY = 'cpan:NUFFIN';
}
BEGIN {
  $Data::Thunk::Object::VERSION = '0.07';
}
use base qw(Data::Thunk::Code);

use strict;
use warnings;

use Scalar::Util qw(blessed reftype);

use namespace::clean;

use UNIVERSAL::ref;

our $get_field = sub {
	my ( $obj, $field ) = @_;

	my $thunk_class = blessed($obj) or return;
	bless $obj, "Data::Thunk::NoOverload";

	my $exists = exists $obj->{$field};
	my $value = $obj->{$field};

	bless $obj, $thunk_class;

	# ugly, but it works
	return ( wantarray
		? ( $exists, $value )
		: $value );
};

sub ref {
	my ( $self, @args ) = @_;

	if ( my $class = $self->$get_field("class") ) {
		return $class;
	} else {
		return $self->SUPER::ref(@args);
	}
}


foreach my $sym (keys %UNIVERSAL::) {
	no strict 'refs';

	next if $sym eq 'ref::';
	next if defined &$sym;

	local $@;

	eval "sub $sym {
		my ( \$self, \@args ) = \@_;

		if ( my \$class = \$self->\$get_field('class') ) {
			return \$class->$sym(\@args);
		} else {
			return \$self->SUPER::$sym(\@args);
		}
	}; 1" || warn $@;
}

sub AUTOLOAD {
	my ( $self, @args ) = @_;
	my ( $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );

	if ( $method !~ qr/^(?: class | code )$/ ) {
		my ( $exists, $value ) = $self->$get_field($method);

		if ( $exists ) {
			if ( CORE::ref($value) && reftype($value) eq 'CODE' ) {
				return $self->$value(@args);
			} else {
				return $value;
			}
		}
	}

	unshift @_, $method;
	goto $Data::Thunk::Code::vivify_and_call;
}

1;

__END__