view release on metacpan or  search on metacpan

lib/Class/Monadic.pm  view on Meta::CPAN

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/ };