view release on metacpan or  search on metacpan

lib/Object/Proto/Sugar.pm  view on Meta::CPAN

		}
	}

	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, @_ }
	);

	BEGIN::Lift::install(
		($caller, 'accessor_alias') => sub { $accessor_alias = $_[0] }
	);

	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;

		$accessor_aliases{$caller} = $accessor_alias if $accessor_alias;

		my %func_to_attr;
		while (@spec_copy) {
			my ($name, $spec) = (shift @spec_copy, shift @spec_copy);
			my @fnames = _install_func_accessors($caller, $name, $spec, $accessor_alias);
			$func_to_attr{$_} = $name for @fnames;
			push @func_names, @fnames;
		}

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

		{
			no strict 'refs';
			no warnings 'redefine';
			*{"${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)) {
						my $alias = $accessor_aliases{$pkg} || '';
						Object::Proto::import_accessors($pkg, ($alias ? "${alias}_" : ""), $target);
					}
				} else {