Menu
▾
▴
treebase-guts
|
From: <rv...@us...> - 2009-06-11 08:21:27
|
Revision: 41
http://treebase.svn.sourceforge.net/treebase/?rev=41&view=rev
Author: rvos
Date: 2009-06-11 08:21:24 +0000 (Thu, 11 Jun 2009)
Log Message:
-----------
Factored CREATE statement writing out to RecDumper.pm
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/dump/sqldump
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
Modified: trunk/treebase-core/src/main/perl/dump/sqldump
===================================================================
--- trunk/treebase-core/src/main/perl/dump/sqldump 2009-06-11 07:54:14 UTC (rev 40)
+++ trunk/treebase-core/src/main/perl/dump/sqldump 2009-06-11 08:21:24 UTC (rev 41)
@@ -83,8 +83,7 @@
# write create table statements
if ( $with_creates ) {
- my $uc_table = uc $table;
- print $outhandle "CREATE TABLE $uc_table;\n";
+ $dumper->dump_create;
}
# write insert statements
Modified: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
===================================================================
--- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm 2009-06-11 07:54:14 UTC (rev 40)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm 2009-06-11 08:21:24 UTC (rev 41)
@@ -50,6 +50,13 @@
return $insert;
}
+# Format metadata into a create statement and return (or write) the result
+sub dump_create {
+ my $create = 'CREATE TABLE ' . $self->{'N'} . ";\n";
+ return print {$self->{'OUT'}} $create if $self->{'OUT'};
+ return $create;
+}
+
# XXX UNFINISHED !!!!
sub quote_data {
my $self = shift;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-07-01 20:56:34
|
Revision: 154
http://treebase.svn.sourceforge.net/treebase/?rev=154&view=rev
Author: mjdominus
Date: 2009-07-01 20:56:13 +0000 (Wed, 01 Jul 2009)
Log Message:
-----------
when table is empty, write a comment instead of an empty file
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/dump/sqldump
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
Modified: trunk/treebase-core/src/main/perl/dump/sqldump
===================================================================
--- trunk/treebase-core/src/main/perl/dump/sqldump 2009-06-28 11:56:30 UTC (rev 153)
+++ trunk/treebase-core/src/main/perl/dump/sqldump 2009-07-01 20:56:13 UTC (rev 154)
@@ -164,6 +164,7 @@
$sth->execute();
my $row;
+ my $rows_printed = 0;
# if --progress is provided, print out progress counter
if ($with_progress_meter) {
@@ -177,7 +178,7 @@
my $percent = int(0.5 + $count / $total_records * 100);
print STDERR "\r$percent%" if $percent ne $old_percent;
$old_percent = $percent;
- last if defined($nrecs) && (--$nrecs == 0);
+ last if defined($nrecs) && ++$rows_printed >= $nrecs;
}
}
@@ -185,10 +186,14 @@
else {
while ( $row = $sth->fetchrow_arrayref ) {
$dumper->rec(@$row);
- last if defined($nrecs) && (--$nrecs == 0);
+ last if defined($nrecs) && ++$rows_printed >= $nrecs;
}
}
+ if ($rows_printed == 0) {
+ $dumper->print("-- empty table\n");
+ }
+
# finish the statement handler
$sth->finish();
Modified: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
===================================================================
--- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm 2009-06-28 11:56:30 UTC (rev 153)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm 2009-07-01 20:56:13 UTC (rev 154)
@@ -33,6 +33,12 @@
return;
}
+# Print some text literally
+sub print {
+ my $self = shift;
+ return print {$self->{'OUT'}} @_;
+}
+
# Format data into an insert statement and return (or write) the result
sub rec {
my $self = shift;
@@ -56,7 +62,6 @@
return $create;
}
-# XXX UNFINISHED !!!!
sub quote_data {
my $self = shift;
my @d = @_;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <rv...@us...> - 2009-11-02 23:05:30
|
Revision: 235
http://treebase.svn.sourceforge.net/treebase/?rev=235&view=rev
Author: rvos
Date: 2009-11-02 23:05:22 +0000 (Mon, 02 Nov 2009)
Log Message:
-----------
Added special case for STUDY_NEXUSFILE table dumper
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/dump/sqldump
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
Modified: trunk/treebase-core/src/main/perl/dump/sqldump
===================================================================
--- trunk/treebase-core/src/main/perl/dump/sqldump 2009-11-02 16:08:27 UTC (rev 234)
+++ trunk/treebase-core/src/main/perl/dump/sqldump 2009-11-02 23:05:22 UTC (rev 235)
@@ -18,6 +18,7 @@
my $nrecs; # max number of recs per table
my $where = ""; # WHERE clause to select dumped records
my $maxlen = 5 * 1024 * 1024; # Maximum field length: 5 MB by default
+my $dir = 'STUDY_NEXUSFILE'; # Location to write dumped nexus files
# get command line options, see Getopt::Long
GetOptions(
@@ -28,6 +29,7 @@
'user=s' => \$ENV{'TREEBASE_DB_USER'},
'pass=s' => \$ENV{'TREEBASE_DB_PASS'},
'dsn=s' => \$ENV{'TREEBASE_DB_DSN'},
+ 'dir=s' => \$dir,
'table=s' => \@tables,
'zip' => \$zip,
'maxlen=i' => \$maxlen,
@@ -83,7 +85,8 @@
my $dumper = CIPRES::TreeBase::RecDumper->new(
'FIELDS' => \@names,
'TYPES' => \@types,
- 'TABLE' => $table
+ 'TABLE' => $table,
+ 'DIR' => $dir,
) or die "Couldn't instantiate CIPRES::TreeBase::RecDumper";
# give dumper the output handle to write to, i.e. either STDOUT,
Modified: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
===================================================================
--- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm 2009-11-02 16:08:27 UTC (rev 234)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm 2009-11-02 23:05:22 UTC (rev 235)
@@ -8,12 +8,15 @@
my $fn = $arg{'FIELDS'} or croak("$class->new: FIELDS required");
my $ct = $arg{'TYPES'} or croak("$class->new: TYPES required");
my $tn = uc $arg{'TABLE'} or croak("$class->new: TABLE required");
- my $X = my @fieldnames = map uc, @$fn;
+ my $X = my @fieldnames = map uc, @$fn;
+ my $dir = $arg{'DIR'};
+ mkdir $dir if not -d $dir;
my $self = {
'F' => \@fieldnames,
'X' => $X,
'N' => $tn,
- 'T' => $ct
+ 'T' => $ct,
+ 'D' => $dir,
};
bless $self => $class;
$self->_initialize();
@@ -48,8 +51,29 @@
and croak("rec: too few items (expected $self->{X})");
@_ = $self->quote_data(@_);
-
- my $values = join ", ", @_;
+ my @values;
+ if ( $self->{'N'} ne 'STUDY_NEXUSFILE' ) {
+ @values = @_;
+ }
+ else {
+ my @fields = @{$self->{F}};
+ my ( $dir, $path ) = ( $self->{'D'} );
+ for my $i ( 0 .. $#fields ) {
+ if ( uc $fields[$i] eq 'ID' ) {
+ $path = "$dir/".$_[$i];
+ }
+ if ( uc $fields[$i] ne 'NEXUS' ) {
+ push @values, $_[$i];
+ }
+ else {
+ open my $nexfh, '>', $path or croak $!;
+ print $nexfh $_[$i];
+ close $nexfh;
+ push @values, "lo_import('$path')";
+ }
+ }
+ }
+ my $values = join ", ", @values;
my $insert = $self->{'PREFIX'} . $values . $self->{'SUFFIX'};
return print {$self->{'OUT'}} $insert if $self->{'OUT'};
return $insert;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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.
|
|
From: <rv...@us...> - 2009-11-23 14:07:46
|
Revision: 291
http://treebase.svn.sourceforge.net/treebase/?rev=291&view=rev
Author: rvos
Date: 2009-11-23 14:07:38 +0000 (Mon, 23 Nov 2009)
Log Message:
-----------
Adding CPAN-style supporting scripts (Makefile.PL, test suite)
Added Paths:
-----------
trunk/treebase-core/src/main/perl/Makefile.PL
trunk/treebase-core/src/main/perl/t/
trunk/treebase-core/src/main/perl/t/pod-coverage.t
trunk/treebase-core/src/main/perl/t/pod.t
Added: trunk/treebase-core/src/main/perl/Makefile.PL
===================================================================
--- trunk/treebase-core/src/main/perl/Makefile.PL (rev 0)
+++ trunk/treebase-core/src/main/perl/Makefile.PL 2009-11-23 14:07:38 UTC (rev 291)
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'CIPRES-TreeBase',
+ 'AUTHOR' => 'Rutger Vos <rut...@gm...>',
+ 'PL_FILES' => {},
+ 'EXE_FILES' => [],
+ 'VERSION_FROM' => 'lib/CIPRES/TreeBase/TreeBaseObjects.pm',
+ 'clean' => {},
+ 'dist' => { 'COMPRESS' => 'gzip -9f', 'SUFFIX' => 'gz', },
+);
Added: trunk/treebase-core/src/main/perl/t/pod-coverage.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/pod-coverage.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/pod-coverage.t 2009-11-23 14:07:38 UTC (rev 291)
@@ -0,0 +1,5 @@
+use Test::More;
+eval "use Test::Pod::Coverage";
+plan skip_all => "Test::Pod::Coverage required for testing POD coverage"
+ if $@;
+all_pod_coverage_ok();
\ No newline at end of file
Added: trunk/treebase-core/src/main/perl/t/pod.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/pod.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/pod.t 2009-11-23 14:07:38 UTC (rev 291)
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Pod";
+plan skip_all => "Test::Pod required for testing POD" if $@;
+all_pod_files_ok();
\ No newline at end of file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-23 19:26:39
|
Revision: 298
http://treebase.svn.sourceforge.net/treebase/?rev=298&view=rev
Author: mjdominus
Date: 2009-11-23 19:25:47 +0000 (Mon, 23 Nov 2009)
Log Message:
-----------
add trivial test using DBD::CSV
Added Paths:
-----------
trunk/treebase-core/src/main/perl/t/01_basic.t
trunk/treebase-core/src/main/perl/test_db/
trunk/treebase-core/src/main/perl/test_db/study
Added: trunk/treebase-core/src/main/perl/t/01_basic.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/01_basic.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-23 19:25:47 UTC (rev 298)
@@ -0,0 +1,18 @@
+
+use Test::More tests => 10;
+
+warn(`pwd`);
+use_ok('DBI');
+use_ok('DBD::CSV');
+
+ok(my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n"));
+ok(my $sth = $dbh->prepare("select id from study where interesting > 0"));
+ok($sth->execute());
+
+%x = (4 => 1, 6 => 1, 8 => 1, 9 => 1);
+while (my ($id) = $sth->fetchrow) {
+ ok($x{$id}, "found item $id");
+ delete $x{$id};
+}
+is(keys(%x), 0, "all items found");
+
Added: trunk/treebase-core/src/main/perl/test_db/study
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/study (rev 0)
+++ trunk/treebase-core/src/main/perl/test_db/study 2009-11-23 19:25:47 UTC (rev 298)
@@ -0,0 +1,10 @@
+name,id,interesting
+cube,8,1
+even prime,2,0
+five,5,0
+seven,7,0
+sphenic,6,1
+square 3,9,1
+square,4,1
+three,3,0
+unit,1,0
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-24 02:48:14
|
Revision: 300
http://treebase.svn.sourceforge.net/treebase/?rev=300&view=rev
Author: mjdominus
Date: 2009-11-24 02:47:19 +0000 (Tue, 24 Nov 2009)
Log Message:
-----------
More tests; start filling out the test database.
Create TestObjects.pm with schema definition for test database.
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TreeBaseObjects.pm
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm
trunk/treebase-core/src/main/perl/t/01_basic.t
trunk/treebase-core/src/main/perl/test_db/study
Added Paths:
-----------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
trunk/treebase-core/src/main/perl/t/02_table.t
trunk/treebase-core/src/main/perl/t/10_internal.t
trunk/treebase-core/src/main/perl/t/20_study.t
trunk/treebase-core/src/main/perl/t/test_db
trunk/treebase-core/src/main/perl/test_db/TREE
trunk/treebase-core/src/main/perl/test_db/matrices
Added: trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
===================================================================
--- trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm (rev 0)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1,20 @@
+$CIPRES::TreeBase::TestObjects::VERSION=0.1;
+
+require CIPRES::TreeBase::VeryBadORM;
+
+
+package Study;
+CIPRES::TreeBase::VeryBadORM->register();
+
+package Tree;
+CIPRES::TreeBase::VeryBadORM->register();
+
+sub table { "TREE" }
+sub id_attr { "TreeId" }
+
+package Matrix;
+CIPRES::TreeBase::VeryBadORM->register();
+
+sub table { "matrices" }
+
+1;
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-23 21:45:55 UTC (rev 299)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TreeBaseObjects.pm 2009-11-24 02:47:19 UTC (rev 300)
@@ -1,4 +1,4 @@
-$CIPRES::TreeBase::VERSION=0.1;
+$CIPRES::TreeBase::TreeBaseObjects::VERSION=0.1;
require CIPRES::TreeBase::VeryBadORM;
@@ -8,8 +8,41 @@
=head1 DESCRIPTION
-=head1 PACKAGE VARIABLES
+This module is a collection of classes that represent objects from the TreeBase database.
+Access to the objects is through L<CIPRES::TreeBase::VeryBadORM> and is read-only.
+In general, each kind of object is represented by a different class. For example, studies are
+represented by C<Study> objects, treenodes are represented by C<PhyloTreeNode> objects, and so
+on.
+
+
+=head1 OBJECT ATTRIBUTES
+
+In general, if a database object, represented by C<$X>, has an attribute named C<foo>, then
+C< $X->foo > retrieves the value of the attribute. If the attribute is a scalar, the value is
+returned as a Perl scalar; if the attribute is a reference to another database object, a
+Perl object is returned.
+
+Each object is assumed to correspond to a single table in the database. If the object class is
+C<ObjectClass>, the corresponding table name is assumed to be C<objectclass>. This can be
+overridden by defining the C<ObjectClass::table> method, which should return the correct table
+name.
+
+Each object from class C<ObjectClass> is assumed to have a unique ID attribute which is stored
+in the table in a field whose name is returned by C<ObjectClass::id_attr>. This defaults to
+C<objectclass_id> if the method is not overridden.
+
+C<ObjectClass::new(V<ID>)> will create an object with the specified ID number. Objects are
+created lazily: the database is not consulted until some
+
+We will consider a running example, a database which contains studies, trees, and matrices.
+Each tree and each matrix is contained in exactly one study, but each study may have multiple
+trees and matrices.
+
+Each tree contains zero or more treenodes, and each matrix contains zero or more matrixrows.
+
+Suppose the C<tree> table contains a field, C<study_id>, which contains the foreign key of the
+
=over
=item %r_attr
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 21:45:55 UTC (rev 299)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm 2009-11-24 02:47:19 UTC (rev 300)
@@ -1,8 +1,11 @@
package CIPRES::TreeBase::VeryBadORM;
+
+$CIPRES::TreeBase::VeryBadORM::VERSION=0.1;
+
use Carp 'croak';
use strict 'vars';
-use Devel::StackTrace;
-use Data::Dumper;
+#use Devel::StackTrace;
+#use Data::Dumper;
our %dbh;
our $DBH;
@@ -12,15 +15,18 @@
=head1 DESCRIPTION
-Superclass for TreeBASE objects. This class is subclassed by packages in TreeBaseObjects.
+Superclass for TreeBASE objects. This class is subclassed by packages in C<TreeBaseObjects>.
+This module maps relations in a relational database to objects in Perl. It avoids all difficult
+implementation problems by providing only read-only access.
+
=head1 PACKAGE VARIABLES
=over
=item %dbh
-This hash holds cached (in theory different) database handles keyed on class names.
+This hash holds cached database handles keyed on class names.
=item $DBH
@@ -94,7 +100,7 @@
=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
+has_attr(), has_subobject(), has_r_attr() or has_r2_attr() applies and invokes one of
get_no_check(), get_subobject_no_check(), get_r_subobject_no_check() or get_r2_subobject_no_check()
respectively. Croaks otherwise.
@@ -208,7 +214,7 @@
my $attr_list = $base->attr_list;
if (@$attr_list) {
%$attr_hash = map { $_ => 1 } @$attr_list;
- $attr_hash->{"$class\_id"} = 1; # XXX case correct?
+ $attr_hash->{$class->id_attr} = 1;
return $attr_hash;
}
return;
@@ -229,7 +235,10 @@
my $attr_list = \@{"$class\::attr"};
return $attr_list if @$attr_list;
- my $q = "select * from " . $base->table . " fetch first 1 rows only"; # XXX case correct?
+# For DB2:
+# my $q = "select * from " . $base->table . " fetch first 1 rows only";
+# For Postgres:
+ my $q = "select * from " . $base->table . " limit 1";
my $sth = $DBH->prepare_cached($q);
$sth->execute();
while (my $row = $sth->fetchrow_hashref) {
@@ -563,7 +572,7 @@
=cut
-sub table { return $_[0]->class; } # XXX case correct?
+sub table { return lc($_[0]->class); }
=item r_class()
Modified: trunk/treebase-core/src/main/perl/t/01_basic.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-23 21:45:55 UTC (rev 299)
+++ trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 02:47:19 UTC (rev 300)
@@ -1,18 +1,28 @@
-use Test::More tests => 10;
+use Test::More tests => 27;
-warn(`pwd`);
use_ok('DBI');
use_ok('DBD::CSV');
ok(my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n"));
-ok(my $sth = $dbh->prepare("select id from study where interesting > 0"));
-ok($sth->execute());
-%x = (4 => 1, 6 => 1, 8 => 1, 9 => 1);
-while (my ($id) = $sth->fetchrow) {
- ok($x{$id}, "found item $id");
- delete $x{$id};
+check_table('study', qw(name study_id owner tree_id));
+check_table('matrices', qw(matrix_id name n_rows study_id));
+check_table('TREE', qw(TreeId name root_node_id));
+
+use_ok('CIPRES::TreeBase::TestObjects');
+
+# one test per column, plus four
+sub check_table {
+ my $table = shift;
+ my %expected_columns = map {$_ => 1} @_;
+ ok(my $sth = $dbh->prepare("select * from $table"));
+ ok($sth->execute());
+ ok(my $row = $sth->fetchrow_hashref);
+ for my $col (keys %$row) {
+ ok($expected_columns{$col}, "found expected column '$col' in table '$table'");
+ delete $expected_columns{$col};
+ }
+ is(keys(%expected_columns), 0, "all columns found in table '$table'");
}
-is(keys(%x), 0, "all items found");
Added: trunk/treebase-core/src/main/perl/t/02_table.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/02_table.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/02_table.t 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1,15 @@
+
+use Test::More tests => 7;
+
+use_ok('CIPRES::TreeBase::TestObjects');
+
+is(Matrix->table, "matrices");
+is(Study->table, "study");
+is(Tree->table, "TREE");
+
+is(Matrix->id_attr, "matrix_id");
+is(Study->id_attr, "study_id");
+is(Tree->id_attr, "TreeId");
+
+
+
Added: trunk/treebase-core/src/main/perl/t/10_internal.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/10_internal.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/10_internal.t 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1,5 @@
+
+# To test: attr_list
+# attr_hash
+
+use Test::More 'skip_all' => 'none yet';
\ No newline at end of file
Added: trunk/treebase-core/src/main/perl/t/20_study.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/20_study.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/20_study.t 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1,13 @@
+use Test::More tests => 5;
+
+use lib '../blib/lib';
+use_ok('CIPRES::TreeBase::TestObjects');
+use DBI;
+my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n");
+Study->set_db_connection($dbh);
+
+ok(my $s1 = Study->new(1));
+is($s1->name, 'study one');
+
+ok(my $s8 = Study->new(8));
+is($s8->owner, 'Otto');
Added: trunk/treebase-core/src/main/perl/t/test_db
===================================================================
--- trunk/treebase-core/src/main/perl/t/test_db (rev 0)
+++ trunk/treebase-core/src/main/perl/t/test_db 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1 @@
+link ../test_db
\ No newline at end of file
Property changes on: trunk/treebase-core/src/main/perl/t/test_db
___________________________________________________________________
Added: svn:special
+ *
Added: trunk/treebase-core/src/main/perl/test_db/TREE
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/TREE (rev 0)
+++ trunk/treebase-core/src/main/perl/test_db/TREE 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1,8 @@
+TreeId,name,root_node_id
+1,tree i,
+2,tree ii,
+24,tree xxiv,
+120,tree cxx,
+5040,tree Vxl,
+40320,tree XLcccxx,
+119,tree cxix,
\ No newline at end of file
Added: trunk/treebase-core/src/main/perl/test_db/matrices
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/matrices (rev 0)
+++ trunk/treebase-core/src/main/perl/test_db/matrices 2009-11-24 02:47:19 UTC (rev 300)
@@ -0,0 +1,7 @@
+matrix_id,name,n_rows,study_id
+1,matrix I,2,2
+16,matrix XVI,17,4
+4,matrix IV,5,2
+64,matrix LXIV,65,8
+25,matrix XXV,26,5
+49,matrix XLIX,50,7
Modified: trunk/treebase-core/src/main/perl/test_db/study
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/study 2009-11-23 21:45:55 UTC (rev 299)
+++ trunk/treebase-core/src/main/perl/test_db/study 2009-11-24 02:47:19 UTC (rev 300)
@@ -1,10 +1,7 @@
-name,id,interesting
-cube,8,1
-even prime,2,0
-five,5,0
-seven,7,0
-sphenic,6,1
-square 3,9,1
-square,4,1
-three,3,0
-unit,1,0
+study_id,name,owner,tree_id
+1,study one,Juan,1
+4,study four,Balfour,24
+2,study two,Thieu,2
+8,study eight,Otto,40320
+5,study five,Quentin,120
+7,study seven,Septimus,5040
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
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.
|
|
From: <mjd...@us...> - 2009-11-24 03:56:07
|
Revision: 304
http://treebase.svn.sourceforge.net/treebase/?rev=304&view=rev
Author: mjdominus
Date: 2009-11-24 03:56:01 +0000 (Tue, 24 Nov 2009)
Log Message:
-----------
register TreeNode; add test for explicit subobject specification
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
trunk/treebase-core/src/main/perl/t/01_basic.t
trunk/treebase-core/src/main/perl/t/21_subobject.t
trunk/treebase-core/src/main/perl/test_db/node
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 03:50:24 UTC (rev 303)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm 2009-11-24 03:56:01 UTC (rev 304)
@@ -9,6 +9,8 @@
package Tree;
CIPRES::TreeBase::VeryBadORM->register();
+%subobject = (root_node => 'TreeNode');
+
sub table { "TREE" }
sub id_attr { "TreeId" }
@@ -17,4 +19,9 @@
sub table { "matrices" }
+package TreeNode;
+CIPRES::TreeBase::VeryBadORM->register();
+
+sub table { "node" }
+
1;
Modified: trunk/treebase-core/src/main/perl/t/01_basic.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 03:50:24 UTC (rev 303)
+++ trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 03:56:01 UTC (rev 304)
@@ -9,7 +9,7 @@
check_table('study', qw(name study_id owner tree_id));
check_table('matrices', qw(matrix_id name n_rows study_id));
check_table('TREE', qw(TreeId name root_node_id));
-check_table('node', qw(node_id tree_id left_child right_child data));
+check_table('node', qw(treenode_id tree_id left_child right_child data));
use_ok('CIPRES::TreeBase::TestObjects');
Modified: trunk/treebase-core/src/main/perl/t/21_subobject.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/21_subobject.t 2009-11-24 03:50:24 UTC (rev 303)
+++ trunk/treebase-core/src/main/perl/t/21_subobject.t 2009-11-24 03:56:01 UTC (rev 304)
@@ -1,4 +1,4 @@
-use Test::More tests => 3;
+use Test::More tests => 4;
use_ok('CIPRES::TreeBase::TestObjects');
use DBI;
@@ -8,4 +8,5 @@
is(Study->new(4)->Tree->name, "tree xxiv"); # use correct subobject name
is(Study->new(4)->tree->name, "tree xxiv"); # use alternate capitalization
-
+# root_node's class is defined by %Tree::subobject, not by the default behavior
+is(Tree->new(24)->root_node->id, Tree->new(24)->root_node_id);
Modified: trunk/treebase-core/src/main/perl/test_db/node
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/node 2009-11-24 03:50:24 UTC (rev 303)
+++ trunk/treebase-core/src/main/perl/test_db/node 2009-11-24 03:56:01 UTC (rev 304)
@@ -1,4 +1,4 @@
-node_id,tree_id,left_child,right_child,data
+treenode_id,tree_id,left_child,right_child,data
8,2,,,D
28,119,,,CC
29,120,,,P
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-24 04:34:52
|
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.
|
|
From: <mjd...@us...> - 2009-11-24 19:21:54
|
Revision: 319
http://treebase.svn.sourceforge.net/treebase/?rev=319&view=rev
Author: mjdominus
Date: 2009-11-24 19:21:44 +0000 (Tue, 24 Nov 2009)
Log Message:
-----------
reverse attributes test for Study->matrices
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
trunk/treebase-core/src/main/perl/t/22_reverse.t
trunk/treebase-core/src/main/perl/test_db/matrices
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 16:09:20 UTC (rev 318)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm 2009-11-24 19:21:44 UTC (rev 319)
@@ -5,6 +5,7 @@
package Study;
CIPRES::TreeBase::VeryBadORM->register();
+%r_attr = (matrices => 'Matrix');
package Tree;
CIPRES::TreeBase::VeryBadORM->register();
Modified: trunk/treebase-core/src/main/perl/t/22_reverse.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/22_reverse.t 2009-11-24 16:09:20 UTC (rev 318)
+++ trunk/treebase-core/src/main/perl/t/22_reverse.t 2009-11-24 19:21:44 UTC (rev 319)
@@ -1,6 +1,9 @@
-use Test::More tests => 3;
+use Test::More tests => 9;
-use lib '../lib';
+#
+# Tests for reverse attributes (%r_attr)
+#
+
use_ok('CIPRES::TreeBase::TestObjects');
use DBI;
my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n");
@@ -8,21 +11,31 @@
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;
+{
+ 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};
}
- 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");
}
- if (%x_names) {
- my $missing = each %x_names;
- $RESULT = "Where is node '$missing'?";
- }
- ok($RESULT eq "", $RESULT || "Tested nodes of tree 5040");
}
+
+my %x_num_matrices = (1 => 1, 2 => 1, 4 => 2, 5 => 1, 7 => 1, 8 => 1);
+for my $sid (1, 2, 4, 5, 7, 8) {
+ my $num_matrices = my @matrices = Study->new($sid)->matrices;
+ my $matrices = $x_num_matrices{$sid} == 1 ? "matrix" : "matrices";
+ is ($num_matrices, $x_num_matrices{$sid}, "count study $sid matrices");
+}
+
Modified: trunk/treebase-core/src/main/perl/test_db/matrices
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/matrices 2009-11-24 16:09:20 UTC (rev 318)
+++ trunk/treebase-core/src/main/perl/test_db/matrices 2009-11-24 19:21:44 UTC (rev 319)
@@ -1,7 +1,8 @@
matrix_id,name,n_rows,study_id
-1,matrix I,2,2
+1,matrix I,2,1
16,matrix XVI,17,4
4,matrix IV,5,2
64,matrix LXIV,65,8
25,matrix XXV,26,5
49,matrix XLIX,50,7
+17,matrix XVII,18,4
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-24 19:34:54
|
Revision: 320
http://treebase.svn.sourceforge.net/treebase/?rev=320&view=rev
Author: mjdominus
Date: 2009-11-24 19:33:56 +0000 (Tue, 24 Nov 2009)
Log Message:
-----------
add a link table for link-attribute tests
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/t/01_basic.t
Added Paths:
-----------
trunk/treebase-core/src/main/perl/23_link.t
trunk/treebase-core/src/main/perl/test_db/person
trunk/treebase-core/src/main/perl/test_db/study_author
Added: trunk/treebase-core/src/main/perl/23_link.t
===================================================================
--- trunk/treebase-core/src/main/perl/23_link.t (rev 0)
+++ trunk/treebase-core/src/main/perl/23_link.t 2009-11-24 19:33:56 UTC (rev 320)
@@ -0,0 +1,12 @@
+use Test::More tests => 1;
+
+#
+# Tests for link attributes (%r2_attr)
+#
+
+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);
+
+ok(1);
Modified: trunk/treebase-core/src/main/perl/t/01_basic.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 19:21:44 UTC (rev 319)
+++ trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 19:33:56 UTC (rev 320)
@@ -1,5 +1,5 @@
-use Test::More tests => 36;
+use Test::More tests => 50;
use_ok('DBI');
use_ok('DBD::CSV');
@@ -10,6 +10,8 @@
check_table('matrices', qw(matrix_id name n_rows study_id));
check_table('TREE', qw(TreeId name root_node_id));
check_table('node', qw(treenode_id tree_id left_child right_child data));
+check_table('person', qw(person_id last first));
+check_table('study_author', qw(study_id person_id role));
use_ok('CIPRES::TreeBase::TestObjects');
Added: trunk/treebase-core/src/main/perl/test_db/person
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/person (rev 0)
+++ trunk/treebase-core/src/main/perl/test_db/person 2009-11-24 19:33:56 UTC (rev 320)
@@ -0,0 +1,11 @@
+person_id,last,first
+1,Aguilar,Juan
+2,Tuc,Thieu
+3,Coquand,Thierry
+4,Balfour,Todd
+5,Quincunx,Quentin
+6,Sax,Sixto
+7,Sargent,Septimus
+8,Octavian,Otto
+9,Nonne,Ian
+10,Ten Eyck,Rutger
Added: trunk/treebase-core/src/main/perl/test_db/study_author
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/study_author (rev 0)
+++ trunk/treebase-core/src/main/perl/test_db/study_author 2009-11-24 19:33:56 UTC (rev 320)
@@ -0,0 +1,14 @@
+study_id,person_id,role
+1,1,Author
+1,2,Editor
+2,2,Author
+2,3,Author
+4,4,Author
+5,5,Author
+5,6,Author
+5,7,Editor
+7,7,Author
+7,8,Editor
+8,10,Author
+8,8,Author
+8,9,Author
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-24 19:47:48
|
Revision: 321
http://treebase.svn.sourceforge.net/treebase/?rev=321&view=rev
Author: mjdominus
Date: 2009-11-24 19:47:39 +0000 (Tue, 24 Nov 2009)
Log Message:
-----------
Remove owner field from study
Add link tests study -> study_author -> person
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
trunk/treebase-core/src/main/perl/t/01_basic.t
trunk/treebase-core/src/main/perl/t/20_scalar.t
trunk/treebase-core/src/main/perl/test_db/study
Added Paths:
-----------
trunk/treebase-core/src/main/perl/t/23_link.t
Removed Paths:
-------------
trunk/treebase-core/src/main/perl/23_link.t
Deleted: trunk/treebase-core/src/main/perl/23_link.t
===================================================================
--- trunk/treebase-core/src/main/perl/23_link.t 2009-11-24 19:33:56 UTC (rev 320)
+++ trunk/treebase-core/src/main/perl/23_link.t 2009-11-24 19:47:39 UTC (rev 321)
@@ -1,12 +0,0 @@
-use Test::More tests => 1;
-
-#
-# Tests for link attributes (%r2_attr)
-#
-
-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);
-
-ok(1);
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 19:33:56 UTC (rev 320)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm 2009-11-24 19:47:39 UTC (rev 321)
@@ -3,9 +3,18 @@
require CIPRES::TreeBase::VeryBadORM;
+package Matrix;
+CIPRES::TreeBase::VeryBadORM->register();
+
+sub table { "matrices" }
+
+package Person;
+CIPRES::TreeBase::VeryBadORM->register();
+
package Study;
CIPRES::TreeBase::VeryBadORM->register();
%r_attr = (matrices => 'Matrix');
+%r2_attr = (people => ['study_author', 'Person']);
package Tree;
CIPRES::TreeBase::VeryBadORM->register();
@@ -16,11 +25,6 @@
sub table { "TREE" }
sub id_attr { "TreeId" }
-package Matrix;
-CIPRES::TreeBase::VeryBadORM->register();
-
-sub table { "matrices" }
-
package TreeNode;
CIPRES::TreeBase::VeryBadORM->register();
Modified: trunk/treebase-core/src/main/perl/t/01_basic.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 19:33:56 UTC (rev 320)
+++ trunk/treebase-core/src/main/perl/t/01_basic.t 2009-11-24 19:47:39 UTC (rev 321)
@@ -1,12 +1,12 @@
-use Test::More tests => 50;
+use Test::More tests => 49;
use_ok('DBI');
use_ok('DBD::CSV');
ok(my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n"));
-check_table('study', qw(name study_id owner tree_id));
+check_table('study', qw(name study_id tree_id));
check_table('matrices', qw(matrix_id name n_rows study_id));
check_table('TREE', qw(TreeId name root_node_id));
check_table('node', qw(treenode_id tree_id left_child right_child data));
Modified: trunk/treebase-core/src/main/perl/t/20_scalar.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/20_scalar.t 2009-11-24 19:33:56 UTC (rev 320)
+++ trunk/treebase-core/src/main/perl/t/20_scalar.t 2009-11-24 19:47:39 UTC (rev 321)
@@ -8,8 +8,8 @@
ok(my $s1 = Study->new(1));
is($s1->name, 'study one');
-ok(my $s8 = Study->new(8));
-is($s8->owner, 'Otto');
+ok(my $person = Person->new(8));
+is($person->first, '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/23_link.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/23_link.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/23_link.t 2009-11-24 19:47:39 UTC (rev 321)
@@ -0,0 +1,27 @@
+use Test::More tests => 2;
+
+#
+# Tests for link attributes (%r2_attr)
+#
+
+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 $FAIL = "";
+my @s5_people = Study->new(5)->people;
+my %x_people = map {$_ => 1} qw(Quincunx Sax Sargent);
+for my $p (@s5_people) {
+ my $ln = $p->last;
+ if ($x_people{$ln}) {
+ delete $x_people{$ln};
+ } else {
+ $FAIL = "unexpected person '$ln' associated with study 5";
+ }
+}
+if (%x_people) {
+ $FAIL = "missing persons " . join(", ", keys %x_people) . " not associated with study 5";
+}
+ok($FAIL eq "", $FAIL || "check study 5 people");
+
Modified: trunk/treebase-core/src/main/perl/test_db/study
===================================================================
--- trunk/treebase-core/src/main/perl/test_db/study 2009-11-24 19:33:56 UTC (rev 320)
+++ trunk/treebase-core/src/main/perl/test_db/study 2009-11-24 19:47:39 UTC (rev 321)
@@ -1,7 +1,7 @@
-study_id,name,owner,tree_id
-1,study one,Juan,1
-4,study four,Balfour,24
-2,study two,Thieu,2
-8,study eight,Otto,40320
-5,study five,Quentin,120
-7,study seven,Septimus,5040
+study_id,name,tree_id
+1,study one,1
+4,study four,24
+2,study two,2
+8,study eight,40320
+5,study five,120
+7,study seven,5040
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-24 21:29:43
|
Revision: 322
http://treebase.svn.sourceforge.net/treebase/?rev=322&view=rev
Author: mjdominus
Date: 2009-11-24 21:28:47 +0000 (Tue, 24 Nov 2009)
Log Message:
-----------
add another link table test
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm
trunk/treebase-core/src/main/perl/t/23_link.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 19:47:39 UTC (rev 321)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/TestObjects.pm 2009-11-24 21:28:47 UTC (rev 322)
@@ -10,11 +10,12 @@
package Person;
CIPRES::TreeBase::VeryBadORM->register();
+%r2_attr = (studies => ['study_author', 'Study']);
package Study;
CIPRES::TreeBase::VeryBadORM->register();
%r_attr = (matrices => 'Matrix');
-%r2_attr = (people => ['study_author', 'Person']);
+%r2_attr = (people => ['study_author', 'Person', 'person_id']);
package Tree;
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-24 19:47:39 UTC (rev 321)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm 2009-11-24 21:28:47 UTC (rev 322)
@@ -453,13 +453,22 @@
=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.
+(as opposed to instances of the invocant column) in a many-to-many relation.
-See description of %r2_attr hash in TreeBaseObjects. This method returns the 3rd element (index 2)
-in the value array ref.
+If C<%r2_attr> lists a target class for the referenced object,
+C<r2_id_attr> uses that class's default C<id_attr>, unless that us
+overriden by C<%r2_attr>. For example, if C<Study> has:
+ %Study::r2_attr = (nexusfiles => ['study_nexus', 'Nexus'])
+
+then the C<nexus_id> column will be consulted, unless
+C<Nexus->id_attr> returns something else. But if the attribute is
+given explicitly, like this:
+
+ %Study::r2_attr = (nexusfiles => ['study_nexus', 'Nexus', 'nexusfileID'])
+
+then the C<nexusfileID> column of the C<study_nexus> table will be consulted.
+
=cut
sub r2_id_attr {
Modified: trunk/treebase-core/src/main/perl/t/23_link.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/23_link.t 2009-11-24 19:47:39 UTC (rev 321)
+++ trunk/treebase-core/src/main/perl/t/23_link.t 2009-11-24 21:28:47 UTC (rev 322)
@@ -1,9 +1,9 @@
-use Test::More tests => 2;
+use Test::More tests => 5;
#
# Tests for link attributes (%r2_attr)
#
-
+use lib '../lib';
use_ok('CIPRES::TreeBase::TestObjects');
use DBI;
my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n");
@@ -25,3 +25,14 @@
}
ok($FAIL eq "", $FAIL || "check study 5 people");
+
+# ----------------------------------------------------------------
+# This is to test that reverse attributes are inferred automatically,
+# without requiring a separate r2_attr declaration
+
+my @p7_studies = sort { $a->id <=> $b->id } Person->new(7)->studies;
+
+is(scalar @p7_studies, 2, "Septimus is involved in 2 studies");
+is($p7_studies[0]->id, 5, "Septimus in study 5");
+is($p7_studies[1]->id, 7, "Septimus in study 7");
+
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <mjd...@us...> - 2009-11-25 06:02:58
|
Revision: 325
http://treebase.svn.sourceforge.net/treebase/?rev=325&view=rev
Author: mjdominus
Date: 2009-11-25 06:01:41 +0000 (Wed, 25 Nov 2009)
Log Message:
-----------
bug fix in has_subobject, plus regression test
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm
Added Paths:
-----------
trunk/treebase-core/src/main/perl/t/80_regression.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-25 05:58:49 UTC (rev 324)
+++ trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/VeryBadORM.pm 2009-11-25 06:01:41 UTC (rev 325)
@@ -253,7 +253,8 @@
sub has_subobject {
my $base = shift;
my $subobj = shift;
- return $base->has_attr($base->foreign_key($subobj));
+ my $fk = $base->foreign_key($subobj) or return;
+ return $base->has_attr($fk);
}
=item foreign_key()
Added: trunk/treebase-core/src/main/perl/t/80_regression.t
===================================================================
--- trunk/treebase-core/src/main/perl/t/80_regression.t (rev 0)
+++ trunk/treebase-core/src/main/perl/t/80_regression.t 2009-11-25 06:01:41 UTC (rev 325)
@@ -0,0 +1,21 @@
+
+use Test::More tests => 1;
+
+BEGIN {
+ require CIPRES::TreeBase::VeryBadORM;
+
+ package TestObject;
+ CIPRES::TreeBase::VeryBadORM->register;
+ sub table { "study" }
+ sub foreign_key { return undef; }
+}
+
+# Regression test for bug in has_subobject: if ->foreign_key indicates that the attribute is
+# unknown, don't try to call has_attr on the failed result value
+# 20091125 MJD
+use DBI;
+my $dbh = DBI->connect("DBI:CSV:f_dir=test_db;csv_eol=\n");
+CIPRES::TreeBase::VeryBadORM->set_db_connection($dbh);
+
+ok(! TestObject->has_subobject("poo"), "foreign_key method failure");
+
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <rv...@us...> - 2009-12-09 16:07:35
|
Revision: 339
http://treebase.svn.sourceforge.net/treebase/?rev=339&view=rev
Author: rvos
Date: 2009-12-09 16:06:08 +0000 (Wed, 09 Dec 2009)
Log Message:
-----------
Working on issue 2903251
Modified Paths:
--------------
trunk/treebase-core/src/main/perl/bin/undump
trunk/treebase-core/src/main/perl/misc/publish
Modified: trunk/treebase-core/src/main/perl/bin/undump
===================================================================
--- trunk/treebase-core/src/main/perl/bin/undump 2009-12-09 14:56:56 UTC (rev 338)
+++ trunk/treebase-core/src/main/perl/bin/undump 2009-12-09 16:06:08 UTC (rev 339)
@@ -9,7 +9,7 @@
$commit_batch_size ||= $opt{n};
my $BEGIN = "BEGIN TRANSACTION;\n";
-$BEGIN .= "SET CONSTAINTS ALL DEFERRED;\n" if $opt{d};
+$BEGIN .= "SET CONSTRAINTS ALL DEFERRED;\n" if $opt{d};
my $OK = 1;
Modified: trunk/treebase-core/src/main/perl/misc/publish
===================================================================
--- trunk/treebase-core/src/main/perl/misc/publish 2009-12-09 14:56:56 UTC (rev 338)
+++ trunk/treebase-core/src/main/perl/misc/publish 2009-12-09 16:06:08 UTC (rev 339)
@@ -26,6 +26,10 @@
TARGET_DIR="treebase-web"
IP_ADDR=`curl -s checkip.dyndns.org | grep -Eo '[0-9\.]+'`
+# Need to set this for mesquite, in case we're launching
+# on servers that don't have X11 configure
+export DISPLAY=:0.0
+
# Flag to suppress sourre update and rebuilding
update_sources=true
if [ "$1" == "-r" ]; then
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <rv...@us...> - 2011-05-26 19:00:41
|
Revision: 883
http://treebase.svn.sourceforge.net/treebase/?rev=883&view=rev
Author: rvos
Date: 2011-05-26 19:00:34 +0000 (Thu, 26 May 2011)
Log Message:
-----------
Adding scripts to create and test DBIx::Class ORM mapping generation
Added Paths:
-----------
trunk/treebase-core/src/main/perl/orm/
trunk/treebase-core/src/main/perl/orm/maketreebase.pl
trunk/treebase-core/src/main/perl/orm/testtreebase.pl
Added: trunk/treebase-core/src/main/perl/orm/maketreebase.pl
===================================================================
--- trunk/treebase-core/src/main/perl/orm/maketreebase.pl (rev 0)
+++ trunk/treebase-core/src/main/perl/orm/maketreebase.pl 2011-05-26 19:00:34 UTC (rev 883)
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use DBIx::Class::Schema::Loader qw/make_schema_at/;
+
+my $dbname = 'treebasedev';
+my $host = 'treebasedb-dev.nescent.org';
+my $user = 'treebase_app';
+my $pass = 'tim5tema';
+make_schema_at(
+ 'Bio::Phylo::TreeBASE',
+ {
+ 'debug' => 1,
+ 'dump_directory' => './lib',
+ },
+ [
+ "dbi:Pg:dbname=$dbname;host=$host",
+ $user,
+ $pass,
+ ],
+);
\ No newline at end of file
Added: trunk/treebase-core/src/main/perl/orm/testtreebase.pl
===================================================================
--- trunk/treebase-core/src/main/perl/orm/testtreebase.pl (rev 0)
+++ trunk/treebase-core/src/main/perl/orm/testtreebase.pl 2011-05-26 19:00:34 UTC (rev 883)
@@ -0,0 +1,85 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Bio::Phylo::TreeBASE;
+use Bio::Phylo::Util::Logger ':levels';
+use Bio::Phylo::Factory;
+use Data::Dumper;
+
+my $fac = Bio::Phylo::Factory->new;
+my $logger = Bio::Phylo::Util::Logger->new;
+
+my $dbname = 'treebasedev';
+my $host = 'treebasedb-dev.nescent.org';
+my $user = 'treebase_app';
+my $pass = 'tim5tema';
+
+my $tb = Bio::Phylo::TreeBASE->connect(
+ "dbi:Pg:dbname=$dbname;host=$host",
+ $user,
+ $pass,
+ { AutoCommit => 0 },
+);
+
+my @matrices = $tb->resultset('Matrix')->search_literal(
+ 'ntax > ? AND nchar > ?', qw/3 20/);
+
+my ( @studies, %seen_tree );
+MATRIX: for my $matrix ( @matrices ) {
+ my $matrix_id = $matrix->matrix_id;
+ my $type = $matrix->get_type;
+ if ( $type ne 'Dna' ) {
+ warn "Matrix $matrix_id is ${type}, not Dna";
+ next MATRIX;
+ }
+ if ( -e "nexus/${matrix_id}.nex" ) {
+ warn "Matrix $matrix_id has already been written out";
+ next MATRIX;
+ }
+ for my $data ( $matrix->analyzeddatas ) {
+ if ( $data->input ) {
+ my $step = $data->analysisstep;
+ for my $other_data ( $step->analyzeddatas ) {
+ if ( not $other_data->input ) {
+ if ( $other_data->type eq 'T' ) {
+ my $tree = $other_data->phylotree;
+ my $tree_id = $tree->phylotree_id;
+ if ( not $seen_tree{ $tree_id } ) {
+ $seen_tree{ $tree_id } = 1;
+ write_study($matrix_id,$tree_id);
+ warn "found tree $tree_id";
+ }
+ else {
+ warn "already seen tree $tree_id";
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+sub write_study {
+ my ( $matrix_id, $tree_id ) = @_;
+ my $template = 'http://purl.org/phylo/treebase/phylows/%s/TB2:%s?format=nexus';
+
+ # download tree
+ my $tree_file = "nexus/M${matrix_id}-Tr${tree_id}.tre";
+ my $tree_url = sprintf($template,"tree","Tr${tree_id}");
+ if ( system('wget','-O',$tree_file,$tree_url) == 0 ) {
+ warn "downloaded $tree_file from $tree_url";
+ }
+ else {
+ warn "problem: $?";
+ }
+
+ # download matrix
+ my $matrix_file = "nexus/M${matrix_id}.nex";
+ my $matrix_url = sprintf($template,"matrix","M${matrix_id}");
+ if ( system('wget','-O',$matrix_file,$matrix_url) == 0 ) {
+ warn "downloaded $matrix_file from $matrix_url";
+ }
+ else {
+ warn "problem: $?";
+ }
+}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X