view release on metacpan or  search on metacpan

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

		my $v = delete $info->{_vcs};
		$class->vcs($pkg, $v);
	}
}

=head2 apply_attributes

=cut

sub apply_attributes {
	my ($class, $pkg, $info) = @_;
	my %methodList;
	my @attribs = grep { !/^_/ } keys %$info;

# Smart match support - 1 to use a default refaddr-based system, coderef for anything else
	if(my $match = delete $info->{'~~'}) {
		$class->add_method($pkg, '()', sub () { });
		if(ref $match) {
			$class->add_method($pkg, '(~~', $match);
		} else {
			$class->add_method($pkg, '(~~', sub {
				my ($self, $target) = @_;
				return 0 unless defined($self) && defined($target);
				return 0 unless ref($self) && ref($target);
				return 0 unless $self->isa($pkg);
				return 0 unless $target->isa($pkg);
				return 0 unless refaddr($self) == refaddr($target);
				return 1;
			});
		}

		# Update overload cache if we previously invalidated (for smartmatch or other operators),
		# possibly required if calling L<apply_attributes> at runtime.
		bless {}, $pkg;
	}

# Anything else is an accessor, set it up
	foreach my $attr (@attribs) {
		my $type = $info->{$attr}->{type};
		if($type eq 'array') {
			%methodList = (%methodList, EntityModel::Class::Accessor::Array->add_to_class($pkg, $attr => $info->{$attr}))
		} elsif($type eq 'hash') {
			%methodList = (%methodList, EntityModel::Class::Accessor::Hash->add_to_class($pkg, $attr => $info->{$attr}))
		} else {
			%methodList = (%methodList, EntityModel::Class::Accessor->add_to_class($pkg, $attr => $info->{$attr}))
		}
	}

	$CLASS_DEFAULTS{$pkg} = [ grep { exists $info->{$_}->{default} } @attribs ];

# Apply watchers after we've defined the fields - each watcher is field => method
	foreach my $watcher (grep { exists $info->{$_}->{watch} } @attribs) {
		my $w = $info->{$watcher}->{watch};
		foreach my $watched (keys %$w) {
			$class->add_watcher($pkg, $watcher, $watched, $info->{$watched}, $w->{$watched});
		}
	}

# Thanks to Check::UnitCheck
	Check::UnitCheck::unitcheckify(sub {
		# FIXME Can't call any log functions within UNITCHECK
		local $::DISABLE_LOG = 1;
		my %ml = %methodList;
		$class->add_method($pkg, $_, $ml{$_}) foreach keys %ml;
		$class->add_method($pkg, 'import', sub { }) unless $pkg->can('import');
	}) if %methodList;
}

=head2 add_method

=cut

sub add_method {
	my $class = shift;
	my ($pkg, $name, $method) = @_;
	my $sym = $pkg . '::' . $name;
	logDebug("Add method $sym");
	{ no strict 'refs'; *$sym = $method unless *$sym{CODE}; }
	return $sym;
}

=head2 vcs

Add a version control system tag to the class.

=cut

sub vcs {
	my $class = shift;
	my $pkg = shift;
	my $v = shift;

	# Define with empty prototype, which should mean we compile to a constant
	my $versionSub = sub () { $v };
	my $sym = $pkg . '::VCS_INFO';
	{ no strict 'refs'; *$sym = $versionSub unless *$sym{CODE}; }
}

=head2 setup

Standard module setup - enable strict and warnings, and disable 'import' fallthrough.

=cut

sub setup {
	my ($class, $pkg) = @_;

	strict->import;
	warnings->import();
	feature->import(':5.10');
}


=head2 validator

Basic validation function.

=cut

sub validator {
	my $v = shift;