File Coverage

blib/lib/Object/Proto/Sugar.pm

Criterion	Covered	Total	%
statement	313	326	96.0
branch	121	142	85.2
condition	47	54	87.0
subroutine	57	59	96.6
pod			n/a
total	538	581	92.6

package Object::Proto::Sugar;

use 5.008003;
use strict;
use warnings;
use BEGIN::Lift;
use Devel::Hook;
use Object::Proto;
use Carp qw/croak/;

our $VERSION = 0.04;

use constant ro => 'ro';
use constant is_ro => ( is => ro );
use constant rw => 'rw';
use constant is_rw => ( is => rw );
use constant nan => undef;
use constant lzy => ( lazy => 1 );
use constant bld => ( builder => 1 );
use constant lzy_bld => ( lazy_build => 1 );
use constant trg => ( trigger => 1 );
use constant clr => ( clearer => 1 );
use constant req => ( required => 1 );
use constant coe => ( coerce => 1 );
use constant lzy_hash => (lazy => 1, isa => 'HashRef', default => {} );
use constant lzy_array => (lazy => 1, isa => 'ArrayRef', default => [] );
use constant lzy_str => (lazy => 1, isa => 'Str', default => "");
use constant dhash => (isa => 'HashRef', default => {});
use constant darray => (isa => 'ArrayRef', default => []);
use constant dstr => (isa => 'Str', default => "");

our (%valid_types, @type_list, %valid_constants, %modifier_dispatch);

BEGIN {
	@type_list  = @{ Object::Proto::list_types() };
	%valid_types = map { $_ => 1 } @type_list;
	%valid_constants = map { $_ => 1 } qw(
		ro rw is_ro is_rw nan
		lzy bld lzy_bld trg clr req coe
		lzy_hash lzy_array lzy_str dhash darray dstr
	);
	%modifier_dispatch = (
		before => \&Object::Proto::before,
		after  => \&Object::Proto::after,
		around => \&Object::Proto::around,
	);
}

sub import {
	my ($pkg, @import) = @_;
	no strict 'refs';
	my $caller = caller();
	my (@spec, @modifiers, @extends, @with, @requires, $is_role);
	$is_role = 1 if grep { $_ eq '-role' } @import;

	if (grep { $_ eq '-types' } @import) {
		*{"${caller}::${_}"} = sub { $_ } for @type_list;
	}
	if (grep { $_ eq '-constants' } @import) {
		*{"${caller}::${_}"} = \&{"Object::Proto::Sugar::${_}"} for keys %valid_constants;
	}

	for my $name (@import) {
		next if $name =~ /^-/;
		if ($name =~ /^[A-Z]/) {
			croak "Unknown type '$name' requested from Object::Proto::Sugar"
				unless $valid_types{$name};
			*{"${caller}::${name}"} = sub { $name };
		} else {
			croak "Unknown constant '$name' requested from Object::Proto::Sugar"
				unless $valid_constants{$name};
			*{"${caller}::${name}"} = \&{"Object::Proto::Sugar::${name}"};
		}
	}

	BEGIN::Lift::install(
		($caller, 'has') => sub {
			my ($name, %params) = @_;
			if (ref $name) {
				for (@{$name}) {
					push @spec, $_, \%params;
				}
			} else {
				push @spec, $name, \%params;
			}
		}
	);

	BEGIN::Lift::install(
		($caller, 'attributes') => sub {
			my @attr = @_;
			while (@attr) {
				my @names = ref $attr[0] eq 'ARRAY' ? @{ shift @attr } : shift @attr;
				my @sp = @{ shift(@attr) };
				splice @sp, $#sp < 1 ? 0 : 1, 0, delete $sp[-1]->{default}
					if ref $sp[-1] eq 'HASH' && exists $sp[-1]->{default};
				unshift @sp, 'ro' unless (!$sp[0] || !ref $sp[0]) && ($sp[0] || "") =~ m/^(ro|rw|set)$/;
				my %params = (is => $sp[0]);
				$params{default} = ref $sp[1] eq 'CODE' ? $sp[1] : sub { Object::Proto::clone($sp[1]) }
					if defined $sp[1];
				%params = (%params, %{ $sp[2] }) if ref $sp[2] eq 'HASH';
				push @spec, $_, \%params for @names;
			}
		}
	);


	BEGIN::Lift::install(
		($caller, 'extends') => sub { push @extends, @_ }
	);

	BEGIN::Lift::install(
		($caller, 'with') => sub { push @with, @_ }
	);

	BEGIN::Lift::install(
		($caller, 'requires') => sub { push @requires, @_ }
	);

	for my $mod_type (qw/before after around/) {
		BEGIN::Lift::install(
			($caller, $mod_type) => sub {
				my ($name, $code) = @_;
				push @modifiers, [$mod_type, $name, $code];
			}
		);
	}

	Devel::Hook->push_UNITCHECK_hook(sub {
		my @spec_copy = @spec;
		my (@func_names, $attr, $spec, %isa, @attributes);
		while (@spec) {
			($attr, $spec) = (shift @spec, shift @spec);
			$attr = _configure_is($attr, $spec);
			$attr = _configure_required($attr, $spec);
			$attr = _configure_lazy($attr, $spec);
			$attr = _configure_isa_and_coerce($attr, $spec, \%isa, $caller);
			$attr = _configure_default_and_builder($attr, $spec, \%isa, $caller);
			$attr = _configure_trigger($attr, $spec, \%isa, $caller);
			$attr = _configure_predicate($attr, $spec, $caller, 'predicate');
			$attr = _configure_clearer($attr, $spec, $caller, 'clearer');
			$attr = _configure_reader_and_writer($attr, $spec, $caller);
			$attr = _configure_init_arg($attr, $spec, $caller);
			$attr = _configure_weak_ref($attr, $spec, $caller);
			push @attributes, $attr;
		}

		my @extends_arg = @extends > 1
			? (extends => \@extends)
			: @extends
				? (extends => $extends[0])
				: ();
		if ($is_role) {
			Object::Proto::role($caller, @attributes);
			Object::Proto::requires($caller, @requires) if @requires;
		} else {
			Object::Proto::define($caller, @extends_arg, @attributes);
		}
		Object::Proto::with($caller, @with) if @with;

		while (@spec_copy) {
			my ($name, $spec) = (shift @spec_copy, shift @spec_copy);
			push @func_names, _install_func_accessors($caller, $name, $spec);
		}

		if (@func_names) {
			no strict 'refs';
			push @{"${caller}::EXPORT_FUNC"}, @func_names;
		}

		{
			no strict 'refs';
			*{"${caller}::import_accessors"} = sub {
				my ($class, @names) = @_;
				my $target = caller();
				# Use C-level installer - creates CVs with call checkers
				# so code compiled after this gets custom ops
				unless (@names) {
					for my $pkg (_mro($class)) {
						Object::Proto::import_accessors($pkg, $target);
					}
				} else {
					for my $name (@names) {
						for my $pkg (_mro($class)) {
							if (defined &{"${pkg}::${name}"}) {
								Object::Proto::import_accessor($pkg, $name, $name, $target);
								last;
							}
						}
					}
				}
			};
		}

		for my $mod (@modifiers) {
			my ($type, $name, $code) = @{$mod};
			my $meth = $name =~ /::/ ? $name : "${caller}::${name}";
			$modifier_dispatch{$type}->($meth, $code);
		}
	});
}

sub _mro {
	my ($class) = @_;
	my (@queue, @order, %seen) = ($class);
	while (my $pkg = shift @queue) {
		next if $seen{$pkg}++;
		push @order, $pkg;
		no strict 'refs';
		push @queue, @{"${pkg}::ISA"};
	}
	return @order;
}

sub _configure_is {
	my ($attr, $spec) = @_;
	if (defined $spec->{is}) {
		if ($spec->{is} eq 'ro') {
			$attr .= ":readonly";
		}
	}
	return $attr;
}


sub _configure_required {
	my ($attr, $spec) = @_;
	if ($spec->{required}) {
		$attr .= ":required";
	}
	return $attr;
}

sub _configure_lazy {
	my ($attr, $spec) = @_;
	if ( $spec->{lazy} ) {
		$attr .= ":lazy";
	}
	return $attr;
}

sub _configure_isa_and_coerce {
	my ($attr, $spec, $isa, $caller) = @_;
	my ($ref, $val1, $val2);
	if (defined $spec->{isa} || defined $spec->{coerce}) {
		$ref = ref $spec->{isa} || "";
		if ($ref eq 'CODE' || defined $spec->{coerce}) {
			$val1 = (exists $spec->{isa} ? $spec->{isa} + 0 : '0000');
			$val2 = (exists $spec->{coerce} ? $spec->{coerce} + 0 : '0000');
			if (!$isa->{$val1 . $val2}++) {
				Object::Proto::register_type('T' . $val1 . $val2,
					$spec->{isa} || sub { 1 },
					$spec->{coerce} || sub { $_[0] }
				);
			}
			$attr .= sprintf(":T%s%s", $val1, $val2);
		} elsif ( !$ref ) {
			$val1 = ucfirst($spec->{isa});
			if ($valid_types{$val1}) {
				$attr .= sprintf(":%s", $val1);
			}
		} else {
			croak "Failed to attach isa for $attr in $caller";
		}
	}

	return $attr;
}

sub _configure_default_and_builder {
	my ($attr, $spec, $isa, $caller) = @_;
	my ($ref1, $ref2, $val1, $cb);
	return $attr unless exists $spec->{default} || exists $spec->{builder};
	$ref1 = ref($spec->{default}) || "";
	if (exists $spec->{builder} || $ref1 eq 'CODE') {
		$ref2 = ref($spec->{builder});
		if (! $ref2 && $ref1 ne 'CODE') {
			if ($spec->{builder} =~ m/^1$/) {
				$attr .= ':builder()';
			} else {
				$attr .= sprintf(":builder(%s)", $spec->{builder});
			}
		} elsif ( $ref2 eq 'CODE' || $ref1 eq 'CODE' ) {
			my $cb = exists $spec->{builder} ? $spec->{builder} : $spec->{default};
			$val1 = 'BUILDER' . ($cb + 0);
			if (!$isa->{$val1}++) {
				no strict 'refs';
				*{"${caller}::${val1}"} = $cb;
			}
			$attr .= sprintf(":builder(%s)", $val1);
		} else {
			croak "Failed to attach builder for $attr in $caller";
		}
	} elsif ( ! $ref1 ) {
		$attr .= sprintf(":default(%s)", defined $spec->{default} ? $spec->{default} : 'undef' );
	} elsif ( $ref1 eq 'ARRAY') {
		$attr .= ":default([])";
	} elsif ( $ref1 eq 'HASH' ) {
		$attr .= ":default({})";
	}
	return $attr;
}

sub _configure_trigger {
	my ($attr, $spec, $isa, $caller) = @_;
	my ($ref, $val1);
	if (exists $spec->{trigger}) {
		$ref = ref $spec->{trigger};
		if ( ! $ref ) {
			$attr .= sprintf(":trigger(%s)", $spec->{trigger});
		} elsif ( $ref eq 'CODE' ) {
			$val1 = 'TRIG' . ($spec->{trigger} + 0);
			if (!$isa->{$val1}++) {
				no strict 'refs';
				*{"${caller}::${val1}"} = $spec->{trigger};
			}
			$attr .= sprintf(":trigger(%s::%s)", $caller, $val1);
		}

	}
	return $attr;
}

sub _configure_predicate {
	my ($attr, $spec, $caller) = @_;
	if (defined $spec->{predicate}) {
		if ($spec->{predicate} =~ 1) {
			$attr .= ":predicate";
		} elsif (! ref $spec->{predicate}) {
			$attr .= sprintf(":predicate(%s)", $spec->{predicate});
		} else {
			croak "Failed to attach predicate for $attr in $caller";
		}
	}
	return $attr;
}

sub _configure_clearer {
	my ($attr, $spec, $caller) = @_;
	if (defined $spec->{clearer}) {
		if ($spec->{clearer} =~ 1) {
			$attr .= ":clearer";
		} elsif (! ref $spec->{clearer}) {
			$attr .= sprintf(":clearer(%s)", $spec->{clearer});
		} else {
			croak "Failed to attach clearer for $attr in $caller";
		}
	}
	return $attr;
}

sub _configure_reader_and_writer {
	my ($attr, $spec, $caller) = @_;
	my ($name) = $attr =~ m/^([^\:]+)/;
	if (exists $spec->{reader}) {
		croak "Failed to attach reader for $attr in $caller" unless ! ref $spec->{reader};
		if ($spec->{reader} =~ m/^1$/) {
			$attr .= sprintf(":reader(get_%s)", $name);
		} else {
			$attr .= sprintf(":reader(%s)", $spec->{reader});
		}
	}
	if (exists $spec->{writer}) {
		croak "Failed to attach writer for $attr in $caller" unless ! ref $spec->{writer};
		if ($spec->{writer} =~ m/^1$/) {
			$attr .= sprintf(":writer(set_%s)", $name);
		} else {
			$attr .= sprintf(":writer(%s)", $spec->{writer});
		}
	}
	return $attr;
}

sub _configure_init_arg {
	my ($attr, $spec) = @_;
	if (defined $spec->{init_arg} || defined $spec->{arg}) {
		$attr .= sprintf(":arg(%s)", $spec->{init_arg} || $spec->{arg});
	}
	return $attr;
}

sub _configure_weak_ref {
	my ($attr, $spec) = @_;
	if ($spec->{weak_ref} || $spec->{weak}) {
		$attr .= ':weak';
	}
	return $attr;
}

sub _install_func_accessors {
	my ($caller, $name, $spec) = @_;
	my @installed;
	if (exists $spec->{accessor}) {
		my $fname = $spec->{accessor} eq '1' ? $name : $spec->{accessor};
		Object::Proto::import_accessor($caller, $name, $fname, $caller);
		push @installed, $fname;
	}
	if (exists $spec->{reader} && !ref $spec->{reader}) {
		my $fname = $spec->{reader} eq '1' ? "get_$name" : $spec->{reader};
		Object::Proto::import_accessor($caller, $name, $fname, $caller);
		push @installed, $fname;
	}
	if (exists $spec->{writer} && !ref $spec->{writer}) {
		my $fname = $spec->{writer} eq '1' ? "set_$name" : $spec->{writer};
		Object::Proto::import_accessor($caller, $name, $fname, $caller);
		push @installed, $fname;
	}
	return @installed;
}

1;

__END__