From: <mjd...@us...> - 2009-11-24 03:33:12
|
Revision: 301 http://treebase.svn.sourceforge.net/treebase/?rev=301&view=rev Author: mjdominus Date: 2009-11-24 03:33:05 +0000 (Tue, 24 Nov 2009) Log Message: ----------- New tests for subobject features. Restore ucfirst(lc(...)) code removed by RAV; it is actually correct. Document behavior of ->subobject_class method. Modified Paths: -------------- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm trunk/treebase-core/src/main/perl/t/10_internal.t trunk/treebase-core/src/main/perl/t/20_study.t Added Paths: ----------- trunk/treebase-core/src/main/perl/t/21_subobject.t Modified: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm =================================================================== --- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm 2009-11-24 02:47:19 UTC (rev 300) +++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm 2009-11-24 03:33:05 UTC (rev 301) @@ -107,6 +107,10 @@ =cut # Maybe add some caching here at some point +# +# This should dispatch off to ->get because the code in the +# two places is almost the same and we've already had one bug +# occur when they didn't stay in sync. mjd 20091123 sub AUTOLOAD { my $obj = shift; our $AUTOLOAD; @@ -541,17 +545,36 @@ =item subobject_class() -Returns the class name for the supplied subobject name. This is either a value in the invocant -class's %subobject hash (see TreeBaseObjects), an alias as returned by the alias() method or -the supplied subobject's name itself. +Returns the class name for the supplied attribute name. The default is the name of the attribute, +lowercase with initial capital. This may be overridden by an entry in the C<%subobject> hash in the +invocant's class. For example, suppose there are C<Dessert> objects and C<Flavor> objects. Suppose +each C<Dessert> has a C<flavor> and an C<alternate_flavor> attribute, which are C<Flavor> objects. +One could represent this by defining: + %Dessert::subobject = (flavor => 'Flavor', + alternate_flavor => 'Flavor', + ); + +which says that whenever a C<Dessert> object's C<flavor> or C<alternate_flavor> attributes are +accessed, C<VeryBadORM> should instantiate them as C<Flavor> objects. + +But one could omit the first entry from the hash: + + %Dessert::subobject = (alternate_flavor => 'Flavor'); + +since the class for the C<flavor> attribute will be inferred to be C<Flavor> by default. + +One may, of course, override this method to implement any mapping of attribute to class names that +is desired. + + =cut sub subobject_class { my ($self, $subobj) = @_; my $subobj_class = \%{$self->class . "::subobject"}; return $subobj_class->{$subobj} if exists $subobj_class->{$subobj}; - return $self->alias($subobj) || $subobj;#ucfirst(lc($subobj)); # XXX really? + return $self->alias($subobj) || ucfirst(lc($subobj)); } =item get_id_pair() Modified: trunk/treebase-core/src/main/perl/t/10_internal.t =================================================================== --- trunk/treebase-core/src/main/perl/t/10_internal.t 2009-11-24 02:47:19 UTC (rev 300) +++ trunk/treebase-core/src/main/perl/t/10_internal.t 2009-11-24 03:33:05 UTC (rev 301) @@ -1,5 +1,6 @@ # To test: attr_list # attr_hash +# subobject_class -use Test::More 'skip_all' => 'none yet'; \ No newline at end of file +use Test::More 'skip_all' => 'none yet'; Modified: trunk/treebase-core/src/main/perl/t/20_study.t =================================================================== --- trunk/treebase-core/src/main/perl/t/20_study.t 2009-11-24 02:47:19 UTC (rev 300) +++ trunk/treebase-core/src/main/perl/t/20_study.t 2009-11-24 03:33:05 UTC (rev 301) @@ -1,6 +1,5 @@ -use Test::More tests => 5; +use Test::More tests => 7; -use lib '../blib/lib'; use_ok('CIPRES::TreeBase::TestObjects'); use DBI; my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n"); @@ -11,3 +10,6 @@ ok(my $s8 = Study->new(8)); is($s8->owner, 'Otto'); + +is(Tree->new(120)->name, "tree cxx"); +is(Matrix->new(25)->n_rows, 26); \ No newline at end of file Added: trunk/treebase-core/src/main/perl/t/21_subobject.t =================================================================== --- trunk/treebase-core/src/main/perl/t/21_subobject.t (rev 0) +++ trunk/treebase-core/src/main/perl/t/21_subobject.t 2009-11-24 03:33:05 UTC (rev 301) @@ -0,0 +1,9 @@ +use Test::More tests => 3; + +use_ok('CIPRES::TreeBase::TestObjects'); +use DBI; +my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n"); +CIPRES::TreeBase::VeryBadORM->set_db_connection($dbh); + +is(Study->new(4)->Tree->name, "tree xxiv"); +is(Study->new(4)->tree->name, "tree xxiv"); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |