view release on metacpan or  search on metacpan

lib/Basset/Object.pm  view on Meta::CPAN

This creates method called 'foo' which talks to a separate accessor, in this case the closure returned by "accessor_creator" instead of a closure
returned by _isa_accessor. This is useful if you want to create a validating method on your attribute.

Additionally, it creates a normal method going to _isa_accessor called '__b_foo', which is assumed to be the internal attribute
slot your other accessor with use. In general, for a given "attribute", "__b_attribute" will be created for internal use. Also please
note that you shouldn't ever create a method that starts with '__b_' (double underscore) since Basset reserves the right to automatically
create methods named in that fashion. You've been warned.

"other_accessor" will get the object as the first arg (as always) and the name of the internal method as the second.

A sample accessor_creator could look like this:

 Some::Class->add_attr(['foo', 'accessor_creator']);

 sub accessor_creator {
 	my $self = shift;
 	my $attribute = shift;	#the external method name
 	my $prop = shift;		#the internal "slot" that is a normal attribute

 	#now we make our closure:
 	return sub {
 		my $self = shift;
 		if (@_) {
 			my $val = shift;
 			if ($val == 7) {
 				return $self->$prop($val);
 			}
 			else {
 				return $self->error("Cannot store value...must be 7!", "not_7");
 			}
 		}
 		else {
 			return $self->$prop();
 		}
 	}
 }

And, finally, you can also pass in additional arguments as static args if desired.

 Some::Class->add_attr(['foo', 'accessor_creator'], 'bar');

 $obj->foo('bee');

 sub accessor_creator {
 	my $self	= shift;
 	my $method	= shift;
 	my $static 	= shift;	#'bar' in our example

	return sub {
		#do something with static argument
		.
		.
	}
 };

All easy enough. Refer to any subclasses of this class for further examples.

Basset::Object includes two other alternate accessors for you - regex and private.

 Some::Class->add_attr(['user_id', '_isa_regex_accessor', qr{^\d+$}, "Error - user_id must be a number", "NaN"]);

The arguments to it are, respectively, the name of the attribute, the internal accessor used, the regex used to validate, the error message to return, and the error code to return.
If you try to mutate with a value that doesn't match the regex, it'll fail.

 Some::Class->add_attr(['secret', '_isa_private_accessor']);

private accessors add a slight degree of security. All they do is simply restrict access to the attribute unless you are within the class of the object. Note, that this causes
access to automatically trickle down into subclasses.

=cut

sub add_attr {
	my $pkg			= shift;

	no strict 'refs';

	foreach my $record (@_) {
		my ($attribute, $adding_method, $internal_attribute, @args);
		if (ref $record eq 'ARRAY') {
			($attribute, $adding_method, @args) = @$record;
			$internal_attribute = $pkg->privatize($attribute);
			*{$pkg . "::$internal_attribute"}	= $pkg->_isa_accessor($internal_attribute, $attribute)
				unless *{$pkg . "::$internal_attribute"}{'CODE'};
			*{$pkg . "::$attribute"}			= $pkg->$adding_method($attribute, $internal_attribute, @args)
				unless *{$pkg . "::$attribute"}{'CODE'};
		}
		else {
			$attribute = $record;
			*{$pkg . "::$record"} = $pkg->_isa_accessor($record) unless *{$pkg . "::$record"}{'CODE'};
		}

		$pkg->_instance_attributes->{$attribute}++;

	}

	return 1;

}

sub _isa_accessor {
	my $pkg			= shift;
	my $attribute	= shift;
	my $prop		= shift || $attribute;

	return sub {
		my $self = shift;

		return $self->error("Not a class attribute", "BO-08") unless ref $self;

		$self->{$prop} = shift if @_;

		$self->{$prop};
	};
}

# _accessor is the main accessor method used in the system. It defines the most simple behavior as to how objects are supposed
# to work. If it's called with no arguments, it returns the value of that attribute. If it's called with arguments,
# it sets the object attribute value to the FIRST argument passed and ignores the rest
#
# example: