[Treebase-guts] SF.net SVN: treebase:[308] trunk/treebase-core/src/main/perl

[<mjd...@us...>]

Revision: 308
          http://treebase.svn.sourceforge.net/treebase/?rev=308&view=rev
Author:   mjdominus
Date:     2009-11-24 04:34:45 +0000 (Tue, 24 Nov 2009)

Log Message:
-----------
Started tests for reverse attributes.
For example, Tree has a reverse attribute of 'nodes'
which is generated by looking at the tree_id field
of the TreeNode class.

Bug fix: when the code neds to find the Foos that belong to Bar,
it used the name of Bar's primary key, rather than
the name of Foo's foreign key for Bar.

Modified Paths:
--------------
    trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
    trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm

Added Paths:
-----------
    trunk/treebase-core/src/main/perl/t/22_reverse.t

Modified: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
===================================================================
--- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm	2009-11-24 04:01:45 UTC (rev 307)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm	2009-11-24 04:34:45 UTC (rev 308)
@@ -10,6 +10,7 @@
 CIPRES::TreeBase::VeryBadORM->register();
 
 %subobject = (root_node => 'TreeNode');
+%r_attr = (nodes => 'TreeNode');
 
 sub table { "TREE" }
 sub id_attr { "TreeId" }

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 04:01:45 UTC (rev 307)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm	2009-11-24 04:34:45 UTC (rev 308)
@@ -124,8 +124,8 @@
     } elsif ($package->has_r2_attr($method)) {
 		return $obj->get_r2_subobject_no_check($method, @_);
     } else {
-		my $trace = Devel::StackTrace->new;
-		print $trace->as_string; # like carp
+#		my $trace = Devel::StackTrace->new;
+#		print $trace->as_string; # like carp
 		croak("Unknown attribute '$method' in class '$package'");
     }
 }
@@ -195,7 +195,7 @@
 
 sub foreign_key {
     my $base = shift;
-    my $subobj = lc(shift); # XXX
+    my $subobj = lc(shift());
     return $subobj . "_id"; 
 }
 
@@ -386,11 +386,10 @@
 # and return a list of analysis objects
 sub get_r_subobject_no_check {
     my ($self, $attr) = @_;
-    $attr = $attr;
     my $target_class = $self->r_class($attr);
     my $target_table = $target_class->table;
     my $field = $target_class->id_attr;
-    my $id_field = $self->id_attr;
+    my $id_field = $target_class->foreign_key($self->class); 
     my $q = "select $field from $target_table where $id_field = ?";
     my $sth = $DBH->prepare_cached($q);
     $sth->execute($self->id);

Added: trunk/treebase-core/src/main/perl/t/22_reverse.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/22_reverse.t	                        (rev 0)
+++ trunk/treebase-core/src/main/perl/t/22_reverse.t	2009-11-24 04:34:45 UTC (rev 308)
@@ -0,0 +1,28 @@
+use Test::More tests => 3;
+
+use lib '../lib';
+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);
+
+my %x_names = map {$_ => 1} ('R' .. 'W');
+
+my @nodes_5040 = Tree->new(5040)->nodes;
+is (scalar(@nodes_5040), 6);
+{ my $RESULT = "";
+  for my $node (@nodes_5040) {
+    if ($node->tree_id != 5040) {
+      my $nid = $node->id;  my $tid = $node->tree_id;
+      $RESULT = "Node $nid has treeid = $tid; s/b 5040";
+      last;
+    }
+    delete $x_names{$node->data};
+  }
+  if (%x_names) {
+    my $missing = each %x_names;
+    $RESULT = "Where is node '$missing'?";
+  }
+  ok($RESULT eq "", $RESULT || "Tested nodes of tree 5040");
+}
+


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.