File Coverage

blib/lib/Object/Adhoc.pm

Criterion	Covered	Total	%
statement	100	121	82.6
branch	40	64	62.5
condition	15	29	51.7
subroutine	17	19	89.4
pod	2	2	100.0
total	174	235	74.0

use 5.008;
use strict;
use warnings;

package Object::Adhoc;

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

use Digest::MD5 qw( md5_hex );
use Scalar::Util qw( refaddr );
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, %opts) =
		(@_ == 0) ? _croak('Expected hashref') :
		(@_ <= 2) ? @_ : ($_[0], undef, @_[1..$#_]);
	$keys ||= delete($opts{keys}) || [ keys %$data ];
	bless $data, make_class($keys, %opts);
	if ($opts{recurse}) {
		_croak('Bad recurse option') if ref($opts{recurse}) || $opts{recurse} !~ /\A[0-9]+\z/;
		my %seen = (refaddr($data) => undef, %{ delete($opts{seen}) or {}});
		for my $k (keys %$data) {
			ref $data->{$k} or next;
			$data->{$k} = _recurse($data->{$k}, %opts, seen => \%seen);
		}
	}
	lock_ref_keys($data, @$keys);
	$data;
}

sub _recurse {
	my ($ref, %opts) = @_;
	my $lvl     = $opts{recurse} - 1;
	my $reftype = ref $ref;
	my %seen    = %{ delete($opts{seen}) or {} };
	return $ref if $lvl < 1 || !$reftype || exists $seen{refaddr($ref)};

	$seen{refaddr($ref)} = undef;

	if ($reftype eq 'ARRAY') {
		@$ref = map { ref($_) ? _recurse($_, %opts, recurse => $lvl, seen => \%seen) : $_ } @$ref;
		return $ref;
	}

	if ($reftype eq 'HASH') {
		return object($ref, %opts, recurse => $lvl, seen => \%seen);
	}

	if ($reftype eq 'CODE') {
		return sub {
			my $wa = wantarray;
			if ($wa) {
				return map { ref($_) ? _recurse($_, %opts, recurse => $lvl, seen => \%seen) : $_ } $ref->(@_);
			}
			elsif (defined $wa) {
				local $_ = $ref->(@_);
				return ref($_) ? _recurse($_, %opts, recurse => $lvl, seen => \%seen) : $_;
			}
			goto $ref;
		};
	}

	if ($reftype eq 'REF') {
		($$ref) = map { ref($_) ? _recurse($_, %opts, recurse => $lvl, seen => \%seen) : $_ } $$ref;
		return $ref;
	}

	return $ref;
}

my %made;
sub make_class {
	my ($keys, %opts) = @_;
	my $joined = join "|", sort(@$keys);
	$joined .= '*CTOR' if $opts{ctor};
	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 die($@);
	}

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

		if ( $opts{ctor} ) {
			my $re = join "|", map quotemeta($_), @$keys;
			*{"$class\::new"} = sub {
				my ($class, %hash) = (@_ == 2 and ref $_[1] eq 'HASH') ? ($_[0], %{$_[1]}) : (@_ % 2 == 1) ? @_ : _usage('class', 'hashref');
				for (keys %hash) {
					/\A(?:$re)\z/ or _croak("Bad key: $_");
				}
				return bless(\%hash, ref($class) || $class);
			};
		}
	};

	$made{$joined} = $class;
}

sub _usage {
	my $caller = (caller(1))[3];
	require Carp;
	local $Carp::CarpLevel = 1 + $Carp::CarpLevel;
	my @fields = @_ ? @_ : ('self');
	Carp::croak("Usage: $caller\(@{[join q[, ], @fields]})"); # mimic XS usage message
}

sub _croak {
	require Carp;
	goto \&Carp::croak;
}

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__