File Coverage

blib/lib/Object/Properties.pm

Criterion	Covered	Total	%
statement	86	86	100.0
branch	17	18	94.4
condition	3	3	100.0
subroutine	21	21	100.0
pod			n/a
total	127	128	99.2

use 5.006;    # for us
use 5.008008; # for Sentinel
use strict;
use warnings;

package Object::Properties;
$Object::Properties::VERSION = '1.002';
# ABSTRACT: minimal-ceremony class builder

use Sentinel ();

sub _make_init {
	my @field  = @{ $_[0] };
	my @setter = @{ $_[1] };
	return sub {
		my $self = shift;
		my ( $hash ) = @_;
		my ( @v, @s );
		for my $i ( 0 .. $#field ) {
			next unless exists $hash->{ $field[ $i ] };
			push @s, $setter[ $i ];
			push @v, delete $hash->{ $field[ $i ] };
		}
		delete @$self{ @field } if $hash != $self;
		for my $i ( 0 .. $#v ) { $self->$_( $v[$i] ) for $s[$i] }
	};
}

sub _make_getter {
	my ( $prop ) = @_;
	return sub { $_[0]{ $prop } };
}

sub _make_getter_setter {
	my ( $prop ) = @_;
	return sub : lvalue { $_[0]{ $prop } };
}

sub _make_setter {
	my ( $prop, $munger ) = @_;
	return sub {
		local $Carp::Internal{ (__PACKAGE__) } = 1;
		$_[0]{ $prop } = $_, return for &$munger;
	};
}

sub _make_accessor {
	my ( $getter, $setter ) = @_;
	return sub : lvalue { Sentinel::sentinel get => $getter, set => $setter, obj => $_[0] };
}

sub import {
	my $class = shift;
	my $pkg = caller;

	my ( @prop, %ro, %setter );
	for ( @_ ) {
		if ( @prop and 'CODE' eq ref ) {
			$setter{ $prop[-1] } = _make_setter $prop[-1], $_;
			next;
		}
		die "Invalid accessor name '$_'" unless /\A([+]?)([^\W\d]\w*)\z/;
		$ro{ $2 } = 1 unless $1;
		push @prop, $2;
	}

	for my $prop ( @prop ) {
		my $getter = _make_getter $prop;
		my $setter = $setter{ $prop };
		my $accessor
			= $ro{ $prop } ? $getter
			: $setter      ? _make_accessor $getter, $setter
			: _make_getter_setter $prop;
		{ no strict 'refs'; *{ $pkg.'::'.$prop } = $accessor }
	}

	if ( my @sprop = grep { exists $setter{ $_ } } @prop ) {
		my $init = _make_init \@sprop, [ @setter{ @sprop } ];
		{ no strict 'refs'; *{ $pkg.'::PROPINIT' } = $init }
	}

	my $ISA = do { no strict 'refs'; \@{ $pkg.'::ISA' } };
	@$ISA = __PACKAGE__ . '::Base' unless @$ISA;

	return 1;
}

package Object::Properties::Base;
$Object::Properties::Base::VERSION = '1.002';
use NEXT ();

sub new {
	my $class = shift;
	my $self = bless { @_ }, $class;
	local $Carp::Internal{ (__PACKAGE__) } = 1;
	$self->EVERY::LAST::PROPINIT( $self );
	return $self;
}

1;

__END__