[Treebase-guts] SF.net SVN: treebase:[295] trunk/treebase-core/src/main/perl/lib/CIPRES/ TreeBase/VeryBadORM.pm

[<rv...@us...>]

Revision: 295
          http://treebase.svn.sourceforge.net/treebase/?rev=295&view=rev
Author:   rvos
Date:     2009-11-23 17:13:57 +0000 (Mon, 23 Nov 2009)

Log Message:
-----------
Added POD to VeryBadORM.pm

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

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-23 14:59:51 UTC (rev 294)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm	2009-11-23 17:13:57 UTC (rev 295)
@@ -1,4 +1,3 @@
-
 package CIPRES::TreeBase::VeryBadORM;
 use Carp 'croak';
 use strict 'vars';
@@ -7,14 +6,75 @@
 our %dbh;
 our $DBH;
 
+=head1 NAME
+
+CIPRES::TreeBase::VeryBadORM
+
+=head1 DESCRIPTION
+
+Superclass for TreeBASE objects. This class is subclassed by packages in TreeBaseObjects.
+
+=head1 PACKAGE VARIABLES
+
+=over
+
+=item %dbh
+
+This hash holds cached (in theory different) database handles keyed on class names.
+
+=item $DBH
+
+Holds a singleton database handle
+
+=back
+
+=head1 PACKAGE METHODS
+
+=over
+
+=item set_db_connection()
+
+Sets the database handle for the invoking child class. Called as a package method.
+
+=cut
+
 sub set_db_connection { my $class = shift;  $DBH = $dbh{$class} = shift; }
+
+=item get_db_connection()
+
+Gets the database handle for the invoking child class. Called as a package method.
+
+=cut
+
 sub get_db_connection { my $class = shift; return $dbh{$class}; }
 
+=back
+
+=head1 INSTANCE METHODS
+
+=over
+
+=item prepare_cached()
+
+Prepares a query on the singleton database handle, returns statement handler.
+
+=cut
+
 sub prepare_cached {
     my ($self, $q) = @_;
     return $DBH->prepare_cached($q);
 }
 
+=item new()
+
+Instantiates an instance of one of the classes defined in TreeBaseObjects. This constructor
+requires that the singleton database handle $CIPRES::TreeBase::VeryBadORM::DBH has been defined
+and that a valid ID is supplied as argument. Instantiated objects are cached in the private
+%cache hash as $cache{$class}{$id}. Returned objects are simply blessed hash references that 
+contain the ID as { 'id' => $id }
+
+=cut
+
 my %cache;
 sub new {
     my ($class, $id) = @_;
@@ -31,6 +91,15 @@
     return $obj;
 }
 
+=item AUTOLOAD
+
+Provides the magical methods available in the child classes. It does this by checking which of
+has_attr(), has_subobject(), has_r_attr() or has_r2_attr() applies and returns one of 
+get_no_check(), get_subobject_no_check(), get_r_subobject_no_check() or get_r2_subobject_no_check()
+respectively. Croaks otherwise.
+
+=cut
+
 # Maybe add some caching here at some point
 sub AUTOLOAD {
     my $obj = shift;
@@ -51,36 +120,85 @@
     }
 }
 
+=item has_attr()
+
+Checks to see if the invocant's class defines the supplied attribute. It does this by calling
+attr_hash() and doing a lookup for the supplied attribute in the returned hash.
+
+=cut
+
 sub has_attr {
     my $base = shift;
     my $class = ref($base) || $base;
     return $class->attr_hash()->{shift()};
 }
 
+=item has_r_attr()
+
+Checks to see if the invocant's class defines the supplied "reverse attribute" (see 
+L<TreeBaseObjects> for the description of the %r_attr hash). It does this by returning whatever
+is returned by r_class() whilst passing it the supplied "reverse attribute"'s name.
+
+=cut
+
 sub has_r_attr {
     my $base = shift;
     my $class = ref($base) || $base;
     return $class->r_class(shift());
 }
 
+=item has_r2_attr()
+
+Checks to see if the invocant's class defines the supplied "reverse attribute through 
+intersection table" (see L<TreeBaseObjects> for the description of the %r2_attr hash). It does this 
+by returning whatever is returned by r2_class() whilst passing it the supplied "reverse 
+attribute through intersection table"'s name.
+
+=cut
+
 sub has_r2_attr {
     my $base = shift;
     my $class = ref($base) || $base;
     return $class->r2_class(shift());
 }
 
+=item has_subobject()
+
+Checks to see if the invocant is associated with the supplied subobject. It does this by 
+first turning the subobject's name into a foreign key column (by calling foreign_key()) and then 
+checking whether that column is available as an attribute (by calling has_attr()).
+
+=cut
+
 sub has_subobject {
     my $base = shift;
     my $subobj = shift;
     return $base->has_attr($base->foreign_key($subobj));
 }
 
+=item foreign_key()
+
+Turns the supplied argument into a foreign key column. It does this by lower casing the 
+argument string and appending '_id'.
+
+=cut
+
 sub foreign_key {
     my $base = shift;
     my $subobj = lc(shift); # XXX
     return $subobj . "_id"; 
 }
 
+=item attr_hash()
+
+Returns a hash reference of all available attributes for the invocant. It does this by first 
+checking to see if there is an %attr hash defined in the invocant's class (and returns 
+a reference to that if it's there). Otherwise it calls attr_list, uses its contents as keys
+(values are 1) and adds the class name . '_id', i.e. a lookup of the primary key. On subsequent
+calls the output is cached due to the autovivification of the package hash.
+
+=cut
+
 sub attr_hash {
     my $base = shift;
     my $class = ref($base) || $base;
@@ -90,40 +208,69 @@
     my $attr_list = $base->attr_list;
     if (@$attr_list) {
 		%$attr_hash = map { $_ => 1 } @$attr_list;
-		$attr_hash->{"$class\_id"} = 1;
+		$attr_hash->{"$class\_id"} = 1; # XXX case correct?
 		return $attr_hash;
     }
     return;
 }
 
+=item attr_list()
+
+Returns an array reference of available attributes. It does this by checking if there is an
+array ref $attr available in the invocant's class (and returns that). Otherwise it checks
+the invocant's mapped database table and collects the returned column names and returns those.
+On subsequent calls the output is cached due to the autovivification of the package array.
+
+=cut
+
 sub attr_list {
     my $base = shift;
     my $class = ref($base) || $base;
     my $attr_list = \@{"$class\::attr"};
     return $attr_list if @$attr_list;
 
-    my $q = "select * from " . $base->table . " fetch first 1 rows only";
+    my $q = "select * from " . $base->table . " fetch first 1 rows only"; # XXX case correct?
     my $sth = $DBH->prepare_cached($q);
     $sth->execute();
     while (my $row = $sth->fetchrow_hashref) {
-	@$attr_list = keys %$row;
+		@$attr_list = keys %$row;
     }
     $sth->finish;
     return $attr_list;
 }
 
+=item r_attr_hash()
+
+Returns the %r_attr hash defined in the invocant's class (see TreeBaseObjects for a description
+of what that hash is for).
+
+=cut
+
 sub r_attr_hash {
     my $base = shift;
     my $class = ref($base) || $base;
     return my $r_attr_hash = \%{"$class\::r_attr"};
 }
 
+=item r2_attr_hash()
+
+Returns the %r2_attr hash defined in the invocant's class (see TreeBaseObjects for a description
+of what that hash is for).
+
+=cut
+
 sub r2_attr_hash {
     my $base = shift;
     my $class = ref($base) || $base;
     return my $r_attr_hash = \%{"$class\::r2_attr"};
 }
 
+=item reify()
+
+Populates the invocant object's attributes from the database.
+
+=cut
+
 sub reify {
     my $obj = shift;
     return $obj if $obj->reified;
@@ -134,40 +281,76 @@
     $sth->execute($id_value);
     my $rows = 0;
     while (my $row = $sth->fetchrow_hashref()) {
-	%$obj = %$row;
-	$obj->{ID} = $obj->{$id_attr};
-	$obj->set_reified();
-	if (++$rows > 1) {
-	    croak("Table '$table' has multiple entries for $id_attr = $id_value");
-	}
+		%$obj = %$row;
+		$obj->{'id'} = $obj->{$id_attr};
+		$obj->set_reified();
+		if (++$rows > 1) {
+			croak("Table '$table' has multiple entries for $id_attr = $id_value");
+		}
     }
     return $obj;
 }
 
-sub reified { $_[0]{reified} }
-sub set_reified { $_[0]{reified} = 1 }
+=item reified()
 
+Returns whether the invocant has been reified (see reify()).
+
+=cut
+
+sub reified { $_[0]{'reified'} }
+
+=item set_reified()
+
+Flags that the invocant object has been reified.
+
+=cut
+
+sub set_reified { $_[0]{'reified'} = 1 }
+
+=item get()
+
+Given an invocant and a supplied attribute name, returns the attribute value. What the attribute
+actually is, is decided by first checking has_attr(), has_subobject(), has_r_attr() and returns
+the output of either get_no_check(), get_subobject_no_check() or get_r_subobject_no_check() 
+respectively. B<This method is probably never used and therefore probably buggy.>
+
+=cut
+
 sub get {
     my ($self, $attr) = @_;
     if ($self->has_attr($attr)) {
-	return $self->get_no_check($attr);
+		return $self->get_no_check($attr);
     } elsif ($self->has_subobject($attr)) {
-	return $self->get_subobject_no_check($attr, @_);
+		return $self->get_subobject_no_check($attr, @_);
     } elsif ($self->has_r_attr($attr)) {
-	return $self->get_r_subobject_no_check($attr, @_);
+		return $self->get_r_subobject_no_check($attr, @_);
     }
     my $trace = Devel::StackTrace->new;
 	print $trace->as_string; # like carp
     croak($self->class . " has no attribute named '$attr'");
 }
 
+=item get_no_check()
+
+Returns the value of the supplied attribute name as applies to the invocant object. This will
+most likely just return scalar, non-reference values such as titles and labels.
+
+=cut
+
 sub get_no_check {
     my ($self, $attr) = @_;
-    return $self->id if $attr eq "id";
+    return $self->id if $attr eq 'id';
     return $self->{$attr} if exists $self->{$attr};
     return $self->{$attr} = $self->reify->{$attr};
 }
 
+=item get_subobject_no_check()
+
+Treats the supplied attribute name as either a true attribute or name from which a subobject
+(in one-to-one relation) is instantiated. See description of %subobject hash in TreeBaseObjects.
+
+=cut
+
 sub get_subobject_no_check {
     my ($self, $attr) = @_;
     return $self->{$attr} if exists $self->{$attr};
@@ -176,6 +359,13 @@
     return $self->{$attr} = $self->subobject_class($attr)->new($id);
 }
 
+=item get_r_subobject_no_check()
+
+Treats the supplied attribute name as either a true attribute or name from which a subobject
+(in many-to-one relation) is instantiated. See description of %r_attr hash in TreeBaseObjects.
+
+=cut
+
 # Example: Studies have analyses as a subobject
 # $study->get_r_subobject_no_check("analyses")
 # should query
@@ -198,6 +388,13 @@
     return @results;
 }
 
+=item get_r2_subobject_no_check()
+
+Treats the supplied attribute name as either a true attribute or name from which a subobject
+(in many-to-one relation) is instantiated. See description of %r2_attr hash in TreeBaseObjects.
+
+=cut
+
 # Example: Treeblocks have submissions as subobjects
 #  and vice versa
 # $treeblock->get_r2_subobject_no_check("submission")
@@ -206,7 +403,7 @@
 # and return a list of submission objects
 sub get_r2_subobject_no_check {
     my ($self, $attr) = @_;
-    $attr = uc $attr;
+#    $attr = uc $attr;
     my $q = $self->r2_subobject_query($attr);
     my $target_class = $self->r2_class($attr);
     my $sth = $self->prepare_cached($q);
@@ -217,6 +414,19 @@
     }
     return @results;
 }
+
+=item r2_subobject_query()
+
+Creates a SQL statement to resolve the many-to-many relationship (through intersection table)
+between the invocant object and the supplied attribute. It does this by looking up the class
+name to instantiate from (by calling r2_class()), the intersection table to look up the relation
+(by calling r2_table()) and the field name of the id column in the intersection table (by calling
+r2_id_attr()).
+
+See description of %r2_attr hash in TreeBaseObjects.
+
+=cut
+
 sub r2_subobject_query {
     my ($self, $attr) = @_;
 
@@ -228,65 +438,183 @@
     return $q;
 }
 
+=item r2_id_attr()
+
+Returns name of the foreign key column in the intersection table of the referenced objects 
+(as opposed to instances of the invocant column) in a many-to-many relation.  By default, it 
+consults %r2_attr first. And if that doesn't work, it consults the foreign class's %r2 instead, 
+to see if the relationship was defined in the other direction.
+
+See description of %r2_attr hash in TreeBaseObjects. This method returns the 3rd element (index 2)
+in the value array ref.
+
+=cut
+
 sub r2_id_attr {
     my ($self, $attr) = @_;
-    $self->r2_attr_hash()->{uc $attr}->[2] || $self->r2_class($attr)->id_attr;
+    $self->r2_attr_hash()->{$attr}->[2] || $self->r2_class($attr)->id_attr;
 }
 
+=item to_str()
+
+Stringification method. Returns at least the invocant's class name and its ID number, possibly
+augmented by other attributes (as implemented in child classes).
+
+=cut
+
 sub to_str { my $self = shift; 
 	     my %attr = @_;
 	     return $self->class  . " #" . $self->id; }
 
+=item id()
+
+Returns the invocant's identifier number.
+
+=cut
+
 sub id { $_[0]{'id'} }
+
+=item id_attr()
+
+Returns the name of the column that contains the primary key for instances of the invocant class.
+
+=cut
+
 sub id_attr { return lc($_[0]->class . "_id") };
+
+=item class()
+
+Returns the invocant class name.
+
+=cut
+
 sub class { return ref($_[0]) || $_[0]; }
 
 my %known_class;
 
+=item known_class_hash()
+
+Returns a reference to the private %known_class hash, in which child classes register themselves.
+
+=cut
+
 sub known_class_hash { return \%known_class; }
+
+=item register()
+
+Called by child classes in the package body. Causes these classes to be registered in the 
+%known_class hash. Can be called with arguments, in which case the arguments are considered
+class names to register, or without any, in which case the class name is deduced by using
+caller().
+
+=cut
+
 sub register {
     my $my_class = shift;
     my @classes = @_;
     @classes = scalar(caller()) unless @classes;
     for my $class (@classes) {
 		push @{"$class\::ISA"}, $my_class;
-		$class->known_class_hash->{uc $class} = $class;
+		$class->known_class_hash->{uc $class} = $class; # XXX casing correct?
     }
 }
 
+=item alias()
+
+Returns a registered alias for the supplied class name.
+
+=cut
+
 sub alias { 
     my ($base, $class) = @_;
     return $base->known_class_hash->{$class};
 }
 
+=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.
+
+=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));
+    return $self->alias($subobj) || $subobj;#ucfirst(lc($subobj)); # XXX really?
 }
 
+=item get_id_pair()
+
+Returns the name of the column that contains the primary key in the table onto which the invocant's
+class is mapped, and the value of the id for the invocant instance.
+
+=cut
+
 sub get_id_pair {
     my $self = shift;
     return ($self->id_attr, $self->id);
 }
 
-sub table { return $_[0]->class; }
+=item table()
+
+Returns the name of the table onto which the invocant's class is mapped.
+
+=cut
+
+sub table { return $_[0]->class; } # XXX case correct?
+
+=item r_class()
+
+Returns the class name for the supplied attribute. This is a value in the %r_attr hash.
+
+=cut
+
 sub r_class {
     my ($self, $r_attr) = @_;
     return $self->r_attr_hash()->{$r_attr};
 }
 
+=item r2_table()
+
+Returns the name of the intersection table that connects instances of invocant's class to other
+objects in a many-to-many relation. 
+
+See a description of the %r2_attr hash in TreeBaseObjects. This method returns the first field
+(index 0) in the value array reference.
+
+=cut
+
 sub r2_table {
     my ($self, $r_attr) = @_;
     return $self->r2_attr_hash()->{$r_attr}->[0];
 }
 
+=item r2_class()
+
+Returns the class name for objects that are in a many-to-many relationship with the invocant
+object through an intersection table.
+
+See a description of the %r2_attr hash in TreeBaseObjects. This method returns the second field
+(index 1) in the value array reference.
+
+=cut
+
 sub r2_class {
     my ($self, $r_attr) = @_;
     return $self->r2_attr_hash()->{$r_attr}->[1];
 }
 
+=item dump()
+
+Traverses invocant, executes supplied handlers as defined by the named 'action' argument. The
+'action' argument provides a subroutine reference whose first argument is the invocant, remaining
+arguments are a pass-through of @_. The dump method recurses through the invocant, an operation
+whose depth can be limited by providing a named 'maxdepth' argument.
+
+=cut
+
 sub dump {
     my $self = shift();
     my %attr = @_;
@@ -303,10 +631,44 @@
     delete $attr{$class};
 }
 
+=item recurse()
+
+Empty placeholder method. Implemented by child classes in TreeBaseObjects.
+
+=cut
+
 sub recurse { }
+
+=item consistent()
+
+Empty placeholder method. Implemented by child classes in TreeBaseObjects. Returns true by default.
+
+=cut
+
 sub consistent { 1; }
+
+=item is_nested()
+
+Empty placeholder method. Implemented by child classes in TreeBaseObjects. Returns false by default.
+
+=cut
+
 sub is_nested { 0; }
 
+=item DESTROY()
+
+Empty destructor, needed here so that it's not dispatched to AUTOLOAD
+
+=cut
+
 sub DESTROY { }
 
+=back
+
+=head1 SEE ALSO
+
+L<TreeBaseObjects>
+
+=cut
+
 1;


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