File Coverage

blib/lib/Class/Monadic.pm

Criterion	Covered	Total	%
statement	143	147	97.2
branch	30	34	88.2
condition	10	14	71.4
subroutine	27	28	96.4
pod	9	9	100.0
total	219	232	94.4

package Class::Monadic;

use 5.008_001;
use strict;
use warnings;

our $VERSION = '0.04';

use Exporter qw(import);
our @EXPORT_OK   = qw(monadic);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

use Carp ();
use Data::Util ();
use Scalar::Util ();
use Hash::FieldHash ();

#use Class::Method::Modifiers::Fast ();

Hash::FieldHash::fieldhash my %Meta;

sub _cannot_initialize{
	Carp::croak 'Cannot initialize a monadic object without object references';
}

sub monadic{
	my($object) = @_;
	ref($object) or _cannot_initialize();

	return $Meta{$object} ||= __PACKAGE__->_new($object);
}

sub initialize{
	my($class, $object) = @_;
	ref($object) or _cannot_initialize();

	return $Meta{$object} ||= $class->_new($object);
}


sub _new{
	my($metaclass, $object) = @_;

	if(Data::Util::is_glob_ref($object)){
		$object = *{$object}{IO};
	}

	my $class = Scalar::Util::blessed($object) or _cannot_initialize();

	$class =~ s/ ::0x[a-f0-9]+ \z//xms; # remove its monadic identity (in cloning)

	my $meta = bless {
		class     => $class,
		id        => sprintf('0x%x', Scalar::Util::refaddr($object)),

		object    => $object,
		isa       => undef,
		sclass    => undef,
		methods   => undef,
		modifiers => undef,
		fields    => undef,
		field_map => undef,
	}, $metaclass;
	Scalar::Util::weaken( $meta->{object} );

	&Internals::SvREADONLY($meta, 1); # lock_keys(%{$meta})

	my $sclass      = $class . '::' . $meta->{id};
	my $sclass_isa  = do{ no strict 'refs'; \@{$sclass . '::ISA'} };

	$meta->{sclass} = $sclass;
	$meta->{isa}    = $sclass_isa;

	my $base = $metaclass . '::Object';
	if($class->can('clone')){
		$base .= '::Clonable';
	}
	@{$sclass_isa} = ($base, $class);

	bless $object, $sclass; # re-bless
	return $meta;
}


sub name{
	my($meta) = @_;

	return $meta->{class};
}

sub id{
	my($meta) = @_;

	return $meta->{id};
}

*add_methods = \&add_method; # alias
sub add_method{
	my $meta = shift;

	Data::Util::install_subroutine($meta->{sclass}, @_); # dies on fail

	push @{$meta->{methods} ||= []}, @_;
	return;
}

*add_fields = \&add_field; # alias
sub add_field{
	my $meta = shift;

	my $fields_ref = Data::Util::mkopt_hash(\@_, 'add_field', [qw(Regexp ARRAY CODE)]);

	my $field_map_ref = $meta->{field_map} ||= {};

	my $fields = $meta->{fields} ||= [];

	while(my($name, $validator) = each %{$fields_ref}){
		my $slot;

		my $validate_sub;

		if($validator){
			if(Data::Util::is_regex_ref $validator){
				$validate_sub = sub{ $_[0] =~ /$validator/ };
			}
			elsif(Data::Util::is_array_ref $validator){
				my %words;
				@words{@{$validator}} = ();
				$validate_sub = sub{ exists $words{ $_[0] } };
			}
			else{ # CODE reference
				$validate_sub = $validator;
			}
		}

		Data::Util::install_subroutine($meta->{sclass},
			"get_$name" => sub{
				if(@_ > 1){
					Carp::croak "Too many arguments for get_$name";
				}
				return $slot;
			},
			"set_$name" => 	sub{
				if(@_ > 2){
					Carp::croak "Cannot set multiple values for set_$name";
				}
				if(defined $validate_sub){
					my $value = $_[1];
					$validate_sub->($value)
						or Carp::croak 'Invalid value ', Data::Util::neat($value), " for set_$name";
					$slot = $value;
				}
				else{
					$slot = $_[1];
				}
				return $_[0];
			},
		);

		$field_map_ref->{$name} = \$slot;
		push @{$fields}, $name => $validate_sub;
	}
	return;
}

sub add_modifier{
	my $meta = shift;

	require Class::Method::Modifiers::Fast;

	Class::Method::Modifiers::Fast::_install_modifier($meta->{sclass}, @_);
	push @{$meta->{modifiers} ||= []}, @_;
	return;
}

sub inject_base{
	my($meta, @components) = @_;

	# NOTE: In 5.10.0, do{unshift @ISA, @classes} may cause 'uninitialized' warnings.

	@{$meta->{isa}} = (
		(grep{ not $meta->{object}->isa($_) } @components),
		@{$meta->{isa}},
	);
	return;
}

sub bless{
	my($meta, $object) = @_;

	my $newmeta = ref($meta)->initialize($object);

	$newmeta->add_methods( @{ $meta->{methods} } )
		if exists $meta->{methods};

	if(exists $meta->{fields}){
		$newmeta->add_fields(@{$meta->{fields}});

		my $src_map_ref = $meta->{field_map};
		my $new_map_ref = $newmeta->{field_map};
		while(my($key, $val_ref) = each %{$src_map_ref}){
			${$new_map_ref->{$key}} = ${$val_ref};
		}
	}

	$newmeta->inject_base(@{$meta->{isa}}[0 .. $#{$meta->{isa}}-2])
		if @{$meta->{isa}} > 2; # other than Monadic::Object and its original class

	return $object;
}

sub DESTROY{
	my($meta) = @_;
	my $original_stash = Data::Util::get_stash($meta->{class});

	my $sclass_stashgv = delete $original_stash->{$meta->{id} . '::'};

	@{$meta->{isa}}    = ();
	%{$sclass_stashgv} = ();

	return;
}

package Class::Monadic::Object;

sub STORABLE_freeze{
	my($object, $cloning) = @_;

	return if $cloning;
	Carp::croak sprintf 'Cannot serialize monadic object (%s)', Data::Util::neat($object);
}

package Class::Monadic::Object::Clonable;
our @ISA = qw(Class::Monadic::Object);

sub clone{
	my($object) = @_;
	my $meta = $Meta{$object};

	my $clone = $meta->{class}->can('clone') or Carp::croak(qq{Cannot find "clone" method for $meta->{class}});
	return $meta->bless( $clone->($object) );
}


1;
__END__