Menu
▾
▴
[Treebase-guts] SF.net SVN: treebase:[229] trunk/treebase-core/src/main
|
From: <rv...@us...> - 2009-11-01 22:31:37
|
Revision: 229
http://treebase.svn.sourceforge.net/treebase/?rev=229&view=rev
Author: rvos
Date: 2009-11-01 22:31:20 +0000 (Sun, 01 Nov 2009)
Log Message:
-----------
reverting deletion of perl subtree. this folder structure contains scripts and supporting libraries for loading database dumps, checking for database consistency, running generic java classes and sql statements etc. this code is almost entirely due to mjdominus (who has left the project).
Added Paths:
-----------
trunk/treebase-core/src/main/perl/
trunk/treebase-core/src/main/perl/bin/
trunk/treebase-core/src/main/perl/bin/check
trunk/treebase-core/src/main/perl/bin/digester
trunk/treebase-core/src/main/perl/bin/dosql
trunk/treebase-core/src/main/perl/bin/findby
trunk/treebase-core/src/main/perl/bin/gc
trunk/treebase-core/src/main/perl/bin/publish
trunk/treebase-core/src/main/perl/bin/sel
trunk/treebase-core/src/main/perl/bin/show
trunk/treebase-core/src/main/perl/bin/sqldump
trunk/treebase-core/src/main/perl/bin/tbo
trunk/treebase-core/src/main/perl/bin/td
trunk/treebase-core/src/main/perl/bin/undump
trunk/treebase-core/src/main/perl/check/
trunk/treebase-core/src/main/perl/check/check
trunk/treebase-core/src/main/perl/check/digester
trunk/treebase-core/src/main/perl/check/gc
trunk/treebase-core/src/main/perl/dump/
trunk/treebase-core/src/main/perl/dump/dosql
trunk/treebase-core/src/main/perl/dump/findby
trunk/treebase-core/src/main/perl/dump/iq
trunk/treebase-core/src/main/perl/dump/loadspeed
trunk/treebase-core/src/main/perl/dump/sel
trunk/treebase-core/src/main/perl/dump/show
trunk/treebase-core/src/main/perl/dump/showanalyses
trunk/treebase-core/src/main/perl/dump/showmatrices
trunk/treebase-core/src/main/perl/dump/showmatrix
trunk/treebase-core/src/main/perl/dump/showtree
trunk/treebase-core/src/main/perl/dump/showtrees
trunk/treebase-core/src/main/perl/dump/sqldump
trunk/treebase-core/src/main/perl/dump/tbo
trunk/treebase-core/src/main/perl/dump/td
trunk/treebase-core/src/main/perl/jrun
trunk/treebase-core/src/main/perl/lib/
trunk/treebase-core/src/main/perl/lib/CIPRES/
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/DBILogin.pm
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/DBIUtil.pm
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
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/misc/
trunk/treebase-core/src/main/perl/misc/build_and_deploy_treebase.sh
trunk/treebase-core/src/main/perl/misc/fix-sequence
trunk/treebase-core/src/main/perl/misc/kill-jrun
trunk/treebase-core/src/main/perl/misc/publish
trunk/treebase-core/src/main/perl/misc/upload-manager
Removed Paths:
-------------
trunk/treebase-core/src/main/perl/bin/
trunk/treebase-core/src/main/perl/bin/check
trunk/treebase-core/src/main/perl/bin/digester
trunk/treebase-core/src/main/perl/bin/dosql
trunk/treebase-core/src/main/perl/bin/findby
trunk/treebase-core/src/main/perl/bin/gc
trunk/treebase-core/src/main/perl/bin/publish
trunk/treebase-core/src/main/perl/bin/sel
trunk/treebase-core/src/main/perl/bin/show
trunk/treebase-core/src/main/perl/bin/sqldump
trunk/treebase-core/src/main/perl/bin/tbo
trunk/treebase-core/src/main/perl/bin/td
trunk/treebase-core/src/main/perl/bin/undump
trunk/treebase-core/src/main/perl/check/
trunk/treebase-core/src/main/perl/check/check
trunk/treebase-core/src/main/perl/check/digester
trunk/treebase-core/src/main/perl/check/gc
trunk/treebase-core/src/main/perl/dump/
trunk/treebase-core/src/main/perl/dump/dosql
trunk/treebase-core/src/main/perl/dump/findby
trunk/treebase-core/src/main/perl/dump/iq
trunk/treebase-core/src/main/perl/dump/loadspeed
trunk/treebase-core/src/main/perl/dump/sel
trunk/treebase-core/src/main/perl/dump/show
trunk/treebase-core/src/main/perl/dump/showanalyses
trunk/treebase-core/src/main/perl/dump/showmatrices
trunk/treebase-core/src/main/perl/dump/showmatrix
trunk/treebase-core/src/main/perl/dump/showtree
trunk/treebase-core/src/main/perl/dump/showtrees
trunk/treebase-core/src/main/perl/dump/sqldump
trunk/treebase-core/src/main/perl/dump/tbo
trunk/treebase-core/src/main/perl/dump/td
trunk/treebase-core/src/main/perl/jrun
trunk/treebase-core/src/main/perl/lib/
trunk/treebase-core/src/main/perl/lib/CIPRES/
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/DBILogin.pm
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/DBIUtil.pm
trunk/treebase-core/src/main/perl/lib/CIPRES/TreeBase/RecDumper.pm
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/misc/
trunk/treebase-core/src/main/perl/misc/build_and_deploy_treebase.sh
trunk/treebase-core/src/main/perl/misc/fix-sequence
trunk/treebase-core/src/main/perl/misc/kill-jrun
trunk/treebase-core/src/main/perl/misc/publish
trunk/treebase-core/src/main/perl/misc/upload-manager
Deleted: trunk/treebase-core/src/main/perl/bin/check
===================================================================
--- trunk/treebase-core/src/main/perl/bin/check 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/check 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../check/check
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/check (from rev 212, trunk/treebase-core/src/main/perl/bin/check)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/check (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/check 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../check/check
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/digester
===================================================================
--- trunk/treebase-core/src/main/perl/bin/digester 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/digester 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../check/digester
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/digester (from rev 212, trunk/treebase-core/src/main/perl/bin/digester)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/digester (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/digester 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../check/digester
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/dosql
===================================================================
--- trunk/treebase-core/src/main/perl/bin/dosql 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/dosql 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/dosql
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/dosql (from rev 212, trunk/treebase-core/src/main/perl/bin/dosql)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/dosql (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/dosql 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/dosql
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/findby
===================================================================
--- trunk/treebase-core/src/main/perl/bin/findby 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/findby 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/findby
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/findby (from rev 212, trunk/treebase-core/src/main/perl/bin/findby)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/findby (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/findby 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/findby
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/gc
===================================================================
--- trunk/treebase-core/src/main/perl/bin/gc 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/gc 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../check/gc
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/gc (from rev 212, trunk/treebase-core/src/main/perl/bin/gc)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/gc (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/gc 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../check/gc
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/publish
===================================================================
--- trunk/treebase-core/src/main/perl/bin/publish 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/publish 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../misc/publish
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/publish (from rev 212, trunk/treebase-core/src/main/perl/bin/publish)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/publish (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/publish 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../misc/publish
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/sel
===================================================================
--- trunk/treebase-core/src/main/perl/bin/sel 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/sel 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/sel
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/sel (from rev 212, trunk/treebase-core/src/main/perl/bin/sel)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/sel (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/sel 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/sel
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/show
===================================================================
--- trunk/treebase-core/src/main/perl/bin/show 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/show 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/show
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/show (from rev 212, trunk/treebase-core/src/main/perl/bin/show)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/show (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/show 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/show
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/sqldump
===================================================================
--- trunk/treebase-core/src/main/perl/bin/sqldump 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/sqldump 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/sqldump
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/sqldump (from rev 212, trunk/treebase-core/src/main/perl/bin/sqldump)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/sqldump (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/sqldump 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/sqldump
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/tbo
===================================================================
--- trunk/treebase-core/src/main/perl/bin/tbo 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/tbo 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/tbo
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/tbo (from rev 212, trunk/treebase-core/src/main/perl/bin/tbo)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/tbo (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/tbo 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/tbo
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/td
===================================================================
--- trunk/treebase-core/src/main/perl/bin/td 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/td 2009-11-01 22:31:20 UTC (rev 229)
@@ -1 +0,0 @@
-link ../dump/td
\ No newline at end of file
Copied: trunk/treebase-core/src/main/perl/bin/td (from rev 212, trunk/treebase-core/src/main/perl/bin/td)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/td (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/td 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1 @@
+link ../dump/td
\ No newline at end of file
Deleted: trunk/treebase-core/src/main/perl/bin/undump
===================================================================
--- trunk/treebase-core/src/main/perl/bin/undump 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/bin/undump 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,92 +0,0 @@
-#!/usr/bin/perl
-# preprocess DB2 dump files for importation into pg via psql command
-#
-
-use Getopt::Std;
-my $commit_batch_size;
-my @pending; # records read but not written out
-getopts('xdn:', \%opt) or usage();
-$commit_batch_size ||= $opt{n};
-
-my $BEGIN = "BEGIN TRANSACTION;\n";
-$BEGIN .= "SET CONSTAINTS ALL DEFERRED;\n" if $opt{d};
-
-my $OK = 1;
-
-TABLE:
-for my $table (@ARGV) {
- if (-e $table) {
- my $FH;
- unless (open($FH, "<", $table) ) {
- warn "Couldn't open file '$table': $!; skipping\n";
- $OK = 0;
- next TABLE;
- }
- do_table($table, $FH);
- } elsif (-e "$table.gz") {
- my $fh = IO::Zlib->new;
- unless ($fh->open("$table.gz", "rb")) {
- warn "Couldn't open file '$table.gz': $!; skipping\n";
- $OK = 0;
- next TABLE;
- }
- do_table($table, $fh);
- } else {
- warn "Couldn't find dump file for table '$table'; skipping\n";
- $OK = 0;
- }
-}
-
-sub do_table {
- my ($table, $fh) = @_;
- my ($start, $length);
- local *_;
- local *.;
-
- while (<$fh>) {
- if ($. == 1) {
- /INSERT INTO \"/ or die "unparseable";
- $start = $+[0] - 1;
- substr($_, $start) =~ /(.*\)) VALUES \(/ or die "unparseable";
- $length = $+[1];
- die unless defined($start) && defined($length);
- }
-
-
- substr($_, $start, $length) =~ s/"(\w+?)"/"\L$1\E"/g;
-
- if (defined($commit_batch_size)) {
- push @pending, $_;
- if (@pending >= $commit_batch_size) {
- print "BEGIN TRANSACTION;\n", @pending, "COMMIT;\n";
- @pending = ();
- }
- } else {
- print;
- }
- if ($opt{x}) {
- warn "$.\n" if $. % 10_000 == 0;
- }
- }
-
-# possibly a final partial batch
- if (@pending) {
- print "BEGIN TRANSACTION;\n", @pending, "COMMIT;\n";
- @pending = ();
- }
-
- close $fh;
-}
-
-################################################################
-
-sub usage {
- print STDERR qq{Usage: $0 [-dx] [-n batchsize] TABLE...
- -d defer constraint checking to the end of each transaction
- -x print progress information to stderr
- -n batchsize commit records in batches of /batchsize/
-
- records for TABLE are read from file TABLE or from TABLE.gz
-};
- exit 1;
-}
Copied: trunk/treebase-core/src/main/perl/bin/undump (from rev 212, trunk/treebase-core/src/main/perl/bin/undump)
===================================================================
--- trunk/treebase-core/src/main/perl/bin/undump (rev 0)
+++ trunk/treebase-core/src/main/perl/bin/undump 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,92 @@
+#!/usr/bin/perl
+# preprocess DB2 dump files for importation into pg via psql command
+#
+
+use Getopt::Std;
+my $commit_batch_size;
+my @pending; # records read but not written out
+getopts('xdn:', \%opt) or usage();
+$commit_batch_size ||= $opt{n};
+
+my $BEGIN = "BEGIN TRANSACTION;\n";
+$BEGIN .= "SET CONSTAINTS ALL DEFERRED;\n" if $opt{d};
+
+my $OK = 1;
+
+TABLE:
+for my $table (@ARGV) {
+ if (-e $table) {
+ my $FH;
+ unless (open($FH, "<", $table) ) {
+ warn "Couldn't open file '$table': $!; skipping\n";
+ $OK = 0;
+ next TABLE;
+ }
+ do_table($table, $FH);
+ } elsif (-e "$table.gz") {
+ my $fh = IO::Zlib->new;
+ unless ($fh->open("$table.gz", "rb")) {
+ warn "Couldn't open file '$table.gz': $!; skipping\n";
+ $OK = 0;
+ next TABLE;
+ }
+ do_table($table, $fh);
+ } else {
+ warn "Couldn't find dump file for table '$table'; skipping\n";
+ $OK = 0;
+ }
+}
+
+sub do_table {
+ my ($table, $fh) = @_;
+ my ($start, $length);
+ local *_;
+ local *.;
+
+ while (<$fh>) {
+ if ($. == 1) {
+ /INSERT INTO \"/ or die "unparseable";
+ $start = $+[0] - 1;
+ substr($_, $start) =~ /(.*\)) VALUES \(/ or die "unparseable";
+ $length = $+[1];
+ die unless defined($start) && defined($length);
+ }
+
+
+ substr($_, $start, $length) =~ s/"(\w+?)"/"\L$1\E"/g;
+
+ if (defined($commit_batch_size)) {
+ push @pending, $_;
+ if (@pending >= $commit_batch_size) {
+ print "BEGIN TRANSACTION;\n", @pending, "COMMIT;\n";
+ @pending = ();
+ }
+ } else {
+ print;
+ }
+ if ($opt{x}) {
+ warn "$.\n" if $. % 10_000 == 0;
+ }
+ }
+
+# possibly a final partial batch
+ if (@pending) {
+ print "BEGIN TRANSACTION;\n", @pending, "COMMIT;\n";
+ @pending = ();
+ }
+
+ close $fh;
+}
+
+################################################################
+
+sub usage {
+ print STDERR qq{Usage: $0 [-dx] [-n batchsize] TABLE...
+ -d defer constraint checking to the end of each transaction
+ -x print progress information to stderr
+ -n batchsize commit records in batches of /batchsize/
+
+ records for TABLE are read from file TABLE or from TABLE.gz
+};
+ exit 1;
+}
Deleted: trunk/treebase-core/src/main/perl/check/check
===================================================================
--- trunk/treebase-core/src/main/perl/check/check 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/check/check 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,186 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use CIPRES::TreeBase::DBIUtil;
-use CIPRES::TreeBase::TreeBaseObjects;
-use Getopt::Std;
-our $indent = 0;
-
-my $TERMINAL;
-if (-t STDOUT) {
- $| = 1;
- $TERMINAL = 1;
-}
-
-my %opt;
-getopts('chasd:p:RC:X', \%opt) or usage();
-if ($opt{X}) { list_known_classes(); }
-if ($opt{h}) { usage(); }
-if ($opt{R}) {
- if ($opt{d}) { die "-R and -d are incompatible\n"; }
- $opt{d} = 0;
-}
-if ($opt{c}) {
- if ($opt{C}) { die "-c and -C are inconsistent\n"; }
- $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};
-
-if ($opt{s}) {
- # prune out "small" classes
- $prune{$_} = 1 for qw(MatrixRow PhyloTreeNode TaxonLabel MatrixKind TreeType);
-}
-
-my $type = shift or usage();
-my $id = shift or usage();
-$id =~ s/^#//;
-
-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;
-use Carp 'croak';
-sub full_str {
- my $self = shift;
- $self->reify;
- my @keys = sort(grep !/[^A-Z]/, keys %$self);
- my @components = map "$_ => $self->{$_}", @keys;
- return join ", ", @components;
-}
-
-sub attr_check {
- my ($obj, $attr_name, $attr, $warnings) = @_;
-# warn "checking to see that this object has $attr_name = $attr->{$attr_name}\n";
-
- # If $attr is just a scalar, fake up an attr hash with one attribute
- unless (ref $attr) {
- $attr = { $attr_name => $attr };
- }
-
- unless ($warnings || $attr->{warnings}) {
- croak "No warning target variable specified";
- }
-
- return 1 unless exists $attr->{$attr_name};
- if (not defined $obj->$attr_name) {
- # attribute is missing from the object
-
- # ... okay, if it is specifically required to be missing
- return 1 if ! defined $attr->{$attr_name};
-
- # otherwise, record an error
- push @$warnings,
- "Object ". $obj->CIPRES::TreeBase::VeryBadORM::to_str.
- " should have $attr_name = $attr->{$attr_name}, ".
- " but it is missing.";
- return;
- }
-
- return 1 if $obj->$attr_name->id == $attr->{$attr_name};
- push @$warnings,
- "Object ". $obj->CIPRES::TreeBase::VeryBadORM::to_str.
- " should have $attr_name = $attr->{$attr_name}, ".
- " but instead has " . $obj->$attr_name->id;
- return;
-}
-
-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}) : (),
- );
-
-for my $w (@warnings) {
- print STDERR "*** $w\n";
-}
-if (! $OK) {
- warn "Inconsistencies detected\n";
- exit 1;
-} else {
- exit 0;
-}
-
-
-sub prt {
- my ($self, %attr) = @_;
- my $seen = $attr{seen}{$self->class}{$self->id}++;
- my $str = $attr{show_all} ? full_str($self) : $self->to_str;
- my $indent = " " x $attr{depth};
- my $consistent;
-
- my ($class, $id) = ($self->class, $self->id);
-
- if (! $seen) {
- my $z;
- if ($TERMINAL) {
- $z = "(Checking consistency of $class $id.)";
- print $z, "\r";
- }
-
- {
- my $do_check = $all_consistency_checks || $consistency_check{$class};
- $consistent = $do_check ? $self->consistent(%attr) : 1;
- }
-
- $OK &&= $consistent;
- if ($TERMINAL) {
- print " " x length($z), "\r";
- }
- }
-
- unless ($class->is_nested) {
- if (exists $attr{$class} &&
- $attr{$class} != $id) {
- push @{$attr{warnings}}, "** Expected $class $attr{$class}, found $id insead\n";
- }
- }
-
- my $mark = $seen ? "|-" : $consistent ? "| " : "|*";
- return 0 if $attr{prune}{$self->class};
- print "| " x $attr{depth}, "$mark$str\n";
-
- return !$seen;
-}
-
-sub list_known_classes {
- my $kch = CIPRES::TreeBase::VeryBadORM->known_class_hash();
- for my $k (sort values %$kch) {
- print "$k\n";
- }
- exit 0;
-}
-
-sub usage {
- print STDERR qq<Usage: $0 [-X] [-acsR] [-d n] [-pClass1,Class2,...] [-CClasses...] Class IDnumber
-
-Recursively print the contents of the specified object of the
-specified class. For example, "$0 Study 1234" prints out study #1234
-and all of its trees, matrices, analyses, etc., and their contents.
-
-Use "$0 -X" for a list of known classes.
-
-Options:
- -a: show *all* attributes of every object (default: pretty-print objects)
- -s: do not recurse into "small" objects (Currently: MatrixRow,
- PhyloTreeNode, TaxonLabel)
- -R: do not recurse at all, printing only the top object
- -c: Skip all consistency checking
-
- -d n: recurse only n levels deep
-
- -pClasses... : 'prune': do not display or recurse into objects of these
- classes.
- -CClasses... : Perform consistency checking of these classes only
->;
- exit 1;
-}
-
-
-1;
Copied: trunk/treebase-core/src/main/perl/check/check (from rev 212, trunk/treebase-core/src/main/perl/check/check)
===================================================================
--- trunk/treebase-core/src/main/perl/check/check (rev 0)
+++ trunk/treebase-core/src/main/perl/check/check 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,186 @@
+#!/usr/bin/perl
+
+use strict;
+use CIPRES::TreeBase::DBIUtil;
+use CIPRES::TreeBase::TreeBaseObjects;
+use Getopt::Std;
+our $indent = 0;
+
+my $TERMINAL;
+if (-t STDOUT) {
+ $| = 1;
+ $TERMINAL = 1;
+}
+
+my %opt;
+getopts('chasd:p:RC:X', \%opt) or usage();
+if ($opt{X}) { list_known_classes(); }
+if ($opt{h}) { usage(); }
+if ($opt{R}) {
+ if ($opt{d}) { die "-R and -d are incompatible\n"; }
+ $opt{d} = 0;
+}
+if ($opt{c}) {
+ if ($opt{C}) { die "-c and -C are inconsistent\n"; }
+ $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};
+
+if ($opt{s}) {
+ # prune out "small" classes
+ $prune{$_} = 1 for qw(MatrixRow PhyloTreeNode TaxonLabel MatrixKind TreeType);
+}
+
+my $type = shift or usage();
+my $id = shift or usage();
+$id =~ s/^#//;
+
+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;
+use Carp 'croak';
+sub full_str {
+ my $self = shift;
+ $self->reify;
+ my @keys = sort(grep !/[^A-Z]/, keys %$self);
+ my @components = map "$_ => $self->{$_}", @keys;
+ return join ", ", @components;
+}
+
+sub attr_check {
+ my ($obj, $attr_name, $attr, $warnings) = @_;
+# warn "checking to see that this object has $attr_name = $attr->{$attr_name}\n";
+
+ # If $attr is just a scalar, fake up an attr hash with one attribute
+ unless (ref $attr) {
+ $attr = { $attr_name => $attr };
+ }
+
+ unless ($warnings || $attr->{warnings}) {
+ croak "No warning target variable specified";
+ }
+
+ return 1 unless exists $attr->{$attr_name};
+ if (not defined $obj->$attr_name) {
+ # attribute is missing from the object
+
+ # ... okay, if it is specifically required to be missing
+ return 1 if ! defined $attr->{$attr_name};
+
+ # otherwise, record an error
+ push @$warnings,
+ "Object ". $obj->CIPRES::TreeBase::VeryBadORM::to_str.
+ " should have $attr_name = $attr->{$attr_name}, ".
+ " but it is missing.";
+ return;
+ }
+
+ return 1 if $obj->$attr_name->id == $attr->{$attr_name};
+ push @$warnings,
+ "Object ". $obj->CIPRES::TreeBase::VeryBadORM::to_str.
+ " should have $attr_name = $attr->{$attr_name}, ".
+ " but instead has " . $obj->$attr_name->id;
+ return;
+}
+
+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}) : (),
+ );
+
+for my $w (@warnings) {
+ print STDERR "*** $w\n";
+}
+if (! $OK) {
+ warn "Inconsistencies detected\n";
+ exit 1;
+} else {
+ exit 0;
+}
+
+
+sub prt {
+ my ($self, %attr) = @_;
+ my $seen = $attr{seen}{$self->class}{$self->id}++;
+ my $str = $attr{show_all} ? full_str($self) : $self->to_str;
+ my $indent = " " x $attr{depth};
+ my $consistent;
+
+ my ($class, $id) = ($self->class, $self->id);
+
+ if (! $seen) {
+ my $z;
+ if ($TERMINAL) {
+ $z = "(Checking consistency of $class $id.)";
+ print $z, "\r";
+ }
+
+ {
+ my $do_check = $all_consistency_checks || $consistency_check{$class};
+ $consistent = $do_check ? $self->consistent(%attr) : 1;
+ }
+
+ $OK &&= $consistent;
+ if ($TERMINAL) {
+ print " " x length($z), "\r";
+ }
+ }
+
+ unless ($class->is_nested) {
+ if (exists $attr{$class} &&
+ $attr{$class} != $id) {
+ push @{$attr{warnings}}, "** Expected $class $attr{$class}, found $id insead\n";
+ }
+ }
+
+ my $mark = $seen ? "|-" : $consistent ? "| " : "|*";
+ return 0 if $attr{prune}{$self->class};
+ print "| " x $attr{depth}, "$mark$str\n";
+
+ return !$seen;
+}
+
+sub list_known_classes {
+ my $kch = CIPRES::TreeBase::VeryBadORM->known_class_hash();
+ for my $k (sort values %$kch) {
+ print "$k\n";
+ }
+ exit 0;
+}
+
+sub usage {
+ print STDERR qq<Usage: $0 [-X] [-acsR] [-d n] [-pClass1,Class2,...] [-CClasses...] Class IDnumber
+
+Recursively print the contents of the specified object of the
+specified class. For example, "$0 Study 1234" prints out study #1234
+and all of its trees, matrices, analyses, etc., and their contents.
+
+Use "$0 -X" for a list of known classes.
+
+Options:
+ -a: show *all* attributes of every object (default: pretty-print objects)
+ -s: do not recurse into "small" objects (Currently: MatrixRow,
+ PhyloTreeNode, TaxonLabel)
+ -R: do not recurse at all, printing only the top object
+ -c: Skip all consistency checking
+
+ -d n: recurse only n levels deep
+
+ -pClasses... : 'prune': do not display or recurse into objects of these
+ classes.
+ -CClasses... : Perform consistency checking of these classes only
+>;
+ exit 1;
+}
+
+
+1;
Deleted: trunk/treebase-core/src/main/perl/check/digester
===================================================================
--- trunk/treebase-core/src/main/perl/check/digester 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/check/digester 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,49 +0,0 @@
-#!/usr/bin/perl
-#
-# Digest reports that come out of the checker:
-# grep out all the lines that begin with '***'
-# pass them through this program
-# This program will sort each different kind of message into a separate file
-# To have the files placed in some other directory, use the -d option
-# 20090327 MJD
-#
-
-use Getopt::Std;
-my %opt = (d => ".");
-getopts('d:', \%opt) or die;
--d($opt{d}) || mkdir($opt{d}) || die "$opt{d}: $!";
-
-while (<>) {
- chomp;
- my $k = $_;
- $k =~ s/\d+/#/g;
- $k =~ s/#(\s*#)+/##/g;
- $k =~ s/^S#:\s+//;
- push @{$msg{$k}}, $_;
-}
-
-for my $k (keys %msg) {
- my $f = abbr($k);
- open my($fh), ">", "$opt{d}/$f" or die "$opt{d}/$f: $!";
- print $fh $_, "\n" for @{$msg{$k}};
- close $fh;
-}
-
-my $q;
-BEGIN { $q = 1 };
-my %seen;
-
-sub abbr {
- my $s = shift;
- $s =~ tr/A-Z /a-z_/;
- $s =~ tr/A-Za-z_//cd;
- $s =~ tr/_/_/s;
- $s =~ s/^_//;
-
- substr($s, 30) = "" if length($s) > 30;
- if ($seen{$s}) {
- $s .= $q++;
- }
- return $s;
-}
-
Copied: trunk/treebase-core/src/main/perl/check/digester (from rev 212, trunk/treebase-core/src/main/perl/check/digester)
===================================================================
--- trunk/treebase-core/src/main/perl/check/digester (rev 0)
+++ trunk/treebase-core/src/main/perl/check/digester 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,49 @@
+#!/usr/bin/perl
+#
+# Digest reports that come out of the checker:
+# grep out all the lines that begin with '***'
+# pass them through this program
+# This program will sort each different kind of message into a separate file
+# To have the files placed in some other directory, use the -d option
+# 20090327 MJD
+#
+
+use Getopt::Std;
+my %opt = (d => ".");
+getopts('d:', \%opt) or die;
+-d($opt{d}) || mkdir($opt{d}) || die "$opt{d}: $!";
+
+while (<>) {
+ chomp;
+ my $k = $_;
+ $k =~ s/\d+/#/g;
+ $k =~ s/#(\s*#)+/##/g;
+ $k =~ s/^S#:\s+//;
+ push @{$msg{$k}}, $_;
+}
+
+for my $k (keys %msg) {
+ my $f = abbr($k);
+ open my($fh), ">", "$opt{d}/$f" or die "$opt{d}/$f: $!";
+ print $fh $_, "\n" for @{$msg{$k}};
+ close $fh;
+}
+
+my $q;
+BEGIN { $q = 1 };
+my %seen;
+
+sub abbr {
+ my $s = shift;
+ $s =~ tr/A-Z /a-z_/;
+ $s =~ tr/A-Za-z_//cd;
+ $s =~ tr/_/_/s;
+ $s =~ s/^_//;
+
+ substr($s, 30) = "" if length($s) > 30;
+ if ($seen{$s}) {
+ $s .= $q++;
+ }
+ return $s;
+}
+
Deleted: trunk/treebase-core/src/main/perl/check/gc
===================================================================
--- trunk/treebase-core/src/main/perl/check/gc 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/check/gc 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,90 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use CIPRES::TreeBase::DBIUtil;
-use CIPRES::TreeBase::TreeBaseObjects;
-use Getopt::Std;
-use Carp 'croak';
-
-# $seen{$class}{$id} is 0 if the object was in the DB but unreferenced
-# 1 if the object was in the DB and referenced
-my %SEEN = ();
-my $count = 0;
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-CIPRES::TreeBase::TreeBaseObjects->set_db_connection($dbh);
-
-my @CLASSES = qw(Analysis AnalysisStep AnalyzedData
- Matrix MatrixRow
- PhyloTree PhyloTreeNode
- Study
- TaxonLabel
- );
-
-
-for my $class (@CLASSES) {
- for my $id (get_all_ids($class)) {
- $SEEN{$class}{$id} = 0;
- }
- warn "Database contains ", scalar(keys %{$SEEN{$class}}), " $class items\n";
-}
-
-for my $study (map {Study->new($_)} keys %{$SEEN{Study}}) {
- next if $SEEN{Study}{$study->id}++;
- my $N = $study->analyzed_data;
- my $PREFIX = "S" . $study->id;
- print STDERR $PREFIX;
- my $C = 0;
-
- for my $analysis ($study->analyses) {
- next if $SEEN{Analysis}{$analysis->id}++;
- for my $astep ($analysis->analysissteps) {
- next if $SEEN{AnalysisStep}{$astep->id}++;
- for my $adata ($astep->analyzeddata) {
- next if $SEEN{AnalyzedData}{$adata->id}++;
- $C++;
- print STDERR " $C/$N\r$PREFIX";
- if (my $matrix = $adata->matrix) {
- next if $SEEN{Matrix}{$matrix->id}++;
- for my $row ($matrix->rows) {
- next if $SEEN{MatrixRow}{$row->id}++;
- $SEEN{TaxonLabel}{$row->taxonlabel->id} = 1 if $row->taxonlabel
- }
- } elsif (my $tree = $adata->phylotree) {
- for my $node ($tree->nodes) {
- next if $SEEN{PhyloTreeNode}{$node->id}++;
- $SEEN{TaxonLabel}{$node->taxonlabel->id} = 1 if $node->taxonlabel
- }
- }
- }
- }
- }
- print STDERR "\n";
-}
-
-for my $class (sort keys %SEEN) {
- my $classHash = $SEEN{$class};
- for my $id (sort {$a <=> $b} keys %$classHash) {
- if ($classHash->{$id} == 0) {
- print "* $class $id\n";
- }
- }
-}
-
-
-sub get_all_ids {
- my $class = shift;
- my $table = $class->table or croak "Unknown object class '$class'";
- my $id_attr = $class->id_attr or croak "Unknown object class '$class'";
- my $sql = "select $id_attr from $table";
- my $ids = $dbh->selectcol_arrayref($sql);
- return wantarray ? @$ids : $ids;
-}
-
-sub get_all {
- my $class = shift;
- my @ids = sort {$a<=>$b} get_all_ids($class);
- my @objs = map { $class->new($_) } @ids;
- return wantarray ? @objs : \@objs;
-}
Copied: trunk/treebase-core/src/main/perl/check/gc (from rev 212, trunk/treebase-core/src/main/perl/check/gc)
===================================================================
--- trunk/treebase-core/src/main/perl/check/gc (rev 0)
+++ trunk/treebase-core/src/main/perl/check/gc 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,90 @@
+#!/usr/bin/perl
+
+use strict;
+use CIPRES::TreeBase::DBIUtil;
+use CIPRES::TreeBase::TreeBaseObjects;
+use Getopt::Std;
+use Carp 'croak';
+
+# $seen{$class}{$id} is 0 if the object was in the DB but unreferenced
+# 1 if the object was in the DB and referenced
+my %SEEN = ();
+my $count = 0;
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+CIPRES::TreeBase::TreeBaseObjects->set_db_connection($dbh);
+
+my @CLASSES = qw(Analysis AnalysisStep AnalyzedData
+ Matrix MatrixRow
+ PhyloTree PhyloTreeNode
+ Study
+ TaxonLabel
+ );
+
+
+for my $class (@CLASSES) {
+ for my $id (get_all_ids($class)) {
+ $SEEN{$class}{$id} = 0;
+ }
+ warn "Database contains ", scalar(keys %{$SEEN{$class}}), " $class items\n";
+}
+
+for my $study (map {Study->new($_)} keys %{$SEEN{Study}}) {
+ next if $SEEN{Study}{$study->id}++;
+ my $N = $study->analyzed_data;
+ my $PREFIX = "S" . $study->id;
+ print STDERR $PREFIX;
+ my $C = 0;
+
+ for my $analysis ($study->analyses) {
+ next if $SEEN{Analysis}{$analysis->id}++;
+ for my $astep ($analysis->analysissteps) {
+ next if $SEEN{AnalysisStep}{$astep->id}++;
+ for my $adata ($astep->analyzeddata) {
+ next if $SEEN{AnalyzedData}{$adata->id}++;
+ $C++;
+ print STDERR " $C/$N\r$PREFIX";
+ if (my $matrix = $adata->matrix) {
+ next if $SEEN{Matrix}{$matrix->id}++;
+ for my $row ($matrix->rows) {
+ next if $SEEN{MatrixRow}{$row->id}++;
+ $SEEN{TaxonLabel}{$row->taxonlabel->id} = 1 if $row->taxonlabel
+ }
+ } elsif (my $tree = $adata->phylotree) {
+ for my $node ($tree->nodes) {
+ next if $SEEN{PhyloTreeNode}{$node->id}++;
+ $SEEN{TaxonLabel}{$node->taxonlabel->id} = 1 if $node->taxonlabel
+ }
+ }
+ }
+ }
+ }
+ print STDERR "\n";
+}
+
+for my $class (sort keys %SEEN) {
+ my $classHash = $SEEN{$class};
+ for my $id (sort {$a <=> $b} keys %$classHash) {
+ if ($classHash->{$id} == 0) {
+ print "* $class $id\n";
+ }
+ }
+}
+
+
+sub get_all_ids {
+ my $class = shift;
+ my $table = $class->table or croak "Unknown object class '$class'";
+ my $id_attr = $class->id_attr or croak "Unknown object class '$class'";
+ my $sql = "select $id_attr from $table";
+ my $ids = $dbh->selectcol_arrayref($sql);
+ return wantarray ? @$ids : $ids;
+}
+
+sub get_all {
+ my $class = shift;
+ my @ids = sort {$a<=>$b} get_all_ids($class);
+ my @objs = map { $class->new($_) } @ids;
+ return wantarray ? @objs : \@objs;
+}
Deleted: trunk/treebase-core/src/main/perl/dump/dosql
===================================================================
--- trunk/treebase-core/src/main/perl/dump/dosql 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/dosql 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,25 +0,0 @@
-#!/usr/bin/perl
-
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-
-getopts('s') or die "Usage: $0 SQL statement on command line";
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-
-if ($opt_s) {
- my @statements = split /;[ \t]*\r?\n/, join "", <ARGV>;
- for my $Q (@statements) {
- next unless $Q =~ /\S/;
- print "$Q\n";
- $dbh->do($Q)
- or die "Couldn't prepare statement:\n\t$Q\n\t" . $dbh->errstr;
- }
-} else {
- my $Q = join " ", @ARGV;
- $dbh->do($Q)
- or die "Couldn't prepare statement: " . $dbh->errstr;
-}
-
-$dbh->disconnect;
Copied: trunk/treebase-core/src/main/perl/dump/dosql (from rev 212, trunk/treebase-core/src/main/perl/dump/dosql)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/dosql (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/dosql 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+
+getopts('s') or die "Usage: $0 SQL statement on command line";
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+
+if ($opt_s) {
+ my @statements = split /;[ \t]*\r?\n/, join "", <ARGV>;
+ for my $Q (@statements) {
+ next unless $Q =~ /\S/;
+ print "$Q\n";
+ $dbh->do($Q)
+ or die "Couldn't prepare statement:\n\t$Q\n\t" . $dbh->errstr;
+ }
+} else {
+ my $Q = join " ", @ARGV;
+ $dbh->do($Q)
+ or die "Couldn't prepare statement: " . $dbh->errstr;
+}
+
+$dbh->disconnect;
Deleted: trunk/treebase-core/src/main/perl/dump/findby
===================================================================
--- trunk/treebase-core/src/main/perl/dump/findby 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/findby 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,31 +0,0 @@
-#!/usr/bin/perl
-# -*- cperl -*-
-
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-
-my %opt = ();
-getopts('', \%opt) or usage();
-my ($class, $attr, $val) = @ARGV;
-defined($class) && defined($attr) && defined($val) or usage();
-
-my $query = "select $class\_id from $class where $attr = ?";
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-my $sth = $dbh->prepare($query)
- or die "Couldn't prepare statement: " . $dbh->errstr;
-my $rc = $sth->execute($val)
- or die "Couldn't execute statement: " . $dbh->errstr;
-my $row;
-while (my ($id) = $sth->fetchrow_array) {
- print "$id\n";
-}
-
-$dbh->disconnect;
-
-sub usage {
- print "$0 [-n nullsymbol] table id#\n";
- exit 1;
-}
-
Copied: trunk/treebase-core/src/main/perl/dump/findby (from rev 212, trunk/treebase-core/src/main/perl/dump/findby)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/findby (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/findby 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+# -*- cperl -*-
+
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+
+my %opt = ();
+getopts('', \%opt) or usage();
+my ($class, $attr, $val) = @ARGV;
+defined($class) && defined($attr) && defined($val) or usage();
+
+my $query = "select $class\_id from $class where $attr = ?";
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+my $sth = $dbh->prepare($query)
+ or die "Couldn't prepare statement: " . $dbh->errstr;
+my $rc = $sth->execute($val)
+ or die "Couldn't execute statement: " . $dbh->errstr;
+my $row;
+while (my ($id) = $sth->fetchrow_array) {
+ print "$id\n";
+}
+
+$dbh->disconnect;
+
+sub usage {
+ print "$0 [-n nullsymbol] table id#\n";
+ exit 1;
+}
+
Deleted: trunk/treebase-core/src/main/perl/dump/iq
===================================================================
--- trunk/treebase-core/src/main/perl/dump/iq 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/iq 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,140 +0,0 @@
-#!/usr/bin/perl
-# -*- cperl -*-
-
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-use Text::ParseWords;
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-$dbh->{RaiseError} = undef;
-$dbh->{PrintError} = 'on';
-
-my %opt = (e => $ENV{IQEDITOR} || $ENV{VISUAL} || $ENV{EDITOR} || "vi",
- m => 20,
- n => "--",
- );
-getopts('e:m:n:', \%opt) or usage();
-
-my $query = "";
-my $sth;
-my $editor = $opt{e};
-my $maxrows = $opt{m};
-my @rows;
-
-while (1) {
-# print $query, "\n" if $query;
- print "> ";
- my $r = <>;
- trim($r);
- last if $r eq "";
-
- if ($r eq "e") {
- $query = edit($query);
- print "$query\n";
- $sth = maybe_run_query($query);
- } elsif (my ($pat, $rep, $g) = ($r =~ m{s/(.*)/(.*)/(g?)})) {
- if ($g) {
- $query =~ s/$pat/$rep/g;
- } else {
- $query =~ s/$pat/$rep/;
- }
- $sth = maybe_run_query($query);
- } elsif ($r =~ s/^x\s*//) {
- (my $q = $query) =~ tr/\n/ /;
- compile_query($query) unless defined $sth;
- run_query($sth, shellwords($r));
- } elsif ($r eq "p") {
- print_aoh(\@rows, $opt_n);
- } elsif ($r =~ s/^w\s*//) {
- if (open my($f), ">", $r) {
- my $ofh = select $f;
- print_aoh(\@rows, $opt_n);
- select $ofh;
- } else {
- warn "Couldn't open '$r' for writing: $!\n";
- }
- } else {
- $query = $r;
- $sth = maybe_run_query($query);
- }
-}
-
-exit;
-
-################################################################
-
-sub compile_query {
- my $query = shift;
- $query =~ tr/\n/ /;
- my $_sth;
- eval {
- $_sth = $dbh->prepare($query);
- };
- if ($_sth) {
- $sth = $_sth;
- } else {
- warn $dbh->errstr . "\n";
- }
- return defined($_sth);
-}
-
-sub maybe_run_query {
- eval {
- my $query = shift;
- compile_query($query) or return;
-
- return unless $sth->{NUM_OF_PARAMS} == 0;
-
-
- run_query($sth);
- return $sth;
- };
-}
-
-sub run_query {
- my $sth = shift;
- return unless defined $sth;
- my @params = @_;
- my @_rows;
-
- warn "Executing...\n";
- $sth->execute(@params) or return;
- while (my $row = $sth->fetchrow_hashref) {
- push @_rows, {%$row};
- }
-
-
- $sth->finish;
- if (@_rows == 0) {
- print "Empty result.\n";
- return;
- } elsif (@_rows <= $maxrows) {
- print_aoh(\@rows, $opt_n);
- } else {
- print "result: " . @_rows . " rows; use 'p' to display\n";
- }
- @rows = @_rows;
-}
-
-sub edit {
- my $tmp = "/tmp/iq.$$";
- my $data = shift;
- $data .= "\n" unless $data =~ /\n\z/;
- open my($f), ">", $tmp or die "Couldn't write temp file '$tmp': $!";
- print $f $data;
- close $f;
- if (system($editor, $tmp) == 0) {
- open my($f), "<", $tmp or die "Couldn't read modified temp file '$tmp': $!";
- $data = join "", <$f>;
- } else {
- warn "Editor failed; ignoring changes\n";
- }
- unlink $tmp;
- return $data;
-}
-
-sub trim {
- $_[0] =~ s/^\s+//;
- $_[0] =~ s/\s+$//;
-}
Copied: trunk/treebase-core/src/main/perl/dump/iq (from rev 212, trunk/treebase-core/src/main/perl/dump/iq)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/iq (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/iq 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,140 @@
+#!/usr/bin/perl
+# -*- cperl -*-
+
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+use Text::ParseWords;
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+$dbh->{RaiseError} = undef;
+$dbh->{PrintError} = 'on';
+
+my %opt = (e => $ENV{IQEDITOR} || $ENV{VISUAL} || $ENV{EDITOR} || "vi",
+ m => 20,
+ n => "--",
+ );
+getopts('e:m:n:', \%opt) or usage();
+
+my $query = "";
+my $sth;
+my $editor = $opt{e};
+my $maxrows = $opt{m};
+my @rows;
+
+while (1) {
+# print $query, "\n" if $query;
+ print "> ";
+ my $r = <>;
+ trim($r);
+ last if $r eq "";
+
+ if ($r eq "e") {
+ $query = edit($query);
+ print "$query\n";
+ $sth = maybe_run_query($query);
+ } elsif (my ($pat, $rep, $g) = ($r =~ m{s/(.*)/(.*)/(g?)})) {
+ if ($g) {
+ $query =~ s/$pat/$rep/g;
+ } else {
+ $query =~ s/$pat/$rep/;
+ }
+ $sth = maybe_run_query($query);
+ } elsif ($r =~ s/^x\s*//) {
+ (my $q = $query) =~ tr/\n/ /;
+ compile_query($query) unless defined $sth;
+ run_query($sth, shellwords($r));
+ } elsif ($r eq "p") {
+ print_aoh(\@rows, $opt_n);
+ } elsif ($r =~ s/^w\s*//) {
+ if (open my($f), ">", $r) {
+ my $ofh = select $f;
+ print_aoh(\@rows, $opt_n);
+ select $ofh;
+ } else {
+ warn "Couldn't open '$r' for writing: $!\n";
+ }
+ } else {
+ $query = $r;
+ $sth = maybe_run_query($query);
+ }
+}
+
+exit;
+
+################################################################
+
+sub compile_query {
+ my $query = shift;
+ $query =~ tr/\n/ /;
+ my $_sth;
+ eval {
+ $_sth = $dbh->prepare($query);
+ };
+ if ($_sth) {
+ $sth = $_sth;
+ } else {
+ warn $dbh->errstr . "\n";
+ }
+ return defined($_sth);
+}
+
+sub maybe_run_query {
+ eval {
+ my $query = shift;
+ compile_query($query) or return;
+
+ return unless $sth->{NUM_OF_PARAMS} == 0;
+
+
+ run_query($sth);
+ return $sth;
+ };
+}
+
+sub run_query {
+ my $sth = shift;
+ return unless defined $sth;
+ my @params = @_;
+ my @_rows;
+
+ warn "Executing...\n";
+ $sth->execute(@params) or return;
+ while (my $row = $sth->fetchrow_hashref) {
+ push @_rows, {%$row};
+ }
+
+
+ $sth->finish;
+ if (@_rows == 0) {
+ print "Empty result.\n";
+ return;
+ } elsif (@_rows <= $maxrows) {
+ print_aoh(\@rows, $opt_n);
+ } else {
+ print "result: " . @_rows . " rows; use 'p' to display\n";
+ }
+ @rows = @_rows;
+}
+
+sub edit {
+ my $tmp = "/tmp/iq.$$";
+ my $data = shift;
+ $data .= "\n" unless $data =~ /\n\z/;
+ open my($f), ">", $tmp or die "Couldn't write temp file '$tmp': $!";
+ print $f $data;
+ close $f;
+ if (system($editor, $tmp) == 0) {
+ open my($f), "<", $tmp or die "Couldn't read modified temp file '$tmp': $!";
+ $data = join "", <$f>;
+ } else {
+ warn "Editor failed; ignoring changes\n";
+ }
+ unlink $tmp;
+ return $data;
+}
+
+sub trim {
+ $_[0] =~ s/^\s+//;
+ $_[0] =~ s/\s+$//;
+}
Deleted: trunk/treebase-core/src/main/perl/dump/loadspeed
===================================================================
--- trunk/treebase-core/src/main/perl/dump/loadspeed 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/loadspeed 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,39 +0,0 @@
-#!/usr/bin/perl
-# -*- cperl -*-
-
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-
-my %opt = (z => 30);
-getopts('sz:', \%opt) or usage();
-
-@ARGV || usage();
-my $table = shift;
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-my $sth = $dbh->prepare("select count(*) from $table")
- or die "Couldn't prepare statement: " . $dbh->errstr;
-my $rc = $sth->execute()
- or die "Couldn't execute statement: " . $dbh->errstr;
-my ($before) = $sth->fetchrow_array;
-$sth->finish;
-#1 while $sth->fetch;
-warn "$before rows\n" unless $opt{s};
-sleep $opt{z};
-my $rc = $sth->execute()
- or die "Couldn't execute statement: " . $dbh->errstr;
-my ($after) = $sth->fetchrow_array;
-$sth->finish;
-warn "$after rows\n" unless $opt{s};
-my $rate = ($after-$before)*60/$opt{z};
-printf (($opt{s} ? "%.2f\n" : "%.2f records per minute\n"), $rate);
-
-$dbh->disconnect;
-exit;
-
-sub usage {
- print "$0 [-s] [-z time-delay] table-name\n";
- print " -s : short output format\n";
- exit 1;
-}
Copied: trunk/treebase-core/src/main/perl/dump/loadspeed (from rev 212, trunk/treebase-core/src/main/perl/dump/loadspeed)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/loadspeed (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/loadspeed 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,39 @@
+#!/usr/bin/perl
+# -*- cperl -*-
+
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+
+my %opt = (z => 30);
+getopts('sz:', \%opt) or usage();
+
+@ARGV || usage();
+my $table = shift;
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+my $sth = $dbh->prepare("select count(*) from $table")
+ or die "Couldn't prepare statement: " . $dbh->errstr;
+my $rc = $sth->execute()
+ or die "Couldn't execute statement: " . $dbh->errstr;
+my ($before) = $sth->fetchrow_array;
+$sth->finish;
+#1 while $sth->fetch;
+warn "$before rows\n" unless $opt{s};
+sleep $opt{z};
+my $rc = $sth->execute()
+ or die "Couldn't execute statement: " . $dbh->errstr;
+my ($after) = $sth->fetchrow_array;
+$sth->finish;
+warn "$after rows\n" unless $opt{s};
+my $rate = ($after-$before)*60/$opt{z};
+printf (($opt{s} ? "%.2f\n" : "%.2f records per minute\n"), $rate);
+
+$dbh->disconnect;
+exit;
+
+sub usage {
+ print "$0 [-s] [-z time-delay] table-name\n";
+ print " -s : short output format\n";
+ exit 1;
+}
Deleted: trunk/treebase-core/src/main/perl/dump/sel
===================================================================
--- trunk/treebase-core/src/main/perl/dump/sel 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/sel 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,42 +0,0 @@
-#!/usr/bin/perl
-# -*- cperl -*-
-
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-
-my %opt = (n => '--');
-getopts('n:', \%opt) or usage();
-
-@ARGV || usage();
-my $query = join " ", @ARGV;
-
-$query =~ s/^/SELECT / unless $query =~ /^select\s+/i;
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-my $sth = $dbh->prepare($query)
- or die "Couldn't prepare statement: " . $dbh->errstr;
-my $rc = $sth->execute()
- or die "Couldn't execute statement: " . $dbh->errstr;
-while (my $row = $sth->fetchrow_hashref) {
- push @rows, {%$row};
-}
-
-
-$dbh->disconnect;
-if (@rows) {
- if (@rows == 1 && keys %{$rows[0]} == 1) {
- # Special case for a single selected value
- my ($value) = values %{$rows[0]};
- print "$value\n";
- } else {
- print_aoh(\@rows, $opt_n);
- }
-} else {
- print "Empty result.\n";
-}
-
-sub usage {
- print "$0 [-n nullsymbol] '....'\n";
- exit 1;
-}
Copied: trunk/treebase-core/src/main/perl/dump/sel (from rev 212, trunk/treebase-core/src/main/perl/dump/sel)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/sel (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/sel 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,42 @@
+#!/usr/bin/perl
+# -*- cperl -*-
+
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+
+my %opt = (n => '--');
+getopts('n:', \%opt) or usage();
+
+@ARGV || usage();
+my $query = join " ", @ARGV;
+
+$query =~ s/^/SELECT / unless $query =~ /^select\s+/i;
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+my $sth = $dbh->prepare($query)
+ or die "Couldn't prepare statement: " . $dbh->errstr;
+my $rc = $sth->execute()
+ or die "Couldn't execute statement: " . $dbh->errstr;
+while (my $row = $sth->fetchrow_hashref) {
+ push @rows, {%$row};
+}
+
+
+$dbh->disconnect;
+if (@rows) {
+ if (@rows == 1 && keys %{$rows[0]} == 1) {
+ # Special case for a single selected value
+ my ($value) = values %{$rows[0]};
+ print "$value\n";
+ } else {
+ print_aoh(\@rows, $opt_n);
+ }
+} else {
+ print "Empty result.\n";
+}
+
+sub usage {
+ print "$0 [-n nullsymbol] '....'\n";
+ exit 1;
+}
Deleted: trunk/treebase-core/src/main/perl/dump/show
===================================================================
--- trunk/treebase-core/src/main/perl/dump/show 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/show 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,51 +0,0 @@
-#!/usr/bin/perl
-# -*- cperl -*-
-
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-
-my %opt = (n => $ENV{NULLSYMBOL} || '--');
-getopts('n:', \%opt) or usage();
-my ($class, $id) = @ARGV;
-defined($class) && defined($id) && $id =~ /^\d+$/ or usage();
-my $query = "select * from $class where $class\_id = ?";
-
-my $dbh = CIPRES::TreeBase::DBIUtil->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-my $sth = $dbh->prepare($query)
- or die "Couldn't prepare statement: " . $dbh->errstr;
-my $rc = $sth->execute($id)
- or die "Couldn't execute statement: " . $dbh->errstr;
-my $row;
-while (my $r = $sth->fetchrow_hashref) {
- if (defined $row) {
- die "Multiple matching rows!!\n";
- }
- $row = $r;
-}
-
-$dbh->disconnect;
-if (! defined $row) { die "show: No such object\n"; }
-
-my $c1 = max(map length(), keys %$row);
-
-for my $k (sort keys %$row) {
- if (! defined $row->{$k}) { $row->{$k} = $opt{n} }
- print fill($c1, $k), " $row->{$k}\n";
-}
-
-sub usage {
- print "$0 [-n nullsymbol] table id#\n";
- exit 1;
-}
-
-sub max {
- my $m = shift;
- $m = $m > $_ ? $m : $_ for @_;
- return $m;
-}
-
-sub fill {
- my ($n, $s) = @_;
- return length($s) > $n ? $s : $s . " " x ($n - length($s));
-}
Copied: trunk/treebase-core/src/main/perl/dump/show (from rev 212, trunk/treebase-core/src/main/perl/dump/show)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/show (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/show 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+# -*- cperl -*-
+
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+
+my %opt = (n => $ENV{NULLSYMBOL} || '--');
+getopts('n:', \%opt) or usage();
+my ($class, $id) = @ARGV;
+defined($class) && defined($id) && $id =~ /^\d+$/ or usage();
+my $query = "select * from $class where $class\_id = ?";
+
+my $dbh = CIPRES::TreeBase::DBIUtil->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+my $sth = $dbh->prepare($query)
+ or die "Couldn't prepare statement: " . $dbh->errstr;
+my $rc = $sth->execute($id)
+ or die "Couldn't execute statement: " . $dbh->errstr;
+my $row;
+while (my $r = $sth->fetchrow_hashref) {
+ if (defined $row) {
+ die "Multiple matching rows!!\n";
+ }
+ $row = $r;
+}
+
+$dbh->disconnect;
+if (! defined $row) { die "show: No such object\n"; }
+
+my $c1 = max(map length(), keys %$row);
+
+for my $k (sort keys %$row) {
+ if (! defined $row->{$k}) { $row->{$k} = $opt{n} }
+ print fill($c1, $k), " $row->{$k}\n";
+}
+
+sub usage {
+ print "$0 [-n nullsymbol] table id#\n";
+ exit 1;
+}
+
+sub max {
+ my $m = shift;
+ $m = $m > $_ ? $m : $_ for @_;
+ return $m;
+}
+
+sub fill {
+ my ($n, $s) = @_;
+ return length($s) > $n ? $s : $s . " " x ($n - length($s));
+}
Deleted: trunk/treebase-core/src/main/perl/dump/showanalyses
===================================================================
--- trunk/treebase-core/src/main/perl/dump/showanalyses 2009-10-23 15:17:51 UTC (rev 212)
+++ trunk/treebase-core/src/main/perl/dump/showanalyses 2009-11-01 22:31:20 UTC (rev 229)
@@ -1,76 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use CIPRES::TreeBase::DBIUtil;
-use Getopt::Std;
-
-my %opt;
-getopts('', \%opt) or usage();
-
-my $study_id = shift || usage();
-
-my $dbh = CIPRES::TreeBase::Util->dbh
- or die "Couldn't connect to database: " . DBI->errstr;
-
-for my $analysis_row (query("analysis", "study_id", $study_id)) {
- my $a_id = $analysis_row->{ANALYSIS_ID};
- print " Analysis $a_id:\n";
- for my $analysisstep_row (query("analysisstep", "analysis_id", $a_id)) {
- my $as_id = $analysisstep_row->{ANALYSISSTEP_ID};
- print " Step $as_id:\n";
- for my $analyzeddata_row (query("analyzeddata", "analysisstep_id", $as_id)) {
- my $ad_id = $analyzeddata_row->{ANALYZEDDATA_ID};
- my $type = $analyzeddata_row->{TYPE};
- my $Type = {M => "matrix", T => "phyloTree"}->{$type};
- my $input = $analyzeddata_row->{INPUT} ? "input" : "output";
- my $d_id = $analyzeddata_row->{"\U$Type\E_ID"};
- my $nameField = {M => "TITLE", T => "LABEL"}->{$type};
- print " Data $ad_id ($input):\n";
-# print " ", join " ", %$analyzeddata_row;
-
- for my $row (query($Type, $Type . "_id", $d_id)) {
- my $s_id = $row->{STUDY_ID};
- my $ERR = "";
- if (! defined $s_id) {
- $ERR = "(no study!) ";
- } elsif ($s_id != $study_id) {
- $ERR = "(study s_id) ";
- }
- if ($type eq "T" && not defined $row->{TREEBLOCK_ID}) {
- $ERR .= "(no treeblock!) "
- }
-
- my $spc = $ERR ? "**" : " ";
- print " $spc \u$Type $d_id: $ERR'$row->{$nameField}'\n";
- }
- }
- }
-}
-
-$dbh->disconnect;
-
-################################################################
-
-sub usage {
- print "$0 [-tb] tree-id\n";
- print "\t-t : check taxonlabels\n";
- print "\t-b : check treeblocks\n";
- exit 1;
-}
-
-################################################################
-
-sub query {
- my ($table, $qcolumn, $qvalue) = @_;
- unless (defined $qcolumn) {
- $qcolumn = $table . "_id";
- }
- my $sth = $dbh->prepare_cached("select * from $table where $qcolumn = ?");
- $sth->execute($qvalue);
- my @rows;
- while (my $row = $sth->fetchrow_hashref()) {
- push @rows, $row;
- }
- $sth->finish;
- return @rows;
-}
Copied: trunk/treebase-core/src/main/perl/dump/showanalyses (from rev 212, trunk/treebase-core/src/main/perl/dump/showanalyses)
===================================================================
--- trunk/treebase-core/src/main/perl/dump/showanalyses (rev 0)
+++ trunk/treebase-core/src/main/perl/dump/showanalyses 2009-11-01 22:31:20 UTC (rev 229)
@@ -0,0 +1,76 @@
+#!/usr/bin/perl
+
+use strict;
+use CIPRES::TreeBase::DBIUtil;
+use Getopt::Std;
+
+my %opt;
+getopts('', \%opt) or usage();
+
+my $study_id = shift || usage();
+
+my $dbh = CIPRES::TreeBase::Util->dbh
+ or die "Couldn't connect to database: " . DBI->errstr;
+
+for my $analysis_row (query("analysis", "study_id", $study_id)) {
+ my $a_id = $analysis_row->{ANALYSIS_ID};
+ print " Analysis $a_id:\n";
+ for my $analysisstep_row (query(...
[truncated message content] |
