From: <rv...@us...> - 2009-11-19 15:17:01
|
Revision: 288 http://treebase.svn.sourceforge.net/treebase/?rev=288&view=rev Author: rvos Date: 2009-11-19 15:16:50 +0000 (Thu, 19 Nov 2009) Log Message: ----------- Porting from DB2 to PostgreSQL Modified Paths: -------------- trunk/treebase-core/src/main/perl/check/check trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TreeBaseObjects.pm trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm Modified: trunk/treebase-core/src/main/perl/check/check =================================================================== --- trunk/treebase-core/src/main/perl/check/check 2009-11-19 10:51:20 UTC (rev 287) +++ trunk/treebase-core/src/main/perl/check/check 2009-11-19 15:16:50 UTC (rev 288) @@ -5,6 +5,8 @@ use Getopt::Std; use Getopt::Long; use Pod::Usage; +use Data::Dumper; +use Devel::StackTrace; # XXX only for developing, delete me use Carp 'croak'; our $indent = 0; @@ -67,25 +69,27 @@ $| = 1; $TERMINAL = 1; } -my %pod_usage_args = ( -exitval => 1, -verbose => 1 ); +my %pod_usage_args = ( '-exitval' => 1, '-verbose' => 1 ); my %opt; + +# processing command line arguments getopts('chasd:p:RC:X', \%opt) or pod2usage(%pod_usage_args); -if ($opt{X}) { list_known_classes(); } -if ($opt{h}) { pod2usage(%pod_usage_args) } -if ($opt{R}) { - if ($opt{d}) { pod2usage(%pod_usage_args, "-msg" => "-R and -d are incompatible") } - $opt{d} = 0; +if ($opt{'X'}) { list_known_classes(); } +if ($opt{'h'}) { pod2usage(%pod_usage_args) } +if ($opt{'R'}) { + if ($opt{'d'}) { pod2usage(%pod_usage_args, '-msg' => '-R and -d are incompatible') } + $opt{'d'} = 0; } -if ($opt{c}) { - if ($opt{C}) { pod2usage(%pod_usage_args, "-msg" => "-c and -C are inconsistent") } - $opt{C} = ""; # set, but no classes +if ($opt{'c'}) { + if ($opt{'C'}) { pod2usage(%pod_usage_args, '-msg' => '-c and -C are inconsistent') } + $opt{'C'} = ""; # set, but no classes } -my %prune = map { $_ => 1 } split /,\s*/, $opt{p}; -my $all_consistency_checks = ! defined $opt{C}; -my %consistency_check = map { $_ => 1 } split /,\s*/, $opt{C}; +my %prune = map { $_ => 1 } split /,\s*/, $opt{'p'}; +my $all_consistency_checks = ! defined $opt{'C'}; +my %consistency_check = map { $_ => 1 } split /,\s*/, $opt{'C'}; -if ($opt{s}) { +if ($opt{'s'}) { # prune out "small" classes $prune{$_} = 1 for qw(MatrixRow PhyloTreeNode TaxonLabel MatrixKind TreeType); } @@ -94,10 +98,11 @@ my $id = shift or pod2usage(%pod_usage_args); $id =~ s/^#//; +# creating database handle my $dbh = CIPRES::TreeBase::DBIUtil->dbh or die "Couldn't connect to database: " . DBI->errstr; CIPRES::TreeBase::TreeBaseObjects->set_db_connection($dbh); -$dbh->{ShowErrorStatement} = 1; +$dbh->{'ShowErrorStatement'} = 1; sub full_str { my $self = shift; @@ -107,17 +112,24 @@ return join ", ", @components; } +# this is a handler that is passed around during consistency checks sub attr_check { my ($obj, $attr_name, $attr, $warnings) = @_; -# warn "checking to see that this object has $attr_name = $attr->{$attr_name}\n"; + print Dumper($attr); + if ( ref $attr eq 'ARRAY' ) { + print Dumper($attr); + my $trace = Devel::StackTrace->new; + print $trace->as_string; # like carp + return 1; + } # If $attr is just a scalar, fake up an attr hash with one attribute unless (ref $attr) { - $attr = { $attr_name => $attr }; + $attr = { $attr_name => $attr }; } unless ($warnings || $attr->{warnings}) { - croak "No warning target variable specified"; + croak "No warning target variable specified"; } return 1 unless exists $attr->{$attr_name}; @@ -146,13 +158,13 @@ my $OK = 1; my @warnings; $type->new($id)->dump( - action => \&prt, - seen => {}, - prune => \%prune, - show_all => $opt{a}, - warnings => \@warnings, - attr_check => \&attr_check, - defined($opt{d}) ? (maxdepth => $opt{d}) : (), + 'action' => \&prt, + 'seen' => {}, + 'prune' => \%prune, + 'show_all' => $opt{a}, + 'warnings' => \@warnings, + 'attr_check' => \&attr_check, + defined($opt{d}) ? ('maxdepth' => $opt{d}) : (), ); for my $w (@warnings) { @@ -174,7 +186,6 @@ my $consistent; my ($class, $id) = ($self->class, $self->id); - if (! $seen) { my $z; if ($TERMINAL) { Modified: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TreeBaseObjects.pm =================================================================== --- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TreeBaseObjects.pm 2009-11-19 10:51:20 UTC (rev 287) +++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TreeBaseObjects.pm 2009-11-19 15:16:50 UTC (rev 288) @@ -5,9 +5,10 @@ CIPRES::TreeBase::VeryBadORM->set_db_connection(@_); } +#################################################################################################### package Analysis; CIPRES::TreeBase::VeryBadORM->register(); -our %r_attr = qw(ANALYSISSTEPS AnalysisStep); +our %r_attr = ( 'analysissteps' => 'AnalysisStep' ); sub to_str { my $self = shift(); @@ -33,8 +34,8 @@ my @matrices; for my $as ($self->analysis_steps) { for my $ad ($as->analyzeddata) { - my $matrix = $ad->matrix; - push @matrices, $matrix if defined $matrix; + my $matrix = $ad->matrix; + push @matrices, $matrix if defined $matrix; } } $self->{analyzed_matrices} = \@matrices; @@ -48,8 +49,8 @@ my @trees; for my $as ($self->analysis_steps) { for my $ad ($as->analyzeddata) { - my $tree = $ad->tree; - push @trees, $tree if defined $tree; + my $tree = $ad->tree; + push @trees, $tree if defined $tree; } } $self->{analyzed_trees} = \@trees; @@ -68,14 +69,14 @@ my %tlset_ids; my $OK = 1; for my $tree ($self->analyzed_trees) { - if ($tree->treeblock && $tree->treeblock->taxonlabelset) { - $tlset_ids{$tree->treeblock->taxonlabelset->id} ++; - } + if ($tree->treeblock && $tree->treeblock->taxonlabelset) { + $tlset_ids{$tree->treeblock->taxonlabelset->id} ++; + } } for my $matrix ($self->analyzed_matrices) { - if ($matrix->taxonlabelset) { - $tlset_ids{$matrix->taxonlabelset->id} ++; - } + if ($matrix->taxonlabelset) { + $tlset_ids{$matrix->taxonlabelset->id} ++; + } } my @ids = keys(%tlset_ids); if (@ids == 1) { @@ -99,10 +100,10 @@ return $OK; } - +#################################################################################################### package AnalysisStep; CIPRES::TreeBase::VeryBadORM->register(); -our %r_attr = qw(ANALYZEDDATA AnalyzedData); +our %r_attr = qw(analyzeddata AnalyzedData); sub to_str { my $self = shift(); @@ -117,6 +118,7 @@ } } +#################################################################################################### package AnalyzedData; CIPRES::TreeBase::VeryBadORM->register(); @@ -134,9 +136,11 @@ return $_[0]->phylotree; } +#################################################################################################### package Citation; -our %r2_attr = (AUTHORS => ['CITATION_AUTHOR', 'Person', 'AUTHORS_PERSON_ID'] - ); +our %r2_attr = ( + 'authors' => ['citation_author', 'Person', 'authors_person_id'] +); CIPRES::TreeBase::VeryBadORM->register(); sub recurse { @@ -152,18 +156,26 @@ my %author_count; my $OK = 1; for my $author ($self->authors) { - if (++$author_count{$author->id} == 2) { - push @{$attr{warnings}}, "Citation " . $self->id . " contains author " . $author->id . " multiple times.\n"; - $OK = 0; - } + if (++$author_count{$author->id} == 2) { + push @{$attr{warnings}}, + "Citation " + . $self->id + . " contains author " + . $author->id + . " multiple times.\n"; + $OK = 0; + } } return $OK; } +#################################################################################################### package Matrix; CIPRES::TreeBase::VeryBadORM->register(); -our %r_attr = qw(ROWS MatrixRow - COLUMNS MatrixColumn); +our %r_attr = ( + 'rows' => 'MatrixRow', + 'columns' => 'MatrixColumn', +); sub to_str { my $self = shift(); @@ -235,9 +247,11 @@ return $OK; } +#################################################################################################### package MatrixColumn; CIPRES::TreeBase::VeryBadORM->register(); +#################################################################################################### package MatrixKind; CIPRES::TreeBase::VeryBadORM->register(); @@ -247,6 +261,7 @@ return $self->description ? qq{$s "} . $self->description . qq{"} : $s; } +#################################################################################################### package MatrixRow; CIPRES::TreeBase::VeryBadORM->register(); sub recurse { @@ -261,22 +276,25 @@ return $attr{attr_check}->($self, 'Matrix', \%attr); } +#################################################################################################### package NexusFile; CIPRES::TreeBase::VeryBadORM->register(); -our %subobject = (STUDY => 'Study'); +our %subobject = ('study' => 'Study'); -sub table { "Study_NexusFile" } +sub table { "Study_NexusFile" } # XXX check to see if this casing makes sense sub new_by_name { my ($class, $filename, $study_id) = @_; - my $self = bless { FILENAME => $filename, - STUDY_ID => $study_id, - ID => "$study_id,$filename", - reified => 1, # don't try to retrieve the clob! + my $self = bless { + 'filename' => $filename, + 'study_id' => $study_id, + 'id' => "$study_id,$filename", + 'reified' => 1, # don't try to retrieve the clob! } => $class; return $self; } +#################################################################################################### package Person; CIPRES::TreeBase::VeryBadORM->register(); @@ -291,15 +309,16 @@ return $s; } +#################################################################################################### package PhyloTree; CIPRES::TreeBase::VeryBadORM->register(); -our %subobject = (ROOTNODE => 'PhyloTreeNode', TREETYPE => 'TreeType'); -our %r_attr = (TREEBLOCK => 'TreeBlock'); +our %subobject = ('rootnode' => 'PhyloTreeNode', 'treetype' => 'TreeType'); +our %r_attr = ('treeblock' => 'TreeBlock'); sub to_str { my $self = shift; my $s = $self->SUPER::to_str(@_); - my $tb1id = $self->TB1_TREEID(); + my $tb1id = $self->tb1_treeid(); $s .= qq{ (was $tb1id)} if $tb1id; my $title = $self->title; $s .= qq{ "$title"} if $title; @@ -322,23 +341,22 @@ my $self = shift; my %attr = @_; my $OK = 1; - $OK &&= $attr{attr_check}->($self, 'Study', \%attr); - $OK &&= $attr{attr_check}->($self, 'TreeBlock', \%attr); - $OK &&= $attr{attr_check}->($self->rootnode, 'parent', undef, - $attr{warnings}); + $OK &&= $attr{'attr_check'}->($self, 'Study', \%attr); + $OK &&= $attr{'attr_check'}->($self, 'TreeBlock', \%attr); + $OK &&= $attr{'attr_check'}->($self->rootnode, 'parent', undef, $attr{'warnings'}); for my $a (qw(quality kind type)) { my $meth = "tree$a\_id"; unless (defined $self->$meth) { - push @{$attr{warnings}}, "PhyloTree " . $self->id . " has null tree_$a"; - $OK = 0; + push @{$attr{'warnings'}}, "PhyloTree " . $self->id . " has null tree_$a"; + $OK = 0; } } for my $a (qw(label title)) { unless (defined $self->$a) { - push @{$attr{warnings}}, "PhyloTree " . $self->id . " has null $a"; - $OK = 0; + push @{$attr{warnings}}, "PhyloTree " . $self->id . " has null $a"; + $OK = 0; } } @@ -393,12 +411,14 @@ return $self->{nexusfile} = NexusFile->new_by_name($nfn, $sid); } +#################################################################################################### package PhyloTreeNode; CIPRES::TreeBase::VeryBadORM->register(); -our %subobject = (CHILD => 'PhyloTreeNode', - SIBLING => 'PhyloTreeNode', - PARENT => 'PhyloTreeNode', - ); +our %subobject = ( + 'child' => 'PhyloTreeNode', + 'sibling' => 'PhyloTreeNode', + 'parent' => 'PhyloTreeNode', +); sub to_str { my $self = shift; @@ -411,13 +431,9 @@ sub children { my $self = shift; my @children; - - for (my $child = $self->child; - $child; - $child = $child->sibling) { + for (my $child = $self->child; $child; $child = $child->sibling) { push @children, $child; } - return @children; } @@ -431,10 +447,8 @@ my %attr = @_; my $tl = $self->taxonlabel; $tl->dump(%attr) if $tl; - for (my $n = $self->child; - $n; - $n = $n->sibling) { - $n->dump(%attr); + for (my $n = $self->child; $n; $n = $n->sibling) { + $n->dump(%attr); } } @@ -457,17 +471,18 @@ sub is_nested { 1 } +#################################################################################################### package Study; CIPRES::TreeBase::VeryBadORM->register(); -our %r_attr = qw(ANALYSES Analysis - MATRICES Matrix - TREES PhyloTree - SUBMISSIONS Submission - TAXONLABELSETS TaxonLabelSet - ); +our %r_attr = ( + 'analyses' => 'Analysis', + 'matrices' => 'Matrix', + 'trees' => 'PhyloTree', + 'submissions' => 'Submission', + 'taxonlabelsets' => 'TaxonLabelSet', +); -our %r2_attr = (NEXUSFILES => ['STUDY_NEXUSFILE', 'NexusFile'] - ); +our %r2_attr = ('nexusfiles' => ['study_nexusfile', 'NexusFile']); sub to_str { my $self = shift(); @@ -652,11 +667,13 @@ } } +#################################################################################################### package Submission; CIPRES::TreeBase::VeryBadORM->register(); -our %r2_attr = (TREEBLOCKS => ['SUB_TREEBLOCK', 'TreeBlock'], - TAXONLABELS => ['SUB_TAXONLABEL', 'TaxonLabel'], - MATRICES => ['SUB_MATRIX', 'Matrix'], +our %r2_attr = ( + treeblocks => ['sub_treeblock', 'TreeBlock'], + taxonlabels => ['sub_taxonlabel', 'TaxonLabel'], + matrices => ['sub_matrix', 'Matrix'], ); sub recurse { @@ -716,7 +733,7 @@ return $OK; } - +#################################################################################################### package Taxon; CIPRES::TreeBase::VeryBadORM->register(); @@ -726,10 +743,11 @@ return "$s " . $self->name; } +#################################################################################################### package TaxonLabel; CIPRES::TreeBase::VeryBadORM->register(); -our %r_attr = qw(TREENODES PhyloTreeNode ROWS MatrixRow); -our %r2_attr = (TAXONLABELSETS => ['TAXONLABELSET_TAXONLABEL', 'TaxonLabelSet']); +our %r_attr = ('treenodes' => 'PhyloTreeNode', 'rows' => 'MatrixRow'); +our %r2_attr = ('taxonlabelsets' => ['taxonlabelset_taxonlabel', 'TaxonLabelSet']); sub to_str { my $self = shift(); @@ -758,10 +776,11 @@ return $attr{attr_check}->($self, 'Study', \%attr); } +#################################################################################################### package TaxonLabelSet; CIPRES::TreeBase::VeryBadORM->register(); -our %r_attr = qw(TREEBLOCKS TreeBlock MATRICES Matrix); -our %r2_attr = (TAXONLABELS => ['TAXONLABELSET_TAXONLABEL', 'TaxonLabel']); +our %r_attr = ('treeblocks' => 'TreeBlock', 'matrices' => 'Matrix'); +our %r2_attr = ('taxonlabels' => ['taxonlabelset_taxonlabel', 'TaxonLabel']); sub to_str { my $self = shift; @@ -819,6 +838,7 @@ return $OK; } +#################################################################################################### package TaxonVariant; CIPRES::TreeBase::VeryBadORM->register(); @@ -840,10 +860,11 @@ $t->dump(@_) if $t; } +#################################################################################################### package TreeBlock; CIPRES::TreeBase::VeryBadORM->register(); -our %r2_attr = (SUBMISSIONS => ['SUB_TREEBLOCK', 'Submission']); -our %r_attr = (TREES => 'PhyloTree'); +our %r2_attr = ('submissions' => ['sub_treeblock', 'Submission']); +our %r_attr = ('trees' => 'PhyloTree'); sub to_str { @@ -879,6 +900,7 @@ return $OK; } +#################################################################################################### package TreeType; CIPRES::TreeBase::VeryBadORM->register(); 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-19 10:51:20 UTC (rev 287) +++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm 2009-11-19 15:16:50 UTC (rev 288) @@ -2,7 +2,8 @@ package CIPRES::TreeBase::VeryBadORM; use Carp 'croak'; use strict 'vars'; - +use Devel::StackTrace; +use Data::Dumper; our %dbh; our $DBH; @@ -23,9 +24,9 @@ unless defined $DBH; unless (defined $id) { - croak("$class\::new: missing ID argument"); + croak("$class\::new: missing ID argument"); } - my $obj = bless { ID => $id } => $class; + my $obj = bless { 'id' => $id } => $class; $cache{$class}{$id} = $obj; return $obj; } @@ -36,34 +37,36 @@ our $AUTOLOAD; my ($package, $method) = $AUTOLOAD =~ /(.*)::(.*)/; if ($package->has_attr($method)) { - return $obj->get_no_check($method, @_); + return $obj->get_no_check($method, @_); } elsif ($package->has_subobject($method)) { - return $obj->get_subobject_no_check($method, @_); + return $obj->get_subobject_no_check($method, @_); } elsif ($package->has_r_attr($method)) { - return $obj->get_r_subobject_no_check($method, @_); + return $obj->get_r_subobject_no_check($method, @_); } elsif ($package->has_r2_attr($method)) { - return $obj->get_r2_subobject_no_check($method, @_); + return $obj->get_r2_subobject_no_check($method, @_); } else { - croak("Unknown attribute '$method' in class '$package'"); + my $trace = Devel::StackTrace->new; + print $trace->as_string; # like carp + croak("Unknown attribute '$method' in class '$package'"); } } sub has_attr { my $base = shift; my $class = ref($base) || $base; - return $class->attr_hash()->{uc shift()}; + return $class->attr_hash()->{shift()}; } sub has_r_attr { my $base = shift; my $class = ref($base) || $base; - return $class->r_class(uc shift()); + return $class->r_class(shift()); } sub has_r2_attr { my $base = shift; my $class = ref($base) || $base; - return $class->r2_class(uc shift()); + return $class->r2_class(shift()); } sub has_subobject { @@ -74,7 +77,7 @@ sub foreign_key { my $base = shift; - my $subobj = shift; + my $subobj = lc(shift); # XXX return $subobj . "_id"; } @@ -86,11 +89,10 @@ my $attr_list = $base->attr_list; if (@$attr_list) { - %$attr_hash = map { uc($_) => 1 } @$attr_list; - $attr_hash->{"$class\_id"} = 1; - return $attr_hash; + %$attr_hash = map { $_ => 1 } @$attr_list; + $attr_hash->{"$class\_id"} = 1; + return $attr_hash; } - return; } @@ -154,20 +156,20 @@ } elsif ($self->has_r_attr($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'"); } sub get_no_check { my ($self, $attr) = @_; - $attr = uc $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}; } sub get_subobject_no_check { my ($self, $attr) = @_; - $attr = uc $attr; return $self->{$attr} if exists $self->{$attr}; my $id = $self->get($self->foreign_key($attr)); return unless defined $id; @@ -181,7 +183,7 @@ # and return a list of analysis objects sub get_r_subobject_no_check { my ($self, $attr) = @_; - $attr = uc $attr; + $attr = $attr; my $target_class = $self->r_class($attr); my $target_table = $target_class->table; my $field = $target_class->id_attr; @@ -235,8 +237,8 @@ my %attr = @_; return $self->class . " #" . $self->id; } -sub id { $_[0]{ID} } -sub id_attr { return uc($_[0]->class . "_id") }; +sub id { $_[0]{'id'} } +sub id_attr { return lc($_[0]->class . "_id") }; sub class { return ref($_[0]) || $_[0]; } my %known_class; @@ -247,8 +249,8 @@ my @classes = @_; @classes = scalar(caller()) unless @classes; for my $class (@classes) { - push @{"$class\::ISA"}, $my_class; - $class->known_class_hash->{uc $class} = $class; + push @{"$class\::ISA"}, $my_class; + $class->known_class_hash->{uc $class} = $class; } } @@ -261,7 +263,7 @@ my ($self, $subobj) = @_; my $subobj_class = \%{$self->class . "::subobject"}; return $subobj_class->{$subobj} if exists $subobj_class->{$subobj}; - return $self->alias($subobj) || ucfirst(lc $subobj); + return $self->alias($subobj) || $subobj;#ucfirst(lc($subobj)); } sub get_id_pair { @@ -272,17 +274,17 @@ sub table { return $_[0]->class; } sub r_class { my ($self, $r_attr) = @_; - return $self->r_attr_hash()->{uc $r_attr}; + return $self->r_attr_hash()->{$r_attr}; } sub r2_table { my ($self, $r_attr) = @_; - return $self->r2_attr_hash()->{uc $r_attr}->[0]; + return $self->r2_attr_hash()->{$r_attr}->[0]; } sub r2_class { my ($self, $r_attr) = @_; - return $self->r2_attr_hash()->{uc $r_attr}->[1]; + return $self->r2_attr_hash()->{$r_attr}->[1]; } sub dump { @@ -291,11 +293,11 @@ my ($class, $id) = ($self->class, $self->id); my $continue = 1; - $continue = $attr{action}->($self, %attr) if $attr{action}; + $continue = $attr{'action'}->($self, %attr) if $attr{'action'}; return unless $continue; - $attr{depth} += 1; - return if defined($attr{maxdepth}) && $attr{depth} > $attr{maxdepth}; + $attr{'depth'} += 1; + return if defined($attr{'maxdepth'}) && $attr{'depth'} > $attr{'maxdepth'}; $attr{$class} = $id; $self->recurse(%attr); delete $attr{$class}; This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |