view release on metacpan or  search on metacpan

lib/YAOO.pm  view on Meta::CPAN

package YAOO;
use strict; no strict 'refs';
use warnings;
use Carp qw/croak/; use Tie::IxHash;
use feature qw/state/;
use Blessed::Merge;
use Hash::Typed;
our $VERSION = '0.10';

our (%TYPES, %object, $LAST);

sub make_keyword {
	my ($called, $key, $cb) = @_;
	*{"${called}::$key"} = $cb;
	$LAST = 10000000000000000000;
}

sub import {
	my ($package, @attributes) = @_;

	my $called = caller();

	strict->import();
	warnings->import();

	for my $is (qw/ro rw/) {
		make_keyword($called, $is, sub { is => $is });
	}

	for my $key (qw/isa default coerce required trigger lazy delay build_order/) {
		make_keyword($called, $key, sub {
			my (@value) = @_;
			return $key => scalar @value > 1 ? @value : ($value[0] || 1);
		});
	}

	for my $isa ( qw/any string scalarref integer float boolean ordered_hash hash array object fh/ ) {
		make_keyword($called, $isa, sub {
			my (@args) = @_;
			my @return = (
				\&{"${package}::${isa}"},
				type => $isa,
				build_default => \&{"${package}::build_${isa}"}
			);
			push @return, (default => ($isa eq 'ordered_hash' ? sub { deep_clone_ordered_hash(@args) } : sub { deep_clone( scalar @args > 1 ? $isa eq 'hash' ? {@args} : \@args : @args) }))
				if (scalar @args);
			@return;
		});
	}

	make_keyword($called, 'typed_hash', sub {
		my (@args) = @_;
		my $spec = shift @args;
		if (! scalar $spec) {
			die 'Invalid declaration of a typed_hash no Hash::Typed spec passed'
		}
		if (caller(1)) {
			return Hash::Typed->new(
				deep_clone($spec),
				%{ deep_clone_ordered_hash(@args) }
			);
		}
		my @return = (
			\&{"${package}::typed_hash"},
			type => 'typed_hash',
		);
		push @return, default => sub {
			Hash::Typed->new(
				deep_clone($spec), 
				%{ deep_clone_ordered_hash(@args) }
			);
		};
		@return 
	});


	make_keyword($called, 'auto_build', sub { $object{$called}{auto_build} = 1; });

	make_keyword($called, 'extends', sub {
		my (@args) = @_;
		my $extend = caller();
  		for my $inherit (@args) {
			load($inherit);