lib/CXGN/DB/Connection.pm

   1 package CXGN::DB::Connection;
   2 use strict;
   3 use warnings;
   4
   5 use Carp qw/cluck croak carp confess/;
   6 use DBI;
   7
   8 use Scalar::Util ();
   9 use List::MoreUtils qw/ any /;
  10 use CXGN::Debug  ();
  11
  12 use base qw/Class::Accessor::Fast/;
  13
  14 BEGIN {
  15   #list of method names that, when called on this object,
  16   #will be forwarded to the enclosed database handle
  17   my @dbh_methods = qw/
  18                         do
  19
  20                         selectall_arrayref
  21                         selectall_hashref
  22
  23                         selectcol_arrayref
  24                         selectcol_hashref
  25
  26                         selectrow_array
  27                         selectrow_arrayref
  28                         selectrow_hashref
  29
  30                         prepare
  31                         prepare_cached
  32
  33                         begin_work
  34                         commit
  35                         rollback
  36
  37                         quote
  38                         quote_identifier
  39
  40                         err
  41                         errstr
  42                         state
  43                         ping
  44
  45                         trace
  46                         trace_msg
  47
  48                         get_info
  49
  50                         table_info
  51                         column_info
  52                         primary_key_info
  53                         primary_key
  54                         foreign_key_info
  55                         tables
  56                         type_info_all
  57                         type_info
  58
  59                         FETCH
  60
  61                         pg_savepoint
  62                         pg_rollback_to
  63                         pg_release
  64                         pg_putline
  65                         pg_getline
  66                         pg_endcopy
  67
  68                       /;
  69   foreach my $forward_method (@dbh_methods) {
  70       no strict 'refs';
  71       *{$forward_method} = sub { shift->_dbh->$forward_method(@_) };
  72   }
  73 }
  74
  75 __PACKAGE__->mk_accessors( '_dbname',
  76                            '_dbschema',
  77                            '_dbuser',
  78                            '_dbpass',
  79                            '_dbhost',
  80                            '_dbport',
  81                            '_dbbranch',
  82                            '_dbargs',
  83                            '_conf',
  84                            '_dsn',
  85                            '_dbh',
  86                            #note that dbtype is an actual function defined below
  87                          );
  88
  89
  90 =head1 NAME
  91
  92 CXGN::DB::Connection - connect to CXGN databases
  93
  94 =head1 SYNOPSIS
  95
  96   # simple usage
  97   my $dbh = CXGN::DB::Connection->new();
  98   $dbh->do("SELECT 'BLAH'");
  99
 100   # OR
 101
 102   # as part of an object
 103   use base qw/CXGN::DB::Connection/;
 104   $self->do("SELECT 'BLAH'");
 105
 106 =head1 DESCRIPTION
 107
 108 This module can be used in two ways: it is a database handle ($dbh)
 109 that can be used directly; alternatively, objects such as database APIs can
 110 inherit from this by adding 'CXGN::DB::Connection' to their @ISA, and thus
 111 become database handles themselves (see also L<Ima::DBI>, which allows
 112 you to share a single database handle between all instances of a class).
 113
 114 To connect to the database, this object needs to figure out values
 115 for a number of parameters (listed below in the documentation for new() ).
 116 Any one of these parameters can be set in 4 different places:
 117 1.) As arguments to the new() method when the object is created.
 118 2.) As environment variables (e.g. $ENV{DBUSER})
 119 3.) As parameters in the CXGN::Configuration system (e.g. $conf->get_conf('dbuser') )
 120 4.) From the hardcoded default inside this module
 121
 122 Arguments to the new() method override environment variables, which override
 123 CXGN::Configuration parameters, which override the hardcoded defaults.  Get it?
 124 The hardcoded defaults are listed below in the documentation for new().
 125
 126 Example of setting environment variables for a database connection (using a bash
 127 shell):
 128
 129    user@box:~$ export $DBUSER=somebodyelse
 130    user@box:~$ export $DBPASS=lemmein
 131    user@box:~$ ./my_script_that_uses_db_connection.pl
 132
 133 Will specify a user and password for the script to use.
 134
 135 =head1 TRACING
 136
 137 If the CXGN_DB_CONNECTION_TRACE_CONNECTIONS environment variable is
 138 set, will append backtraces of all database connections to the file
 139 /tmp/cxgn_db_connections.log
 140
 141 Also, CXGN::DB::Connection supports the standard DBI tracing
 142 facilities.  See L<DBI> perldoc.
 143
 144 =head1 METHODS
 145
 146 =head2 new
 147
 148   Desc: Connects to the database and returns a new Connection object
 149   Args: parameters hash ref as
 150         ({
 151             REQUIRED:
 152             config => hashref of configuration parameters (from a config object or similar)
 153
 154             OPTIONAL (override parameters in config of the same name):
 155             dbname => name of the database; defaults to 'cxgn'; unused for MySQL
 156             dbschema => name of schema you want to connect to; defaults to 'sgn'
 157             dbtype => type of database - 'Pg' or 'mysql'; defaults to 'Pg'
 158             dbuser => username for the connection; defaults to 'web_usr'
 159             dbpass => password for the connection; defaults to nothing
 160             dbargs => DBI connection params, merged with the default, which are explained below,
 161             dbhost => host to connect to, default 'db.sgn.cornell.edu',
 162             dbbranch => the database "branch" to use, default 'devel' unless you are configured as a production website, in which case it would default to 'production'
 163          })
 164         all parameters in the hash are optional as well
 165   Ret: new CXGN::DB::Connection object
 166   Side Effects: sets up the internal state of the CXGN::DB::Connection object
 167   Example:
 168      my $dbh = CXGN::DB::Connection->new();
 169
 170   Defaults for dbargs:
 171      RaiseError:
 172         Explicitly set to 1.
 173      AutoCommit:
 174        If the environment variable $ENV{MOD_PERL} is set (which would be
 175        the case if you are running under mod_perl, AutoCommit defaults to 1, that is, ON.  If
 176        $ENV{MOD_PERL} is not set, which would probably be the case if you
 177        are running in some other environment (like in a shell), AutoCommit is
 178        defaults to 0, which is OFF.  For more on what AutoCommit is and why you
 179        need to be careful with it, see the documentation of L<DBI> and
 180        L<Class::DBI>.
 181
 182      Note that DBI handle options (AutoCommit, RaiseError, etc) are also
 183      merged, with the same order of precedence as the DB::Connection options
 184      (dbname, dbpass, etc).
 185
 186 =cut
 187
 188 =head2 new_no_connect
 189
 190   Desc: Same as above, except does not connect to the database.
 191         Used by things that want to use the connection parameters for
 192         themselves.
 193
 194 =cut
 195
 196 sub new_no_connect {
 197   my ($class, $db, $p) = @_;
 198   my $self = bless {},$class;
 199
 200   #carp "WARNING: CXGN::DB::Connection is deprecated"
 201   #    unless $ENV{TESTING_CXGN_DB_CONNECTION};
 202
 203   # This is a little gross, but it looks weird to have to call new
 204   # like this when all you want to customize is the dbuser:
 205   #
 206   # new("sgn", { 'dbuser' => 'bob' });
 207   #
 208   # According to Rob, this usage was meant to match some deprecated interface.
 209   # Anyhow, if $db is a ref, then use it as a hash potentially containing
 210   # all the connection parameters.  -- Marty, 2005 July 26.
 211   if (ref ($db)) { # The first argument was a hash ref.
 212     if (ref $p) { # Something's wrong if TWO hash refs were passed
 213       croak ("invalid arguments to CXGN::DB::Connection constructor");
 214     } else {
 215       $p = $db; # The first argument was a hash ref, so call it $p.
 216     }
 217   } else { # The first argument is the dbschema
 218     $p->{dbschema} = $db;
 219   }
 220
 221   my $autocommit_default = 0;
 222   if( any { defined $ENV{$_} } qw| MOD_PERL GATEWAY_INTERFACE CATALYST_ENGINE SERVER_SOFTWARE PATH_INFO HTTP_USER_AGENT CONTENT_LENGTH WEB_PROJECT_NAME | ) {
 223       $autocommit_default = 1; #if we are running in the website, run with autocommit on. otherwise, don't
 224   }
 225
 226   # process the config object we were passed
 227   my $conf = delete $p->{config};
 228   if( $conf ) {
 229       # if we got a config object, check it for validity
 230       if( Scalar::Util::blessed($conf) && $conf->isa('Bio::GMOD::DB::Config') ) {
 231           $conf = { dbhost => $conf->host,
 232                     dbport => $conf->port,
 233                     dbuser => $conf->user,
 234                     dbpass => $conf->password,
 235                     dbytpe => $conf->driver,
 236                     dbname => $conf->name,
 237                   };
 238       }
 239
 240       ref $conf eq 'HASH'
 241           or croak "invalid config, must be a hashref like { varname => value, }";
 242
 243   } else {
 244       # if we didn't get a config object, get the configuration from SGN if running under SGN, otherwise die
 245       if( defined $ENV{PROJECT_NAME} && $ENV{PROJECT_NAME} eq 'SGN' ) {
 246           our $c;
 247           require CatalystX::GlobalContext;
 248           CatalystX::GlobalContext->import('$c');
 249           $c or confess "Catalyst context object not found.  Are we actually running under Catalyst?";
 250           $conf = $c->config;
 251       } else {
 252           require CXGN::Config;
 253           $conf = CXGN::Config->load;
 254       }
 255   }
 256   $self->_conf( $conf );
 257
 258   my $dbbranch_default = exists $conf->{"production_server"} && $conf->{"production_server"} ? "production" : "devel";
 259
 260   if( $p->{dbschema} ) {
 261       carp "WARNING: dbschema argument to CXGN::DB::Connection is ignored.  Set the dbsearchpath configuration variable instead";
 262   }
 263
 264 #  warn "branch: " . $dbbranch_default;
 265
 266   #list of valid args to pass in the params hash, and defaults and auxiliary configuration sources for them.
 267   my @args = (# hash key,       environment var name,    configuration var name,      hardcoded default value
 268               ['dbhost'  ,      'DBHOST'  ,              'dbhost'  ,                  'db.sgn.cornell.edu'                     ],
 269               ['dbport'  ,      'DBPORT'  ,              'dbport'  ,                  ''                                             ],
 270               ['dbname'  ,      'DBNAME'  ,              'dbname'  ,                  'cxgn'                                         ],
 271               ['dbuser'  ,      'DBUSER'  ,              'dbuser'  ,                  'web_usr'                                      ],
 272               ['dbpass'  ,      'DBPASS'  ,              'dbpass'  ,                  ''                                     ],
 273               ['dbtype'  ,      'DBTYPE'  ,              'dbtype'  ,                  'Pg'                                           ],
 274               ['dbschema',      'DBSCHEMA',              'dbschema',                  'sgn'                                          ],
 275               ['dbbranch',      'DBBRANCH',              'dbbranch',                  $dbbranch_default                              ], #see above for default
 276               ['dbargs'  ,      undef     ,              undef     ,                  {RaiseError=>1,AutoCommit=>$autocommit_default}], #see above for default
 277              );
 278
 279   my %valid_argnames = map {$_->[0],1} @args;
 280
 281   #copy our args from the parameters hash into our object
 282   foreach my $pkey (keys %$p) {
 283     unless ($valid_argnames{$pkey}) {
 284       warn Carp::longmess("Invalid parameter '$pkey' passed to CXGN::DB::Connection argument hash");
 285     }
 286
 287     my $upkey = "_$pkey";
 288     $self->$upkey( $p->{$pkey} );
 289   }
 290
 291   #check for environment variables for things that weren't set from
 292   #the params hash, and if there is still no value, set it to the
 293   #conf object's value, and if there is still no value, set it to the
 294   #default value
 295   foreach my $arg (@args) {
 296     my ($argname,$envname,$confname,$default) = @$arg;
 297     if( $argname eq 'dbargs' ) { #merge dbargs specially
 298       my %merged;
 299       #only get args from either what you passed in, or the hardcoded defaults
 300       foreach my $hash ( $default, $self->_dbargs ) {
 301         while( my($key,$val) = each %$hash ) {
 302           $merged{$key} = $val;
 303         }
 304       }
 305       $self->_dbargs( \%merged );
 306     }
 307     else {
 308       $argname = "_$argname"; #these are private methods
 309
 310       # If the $argname field isn't filled in,
 311       # then if the policy allows for an environment
 312       # variable, a conf object key, or a default,
 313       # try those in succession.
 314       $self->$argname( $ENV{$envname} )
 315         if defined $envname && ! defined $self->$argname;
 316
 317       $self->$argname( $conf->{$confname} )
 318         if defined $confname && ! defined $self->$argname && exists $conf->{$confname};
 319
 320       $self->$argname( $default )
 321         if defined $default && ! defined $self->$argname;
 322     }
 323   }
 324
 325   ## Validation  and such.
 326
 327   # Now set up our derived connection params based on what kind of
 328   # database we're connecting to
 329   if( $self->_dbtype eq 'Pg' ) {
 330     # The following line adds 1 optional argument to the dbargs hash, but
 331     # no DBD driver is expected to use this key: it's there only so that
 332     # Apache::DBI will distinguish DBI handles.  If some day in the future
 333     # DBD::Pg does support schemas, you might as well change this argument,
 334     # though leaving it here for Apache::DBI to use shouldn't hurt, either.
 335     # update: according to the DBI docs, if your parameter is prefixed by
 336     #         'private_', the DB driver will ignore it
 337     $self->_dbargs->{private_cxgn_schema} = $self->_dbschema;
 338     my $dsn = "dbi:Pg:".join(';',
 339                              $self->_dbname ? "dbname=".$self->_dbname : (),
 340                              $self->_dbhost ? "host=".$self->_dbhost : (),
 341                              $self->_dbport ? "port=".$self->_dbport : (),
 342                             );
 343     $self->_dsn($dsn);
 344   }
 345   # MySQL
 346   elsif( $self->_dbtype eq 'mysql' ) {
 347     if ($self->_dbschema) {
 348       $self->_dsn( "dbi:mysql:host=".$self->_dbhost.";database=".$self->_dbschema.';port='.$self->_dbport );
 349     } elsif ($self->_dbname) {
 350       $self->_dsn( "dbi:mysql:host=".$self->_dbhost.";database=".$self->_dbname.';port='.$self->_dbport );
 351     } else {
 352       croak "Unknown CXGN::DB::Connection database name or schema for dbtype '".$self->_dbtype."'";
 353     }
 354   }
 355
 356   return $self;
 357 }
 358
 359 sub _compact_backtrace {
 360     return join '/', map {join(':',(caller($_))[0,2])} 1..3;
 361 }
 362
 363 my $debug = CXGN::Debug->new;
 364
 365 sub new {
 366     my $class = shift;
 367     my $self = $class->new_no_connect(@_);
 368
 369     # Now connect to a DB, dying from the caller's perspective
 370     eval { $self->_dbh( DBI->connect($self->get_connection_parameters) ) }; croak $@ if $@;
 371     $self->trace_msg('CXGN_TRACE | '._compact_backtrace().' | '.__PACKAGE__."::new | $self | ".$self->_dbh."\n",1);
 372
 373     #generate the search path
 374     if ( $self->_dbtype eq 'Pg' ) {
 375         my $conf = $self->_conf;
 376         my $configured_search_path =
 377             Scalar::Util::blessed($conf)
 378                   ? $conf->get_conf('dbsearchpath')
 379                   : $conf->{dbsearchpath};
 380
 381         $configured_search_path
 382             or croak 'no dbsearchpath conf variable set!  you must set one!';
 383
 384         my @searchpath = ref $configured_search_path
 385             ? @$configured_search_path
 386             : split /\s*,\s*/, $configured_search_path;
 387
 388         push @searchpath, 'tsearch2' unless $self->_dbh->{pg_server_version} >= 80300;
 389         $self->do("SET search_path TO ".join(',',@searchpath));
 390     }
 391
 392
 393     if ( $debug->get_debug || $ENV{CXGN_DB_CONNECTION_TRACE_CONNECTIONS}) {
 394         my $trace_str = join '',map {"$_\n"}
 395             (
 396              "# === DB::Connection parameters ===",
 397              "# dbhost:     " . $self->_dbhost,
 398              "# dbport:     " . $self->_dbport,
 399              "# dbname:     " . $self->_dbname,
 400              "# dbuser:     " . $self->_dbuser,
 401              "# dbtype:     " . $self->_dbtype,
 402              "# dbschema:   " . $self->_dbschema,
 403              "# dbbranch:   " . $self->_dbbranch,
 404              "# searchpath: " . $self->search_path,
 405              "# dbargs:",
 406              ( map {
 407                  "#  $_ => ".$self->_dbargs->{$_}
 408              } keys %{$self->_dbargs}
 409              ),
 410              "# === End of DB::Connection parameters ==="
 411             );
 412
 413         $debug->debug($trace_str);
 414         if ( $ENV{CXGN_DB_CONNECTION_TRACE_CONNECTIONS} ) {
 415             local *STDERR_SAVE;
 416             open STDERR_SAVE, ">&STDERR" or die "$! saving STDERR";
 417             open STDERR, ">>", '/tmp/cxgn_db_connections.log' or die "run3(): $! redirecting STDERR";
 418             cluck $trace_str;
 419             open STDERR, '>&', \*STDERR_SAVE;
 420         }
 421     }
 422
 423     return $self;
 424 }
 425
 426 # =head2 dbh
 427
 428 #   Args: none
 429 #   Ret : a DBI database handle for this connection
 430 #   Side Effects: none
 431 #   Example:
 432 #     my $dbconn = CXGN::DB::Connection->new
 433 #     $dbconn->dbh->do('delete from seqread');
 434
 435 # =cut
 436
 437 sub dbh {
 438   carp __PACKAGE__.": the dbh() method is deprecated. Just call dbh methods on the CXGN::DB::Connection object instead.";
 439   return shift;
 440 }
 441
 442
 443 =head2 get_actual_dbh
 444
 445  Usage: my $dbh = $self->get_actual_dbh()
 446  Desc: return the actual $dbh object
 447  Ret: $dbh, a database connectio object
 448  Args: none
 449  Side Effects: none
 450  Example:
 451
 452 =cut
 453
 454 sub get_actual_dbh {
 455   shift->_dbh;
 456 }
 457
 458 =head2 get_connection_parameters
 459
 460   Desc: get connection parameters you can use with your own DBI::connect call.
 461         Some things (like some CPAN's Class::DBI) seem to have a burning need
 462         to make DBI connections themselves.  You can satisfy them using the
 463         parameters you get from this.
 464   Args: none
 465   Ret : list of (dsn, db user, db password, DBI connection arguments)
 466
 467 =cut
 468 #'
 469 sub get_connection_parameters {
 470   my ($self) = @_;
 471   return ( $self->_dsn,
 472            $self->_dbuser,
 473            $self->_dbpass,
 474            $self->_dbargs,
 475          );
 476 }
 477
 478 =head2 dbtype
 479
 480   Desc: get the database type set on this connection
 481   Args: none
 482   Ret : the dbtype set on this connection thingy
 483         The dbtype will be a string containing either
 484         'Pg' or 'mysql'
 485
 486 =cut
 487
 488 sub dbtype { shift->_dbtype } #read-only
 489 sub _dbtype {
 490   my $self = shift;
 491   my $newtype = shift;
 492
 493   if( $newtype ) {
 494     $self->{dbtype} = $newtype;
 495   }
 496
 497   my %valid_dbtypes = ( Pg => 1, mysql => 1 );
 498
 499   !$self->{dbtype} || $valid_dbtypes{ $self->{dbtype} }
 500     or die "Invalid dbtype '$self->{dbtype}'";
 501
 502   return $self->{dbtype};
 503 }
 504
 505 =head2 dbname
 506
 507   Usage: my $n = $dbc->dbname
 508   Ret  : the name of the database we're currently connected to
 509   Args : none
 510   Side Effects: none
 511
 512 =cut
 513
 514 sub dbname { shift->_dbname } #keep this read-only
 515
 516 =head2 dbuser
 517
 518   Usage: my $n = $dbc->dbname
 519   Ret  : the name of the db user for this connection
 520   Args : none
 521   Side Effects: none
 522
 523 =cut
 524
 525 sub dbuser { shift->_dbuser } #keep this read-only
 526
 527 =head2 dbpass
 528
 529   Usage: my $n = $dbc->dbpass
 530   Ret  : the password used for this connection
 531   Args : none
 532   Side Effects: none
 533
 534 =cut
 535
 536 sub dbpass { shift->_dbpass } #keep this read-only
 537
 538 =head2 dbhost
 539
 540   Usage: my $host = $dbc->dbhost
 541   Desc :
 542   Ret  : the hostname of the database server
 543   Args : none
 544   Side Effects: none
 545   Example:
 546
 547 =cut
 548
 549 sub dbhost { shift->_dbhost } #read-only
 550
 551 =head2 dbport
 552
 553   Usage: my $port = $dbc->dbport
 554   Desc :
 555   Ret  : the port on the database server
 556   Args : none
 557   Side Effects: none
 558   Example:
 559
 560 =cut
 561
 562 sub dbport { shift->_dbport } #read-only
 563
 564 =head2 dbbranch
 565
 566   Usage: my $branch = $dbc->dbbranch
 567   Desc :
 568   Ret  : the name of the database branch we're using,
 569          usually either 'devel' or 'production'
 570   Args : none
 571   Side Effects: none
 572   Example:
 573
 574 =cut
 575
 576 sub dbbranch { shift->_dbbranch } #keeping this read-only
 577
 578 =head2 dbh_param
 579
 580   Desc: get or set the value of a DBI::db parameter
 581   Args: name of parameter to work with, (optional) new value to set it to
 582   Ret : new value of DBI::db parameter
 583   Side Effects: sets the new value of the parameter in the internal state of
 584                 our enclosed dbh
 585   Example:
 586
 587      my $dbconn = CXGN::DB::Connection->new;
 588      $dbconn->dbh_param( AutoCommit => 0 );
 589      $dbconn->dbh_param( PrintError => 0 );
 590      $dbconn->dbh_param( RaiseError => 1 );
 591
 592 =cut
 593
 594 sub dbh_param {
 595   my ($self,$paramname,$newvalue) = @_;
 596
 597   if( defined($newvalue) ) { #set a new value if given
 598     $self->_dbh->{$paramname} = $newvalue;
 599   }
 600
 601   return $self->_dbh->{$paramname};
 602 }
 603
 604
 605 #disconnect the database handle after we're done
 606 #and call the DESTROY methods of any parent classes that have them
 607 sub DESTROY {
 608   my $self = shift;
 609   #warn __PACKAGE__."(pid $PID): destroy called on dbc $self\n";
 610
 611   return unless $self->_dbh;
 612   $self->trace_msg('CXGN_TRACE | '._compact_backtrace().' | '.__PACKAGE__."::DESTROY | $self | ".$self->_dbh."\n",1);
 613
 614   #      unless( $self->dbh_param('InactiveDestroy') ){
 615   #         #warn "pid $PID disconnecting dbh ".$self->_dbh."\n";
 616   #        #print a warning in the DBI trace when it's enabled
 617   #        $self->disconnect(42);
 618   #        $self->_dbh->DESTROY;
 619   #    }
 620   #}
 621   # return parricide($self,our @ISA);
 622 }
 623
 624 =head2 qualify_schema
 625
 626   Desc: Get a fully-qualified schema name for the connection object or
 627         for a schema.
 628   Args: Nothing, or a schema basename.
 629   Ret : Fully-qualified schema.
 630   Side Effects: None.
 631   Examples:
 632
 633      my $dbconn = CXGN::DB::Connection->new({dbschema=>"genomic", dbbranch=>"production"});
 634      my $qualified_schema_name=$dbconn->qualify_schema;  # Returns "genomic"
 635      my $qualified_sgn_schema_name=$dbconn->qualify_schema("sgn");  # Returns "sgn"
 636
 637      my $dbconn = CXGN::DB::Connection->new({dbschema=>"genomic", dbbranch=>"devel"});
 638      my $qualified_schema_name=$dbconn->qualify_schema;  # Returns "genomic_dev"
 639      my $qualified_sgn_schema_name=$dbconn->qualify_schema("sgn");  # Returns "sgn_dev"
 640
 641   Note: DO NOT hard-code the values this method returns in your code.
 642   We make no guarantees that development/production schemas will keep
 643   their names in future.
 644
 645 =cut
 646
 647 sub qualify_schema {
 648   my ($self, $schema_basename, $return_base_table) = @_;
 649   carp "qualify_schema method is deprecated";
 650   return $schema_basename;
 651 }
 652
 653 =head2 base_schema
 654
 655 For migrating our tables out of the base schemas, factor
 656 out all "_bt" from code
 657
 658 =cut
 659
 660 sub base_schema {
 661     my ($self, $schema) = @_;
 662     carp "base_schema method is deprecated";
 663     return $schema;
 664 }
 665
 666 =head2 search_path
 667
 668   Desc: Get the databases current SEARCH_PATH parameter (or a snarky
 669         message, if the database is MySQL.
 670   Args: Nothing.
 671   Ret : A string.
 672   Side Effects: None.
 673   Examples:
 674
 675    # This is your program
 676    my $sp = $dbh->search_path;
 677    print $sp . "\n";
 678
 679    # This is its output
 680    annotation
 681
 682 =cut
 683
 684 sub search_path {
 685   my ($self) = @_;
 686   if ($self->_dbtype =~ 'mysql') {
 687     return ("You're using MySQL.  Nnyeeehhh.");
 688   } else {
 689     my ($sp) = $self->selectrow_array('SHOW SEARCH_PATH');
 690     return ($sp);
 691   }
 692 }
 693
 694 =head2 add_search_path
 695
 696  Add a schema to the search path, if it is not already there.
 697  One or many search paths may be added at once.
 698  Ex: $dbh->add_search_path(qw/ sgn sgn_people /);
 699
 700 =cut
 701
 702 sub add_search_path {
 703         my $self = shift;
 704         my ($current_string) = $self->selectrow_array('SHOW SEARCH_PATH');
 705         my @current = split ",", $current_string;
 706         push(@current, @_);
 707         @current = grep { /\w/ } @current; #avoid null items in array
 708         s/\s//g foreach @current;  #trim trailing spaces
 709         my $search_paths = {};
 710         $search_paths->{$_} = 1 foreach (@current);
 711         my $new_string = join ",", keys %$search_paths;
 712         my $update_q = "SET SEARCH_PATH=$new_string";
 713         $self->do($update_q);
 714 }
 715
 716 =head2 last_insert_id
 717
 718   Desc: Return the last auto-incremented primary key inserted into
 719         a table in the current connection.  Postgres ONLY!
 720   Args: A table name, an optional schema name (eventually perhaps the table
 721         name can be optional).
 722   Ret : The last insert id, an integer.
 723   Side Effects: None.
 724   Warning: in case there is no sequence found to be the default value
 725            for the primary key column of the table argument, this method
 726            DIEs.  You should only ever be using this inside a transaction
 727            eval block, and therefore should be checking the return from
 728            that eval.
 729   Examples:
 730
 731    $dbh->do("INSERT INTO mytable (mytable_id, foo, bar) VALUES (DEFAULT, 1, 'two')");
 732    my $id = $dbh->last_insert_id("mytable")
 733    print "$id\n";
 734    -| 12345  # just an example
 735
 736 =cut
 737
 738 sub last_insert_id {
 739   my ($self, $table, $schema) = @_;
 740
 741   # warning before the die gets the message through to loading scripts.
 742   warn "you forgot the table name argument to last_insert_id\n" unless $table;
 743   die unless $table;
 744
 745   $schema ||= $self->_dbschema;
 746   # This query needs work.  For one thing, we're banking on the split_part/replace
 747   # munging things correctly, which is dubious.  It'd be better to actually
 748   # figure out the name of the sequence associated with the default on a primary
 749   # key column, but I don't know how to do that.
 750   my ($seq) = $self->selectrow_array("SELECT split_part(replace(adsrc, 'nextval(''', ''), '''::', 1)
 751                                         FROM pg_class t,                     -- tables
 752                                              pg_attribute a,                 -- attributes (columns)
 753                                              pg_attrdef d,                   -- attribute defaults
 754                                              pg_namespace n,                 -- schemas (called namespaces inside Pg)
 755                                              pg_constraint o                 -- constraints
 756                                        WHERE t.relkind='r'                   -- select only tables
 757                                          AND n.oid=t.relnamespace            -- joining tables to schemas
 758                                          AND a.attrelid=t.oid                -- joining attributes to tables
 759                                          AND d.adnum=a.attnum                -- joining defaults to attributes
 760                                          AND d.adrelid=t.oid                 -- joining defaults to tables
 761                                          AND o.conrelid=t.oid                -- joining constraints with tables
 762                                          AND o.contype='p'                   -- selecting only pkey constraints
 763                                          AND array_upper(o.conkey, 1)=1      -- selecting only single-column constraints (serial numbering can only apply to one column)
 764                                          AND o.conkey[1]=a.attnum            -- joining constraint column numbers with attribute column numbers
 765                                          AND adsrc LIKE 'nextval%'           -- select only defaults that look like nextval of some sequence
 766                                          AND t.relname = '$table'            -- select only tables whose name is the table argument
 767                                          AND n.nspname = '$schema'           -- select only schemas whose name is the schema argument");
 768   $seq or die"No sequence name found for table '$table' and schema '$schema' using qualified schema name '$schema'.\n";
 769   my ($id) = $self->selectrow_array("SELECT currval('$schema.$seq')")
 770       or die "No id found for table '$table' and schema '$schema' using qualified schema name '$schema' and sequence name '$seq'.\n";
 771   return ($id);
 772 }
 773
 774 ###
 775 1;#do not remove
 776 ###
 777
 778 =head1 DBI database handle methods
 779
 780 All methods that can be used on a DBI database handle can also be
 781 used on a CXGN::DB::Connection object.  They will be transparently
 782 forwarded to this object's enclosed database handle.
 783
 784 Except for:
 785
 786 =head2 disconnect
 787
 788   Usage: $dbconn->disconnect(42);
 789          #if you don't pass 42 here, it will print a dire warning
 790   Desc : Disconnect this database connection.  To prevent people
 791          doing this by accident, you must give this an argument
 792          of 42, or it will print a _dire_ warning.  Really, very dire.
 793   Ret  : true if the disconnection was successful
 794   Args : (optional) the number 42
 795   Side Effects: disconnects from the database
 796   Example:
 797
 798
 799   Notes: This is here because a lot of code uses shared database
 800          handles, and erroneously disconnecting one can have great
 801          potential for causing far-away code to die a gruesome death.
 802
 803 =cut
 804
 805 #to alter which methods are forwarded, edit the array @dbh_methods
 806 #at the top of this file
 807
 808 #disconnect is not directly forwarded, because we want to catch
 809 #spurious disconnects, because they may be buried somewhere
 810 sub disconnect {
 811   my $self = shift;
 812
 813   return $self->_dbh->disconnect;
 814 }
 815
 816 =head1 CLASS METHODS
 817
 818 =head2 verbose
 819
 820   DEPRECATED.  This method no longer does anything, this module just uses CXGN::Debug::debug.
 821
 822   OLD DOCUMENTATION
 823   # Usage: CXGN::DB::Connection->verbose(1);
 824   # Desc : get/set the verbosity level of CXGN::DB::Connection objects.
 825   #        defaults to 0 in web server, 1 otherwise.
 826   # Ret  : currently set verbosity level
 827   # Args : new verbosity level
 828   # Side Effects: sets the verbosity level for all CXGN::DB::Connection objects
 829   # Example:
 830
 831 =cut
 832
 833 sub verbose {
 834     carp "CXGN::DB::Connection::verbose no longer does anything, might as well remove this invocation";
 835 }
 836
 837 sub is_valid_dbh
 838 {
 839     my($dbh)=@_;
 840     if($dbh eq 'CXGN::DB::Connection')
 841     {
 842         warn "You sent in the string 'CXGN::DB::Connection'. Did you call this function with a '->' instead of a '::'?";
 843         return 0;
 844     }
 845     unless(ref($dbh))
 846     {
 847         warn "'$dbh' is not a reference";
 848         return 0;
 849     }
 850     if(ref($dbh) eq "ARRAY" or ref($dbh) eq "HASH")
 851     {
 852         warn "'$dbh' is not an object reference";
 853         return 0;
 854     }
 855     unless( $dbh->can('selectall_arrayref') )
 856     {
 857         warn "'$dbh' is a reference but does not look like a valid dbh";
 858         return 0;
 859     }
 860     return 1;
 861 }
 862
 863 =head1 LICENSE
 864
 865 This module is part of the SGN/CXGN codebase and is distributed under
 866 the same terms that it is. If you're confused about the license or did
 867 not receive one, please email us at sgn-feedback@sgn.cornell.edu.
 868
 869 =head1 AUTHOR
 870
 871 Written by the SGN crew.  The first person to have her grubby mitts
 872 on this was Beth.  Then Rob.  Then Marty.  Then Rob again.  And so on.
 873
 874 =head1 SEE ALSO
 875
 876 L<DBI>, L<Apache::DBI>, L<Ima::DBI>, L<Class::DBI>
 877
 878 =cut
 879
 880
 881 1;