view release on metacpan or  search on metacpan

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

	$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;
	my $allowed = $v->{valid};
	return defined $allowed
	 ? ref $allowed eq 'CODE'
	 ? $allowed : sub { $_[0] eq $allowed }
	 : undef;
}

=head2 _attrib_info

Returns attribute information for a given package's attribute.

=cut

sub _attrib_info {
	my $class = shift;
	my $attr = shift;
	# return unless ref $self;
	return $classInfo{ref $class || $class}->{$attr};
}

=head2 has_defaults

Returns any defaults defined for this class.

=cut

sub has_defaults {
	my $class = shift;
	return @{ $CLASS_DEFAULTS{$class} // [] };
}

=head2 add_watcher

Add watchers as required for all package definitions.

Call this after all the class definitions have been loaded.

=cut

sub add_watcher {
	my $class = shift;
	my ($pkg, $obj, $target, $attrDef, $meth) = @_;

# The watcher is called with the new value as add|drop => $v
	my $sub = sub {
		my $self = shift;
		my ($action, $v) = @_;