File Coverage

blib/lib/Object/Adhoc.pm

Criterion	Covered	Total	%
statement	55	70	78.5
branch	6	16	37.5
condition	6	10	60.0
subroutine	12	14	85.7
pod	2	2	100.0
total	81	112	72.3

use 5.008;
use strict;
use warnings;

package Object::Adhoc;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.006';

use Digest::MD5 qw( md5_hex );
use Exporter::Shiny qw( object make_class );
our @EXPORT = qw( object );

BEGIN {
	*USE_XS = eval 'use Class::XSAccessor 1.19 (); 1'
		? sub () { !!1 }
		: sub () { !!0 };
};

BEGIN {
	require Hash::Util;
	*lock_ref_keys = 'Hash::Util'->can('lock_ref_keys')
		|| sub { return; };
};

our $RESERVED_REGEXP;

# Yes, you can push extra methods onto this array if you need to,
# but if you do that, then set $RESERVED_REGEXP to undef so that
# make_class will rebuild it!
#
our @RESERVED_METHODS = qw(
	import unimport
	DESTROY
	AUTOLOAD
	isa DOES does can VERSION
	meta new
	TO_JSON
);
#
# Note that tie-related stuff isn't on the list of reserved methods
# because people using those names isn't likely to cause any actual
# harm.

sub object {
	my ($data, $keys) = @_;
	$keys ||= [ keys %$data ];
	bless $data, make_class($keys);
	lock_ref_keys($data, @$keys);
	$data;
}

my %made;
sub make_class {
	my ($keys) = @_;
	my $joined = join "|", sort(@$keys);
	return $made{$joined} if $made{$joined};

	my $class  = sprintf('%s::__ANON__::%s', __PACKAGE__, md5_hex($joined));

	my %getters     = map(+($_ => $_), @$keys);
	my %predicates  = map(+((/^_/?"_has$_":"has_$_")=> $_), @$keys);

	$RESERVED_REGEXP ||= do {
		my $re = join "|", map quotemeta($_), @RESERVED_METHODS;
		qr/\A(?:$re)\z/;
	};

	for my $key (@$keys) {
		if (exists $predicates{$key}) {
			delete $predicates{$key};
			require Carp;
			Carp::carp("Ambiguous method '$key' is getter, not predicate");
		}
		if ($key !~ /^[^\W0-9]\w*$/s or $key =~ $RESERVED_REGEXP) {
			require Carp;
			Carp::carp("Key '$key' would be bad method name, not generating methods");
			my $predicate = ($key =~ /^_/) ? "_has$key" : "has_$key";
			delete $getters{$key};
			delete $predicates{$predicate};
		}
	}

	if (USE_XS) {
		'Class::XSAccessor'->import(
			class             => $class,
			getters           => \%getters,
			exists_predicates => \%predicates,
		);
	}
	else {
		require B;
		my $code = "package $class;\n";
		while (my ($predicate, $key) = each %predicates) {
			my $qkey = B::perlstring($key);
			$code .= "sub $predicate :method { &Object::Adhoc::_usage if \@_ > 1; CORE::exists \$_[0]{$qkey} }\n";
		}
		while (my ($getter, $key) = each %getters) {
			my $qkey = B::perlstring($key);
			$code .= "sub $getter :method { &Object::Adhoc::_usage if \@_ > 1; \$_[0]{$qkey} }\n";
		}
		$code .= "1;\n";
		eval($code) or do { require Carp; Carp::croak($@) };
	}

	do {
		no strict 'refs';
		*{"$class\::DOES"}     = \&_DOES;
		*{"$class\::does"}     = \&_DOES;
		*{"$class\::VERSION"}  = \$VERSION;
		*{"$class\::TO_JSON"}  = \&_TO_JSON;
	};

	$made{$joined} = $class;
}

sub _usage {
	my $caller = (caller(1))[3];
	require Carp;
	local $Carp::CarpLevel = 1 + $Carp::CarpLevel;
	Carp::croak("Usage: $caller\(self)"); # mimic XS usage message
}

sub _DOES {
	return !!1 if $_[1] eq __PACKAGE__;
	return !!1 if $_[1] eq 'HASH';
	shift->isa(@_);
}

sub _TO_JSON {
	my %hash = %{ +shift };
	\%hash;
}

1;

__END__