looks results from the CPAN

looks

Basset

view release on metacpan or search on metacpan

package Basset::Object;

#Basset::Object Copyright and (c) 1999, 2000, 2002-2006 James A Thomason III
#Basset::Object is distributed under the terms of the Perl Artistic License.

=pod

=head1 NAME

Basset::Object - used to create objects

=head1 AUTHOR

Jim Thomason, jim@jimandkoka.com

=head1 DESCRIPTION

This is my ultimate object creation toolset to date. It has roots in Mail::Bulkmail, Text::Flowchart, and the
unreleased abstract object constructors that I've tooled around with in the past.

If you want an object to be compatible with anything else I've written, then subclass it off of here.

Of course, you don't have to use this to create subclasses, but you'll run the risk of making something with an inconsistent
interface vs. the rest of the system. That'll confuse people and make them unhappy. So I recommend subclassing off of here
to be consistent. Of course, you may not like these objects, but they do work well and are consistent. Consistency is
very important in interface design, IMHO.

Please read the tutorials at L<http://www.bassetsoftware.com/perl/basset/tutorial/>.

=cut

$VERSION = '1.03';

sub _conf_class {return 'Basset::Object::Conf'};
BEGIN {eval 'use ' . _conf_class()};

use Data::Dumper ();
use Carp;

use Basset::Container::Hash;

use strict;
use warnings;

=pod

=head1 METHODS

=over

=item add_attr

add_attr adds object attributes to the class.

Okay, now we're going to get into some philosophy. First of all, let me state that I *love* Perl's OO implementation.
I usually get smacked upside the head when I say that, but I find it really easy to use, work with, manipulate, and so
on. And there are things that you can do in Perl's OO that you can't in Java or C++ or the like. Perl, for example, can
have *totally* private values that are completely inaccessible (lexicals, natch). private vars in the other languages
can be redefined or tweaked or subclassed or otherwise gotten around in some form. Not Perl.

And I obviously just adore Perl anyway. I get funny looks when I tell people that I like perl so much because it works
the way I think. That bothers people for some reason.

Anyway, as much as I like how it works, I don't like the fact that there's no consistent object type. An object is,
of course, a blessed ((thingie)) (scalar, array, code, hash, etc) reference. And there are merits to using any of those
things, depending upon the situation. Hashes are easy to work with and most similar to traditional objects.

 $object->{$attribute} = $value;

And whatnot. Arrays are much faster (typically 33% in tests I've done), but they suck to work with.

 $object->[15] = $value;	#the hell is '15'?

 (
  by the way, you can make this easier with variables defined to return the value, i.e.
  $object->[$attribute] = $value;	#assuming $attribute == 15
 )

Scalars are speciality and coderefs are left to the magicians. Don't get me wrong, coderefs as objects are nifty, but
they can be tricky to work with.

So, I wanted a consistent interface. I'm not going to claim credit for this idea, since I think I originally read it
in Object Oriented Programming in Perl (Damien's book). In fact, I think the error reporting method I use was also
originally detailed in there. Anyway, I liked it a lot and decided I'd implement my own version of it. Besides, it's
not like I'm the first guy to say that all attributes should be hidden behind mutators and accessors.

Basically, attributes are accessed and mutated via methods.

 $object->attribute($value);

For all attributes. This way, the internal object can be whatever you'd like. I used to use mainly arrays for the speed
boost, but lately I use hashes a lot because of the ease of dumping and reading the structure for debugging purposes.
But, with this consistent interface of using methods to wrapper the attributes, I can change the implementation of
the object (scalar, array, hash, code, whatever) up in this module and *nothing* else needs to change.

Say you implemented a giant system in OO perl. And you chose hashrefs as your "object". But then you needed a big
speed boost later, which you could easily get by going to arrays. You'd have to go through your code and change all
instances of $object->{$attribute} to $object->[15] or whatever. That's an awful lot of work.

With everything wrappered up this way, changes can be made in the super object class and then automagically populate
out everywhere with no code changes. 

Enough with the philosophy, though. You need to know how this works.

It's easy enough:

 package Some::Class;

 Some::Class->add_attr('foo');

Now your Some::Class objects have a foo attribute, which can be accessed as above. If called with a value, it's the mutator
which sets the attribute to the new value and returns the new value. If called without one, it's the accessor which
returns the value.

 my $obj = Some::Class->new();
 $obj->foo('bar');
 print $obj->foo();			#prints bar
 print $obj->foo('boo');	#prints boo
 print $obj->foo();			#prints boo
 print $obj->foo('bang');	#prints bang
 print $obj->foo;			#prings bang

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

	return $class;
}

=pod

=item nonrestricted_parent

Called on a class, returns the first non-restricted parent of that class

=cut

=pod

=begin btest(nonrestricted_parent)

package Basset::Test::Testing::__PACKAGE__::nonrestricted_parent::Subclass1;
our @ISA = qw(__PACKAGE__);

package __PACKAGE__;

$test->is(__PACKAGE__->nonrestricted_parent, "__PACKAGE__", "__PACKAGE__ own nonrestricted parent");
$test->is(Basset::Test::Testing::__PACKAGE__::nonrestricted_parent::Subclass1->nonrestricted_parent, "Basset::Test::Testing::__PACKAGE__::nonrestricted_parent::Subclass1", "Subclass own nonrestricted parent");

my $subclass = Basset::Test::Testing::__PACKAGE__::nonrestricted_parent::Subclass1->inline_class;
$test->ok($subclass, "Got restricted class");
$test->is($subclass->nonrestricted_parent, "Basset::Test::Testing::__PACKAGE__::nonrestricted_parent::Subclass1", "Restricted class has proper non restricted parent");

my $subclass2 = $subclass->inline_class;
$test->ok($subclass2, "Got restricted class of restricted class");
$test->is($subclass2->nonrestricted_parent, "Basset::Test::Testing::__PACKAGE__::nonrestricted_parent::Subclass1", "Restricted class has proper non restricted parent");

my $subclass3 = __PACKAGE__->inline_class;
$test->ok($subclass3, "Got restricted class");
$test->is($subclass3->nonrestricted_parent, "__PACKAGE__", "Restricted class has proper non restricted parent");

=end btest(nonrestricted_parent)

=cut

sub nonrestricted_parent {
	my $self = shift;

	my $parents = $self->isa_path;

	#remember the isa path is most distant -> closest. Here we want to look at the closest
	#ancestor that is not restricted.
	#
	#We march up the tree. Once we find a parent (or ourselves) that can perform the method
	#we're looking for, we stop and are happy.
	foreach my $parent (reverse @$parents) {
		return $parent unless $parent->restricted();
	};

	return $self->error("class ($self) has no non-restricted parents", "BO-18");
}

=pod

=item dump

->dump dumps out the object (using Data::Dumper internally), this is useful to show you what an object looks like.

 print $obj->dump

Alternatively, you can hand in something to dump.

 print $obj->dump($something_else);

=cut

=pod

=begin btest(dump)

my $o = __PACKAGE__->new();
$test->ok($o, "Created object");
my $o2 = __PACKAGE__->new();
$test->ok($o2, "Created object");

$test->ok($o->dump, "Dumped object");
$test->ok($o->dump(['a']), "Dumped array");
$test->ok($o->dump({'k' => 'v'}), "Dumped hash");
$test->ok($o2->dump, "Dumped other object");
$test->is($o->dump($o2), $o2->dump, "Dumps equal");
$test->is($o->dump, $o2->dump($o), "Dumps equal");

=end btest(dump)

=cut

sub dump {
	my $self = shift;

	return Data::Dumper::Dumper(@_ ? shift : $self);
};

=pod

=item new

Finally! The B<constructor>. It's very easy, for a minimalist object, do this:

 my $obj = Class->new() || die Class->error();

Ta da! You have an object. Any attributes specified in the conf file will be loaded into your object. So if your
conf file defines 'foo' as 'bar', then $obj->foo will now equal 'bar'.

If you'd like, you can also pass in method/value pairs to the constructor.

 my $obj = Class->new(
 	'attribute' => '17',
 	'foo'		=> 'baz',
 	'method'	=> '88'
 ) || die Class->error();

This is (roughly) the same as:

 my $obj = Class->new() || die Class->error();

 $obj->attribute(17) || die $obj->error();
 $obj->foo('baz') || die $obj->error();

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

$test->ok($o2, "got object");

$test->ok(! $o2->cast, "Cannot cast w/o class");
$test->is($o2->errcode, "BO-22", "proper error code");
my $c2 = $o2->cast($subclass, 'copy');
$test->ok($c2, "casted object");
$test->is($o2->pkg, "__PACKAGE__", "original part of super package");
$test->is($c2->pkg, $subclass, "casted object part of sub package");
$test->is($c2->errcode, $o->errcode, "error codes match, rest is assumed");

=end btest(cast)

=cut

#used for introspection.
__PACKAGE__->add_trickle_class_attr('_class_attributes', {});
__PACKAGE__->add_trickle_class_attr('_instance_attributes', {});

# _obj_error is the object attribute slot for storing the most recent error that occurred. It is
# set via the first argument to the ->error method when called with an object.
# i.e., $obj->error('foo', 'bar');	#_obj_error is 'foo'
__PACKAGE__->add_attr('_obj_error');

# _obj_errcode is the object attribute slot for storing the most recent error code that occurred. It is
# set via the second argument to the ->error method when called with an object.
# i.e., $obj->error('foo', 'bar');	#_obj_errcode is 'bar'
__PACKAGE__->add_attr('_obj_errcode');

# _pkg_error is the class attribute slot for storing the most recent error that occurred. It is
# set via the first argument to the ->error method when called with a class.
# i.e., $class->error('foo', 'bar');	#_pkg_error is 'foo'
__PACKAGE__->add_trickle_class_attr('_pkg_error');

# _pkg_errcode is the class attribute slot for storing the most recent error code that occurred. It is
# set via the second argument to the ->error method when called with a class.
# i.e., $class->error('foo', 'bar');	#_pkg_errcode is 'bar'
__PACKAGE__->add_trickle_class_attr('_pkg_errcode');

=pod

=back

=head1 ATTRIBUTES

=over

=item errortranslator

The errortranslator needs to be set to a hashref, and it translates programmer 
readable errors into user readable errors. It's clunky and a mess and a hack, but it works.

 __PACKAGE__->errortranslator(
	{
		'violation of key constraint foo: Cannot INSERT' => 'Please specify a value for foo'
	}
 );

 $obj->do_something || die $obj->error(); 	# dies 'violation of key constraint foo: Cannot INSERT'
 $obj->do_something || die $obj->usererror();# dies 'Please specify a value for foo'

The error translator looks at the error values, and if a more friendly user error exists, it returns that one instead.
errortranslator looks at and returns (in order):

 the actual error,
 the raw error, 
 the error code, 
 a '*' wildcard, 
 and then just returns the original error w/o modification.

Be careful using the '*' wildcard. This will translate -any- error message that doesn't have a friendlier version.

=cut

=pod

=begin btest(errortranslator)

my $uses_real = __PACKAGE__->use_real_errors();
$test->is(__PACKAGE__->use_real_errors(0), 0, "Uses real errors");

my $translator = {
	'test error' => 'test message'
};

$test->ok($translator, "Created translator");
$test->is(__PACKAGE__->errortranslator($translator), $translator, "Set translator");
$test->is(scalar __PACKAGE__->error('test error', 'test code'), undef, "Set error");
$test->is(__PACKAGE__->usererror(), 'test message', 'Re-wrote error message');

$test->is(__PACKAGE__->errortranslator($uses_real), $uses_real, 'Class reset uses real error');

=end btest(errortranslator)

=cut

# The error translator turns system defined error messages into user readable error messages.
# It's clunky, but it's the best we've got for now.
__PACKAGE__->add_trickle_class_attr('errortranslator');

=pod

=item use_real_errors

use_real_errors bypasses the errortranslator and only returns the errstring. This is useful so that your developers can get
back useful information, but your users can get back a friendly message.

=cut

=begin btest(use_real_errors)

my $translator = __PACKAGE__->errortranslator();
$test->ok(__PACKAGE__->errortranslator(
	{
		'test code' => "friendly test message",
		'formatted test error %d' => "friendlier test message",
		'formatted test error 7' => 'friendliest test message',
		'extra error' => 'friendliest test message 2'
	}),
	'Class set error translator'
);

my $uses_real = __PACKAGE__->use_real_errors();

( run in 0.485 second using v1.01-cache-2.11-cpan-ff9377addf4 )