lib/Bio/DB/SimpleDBContext.pm

   1 # $Id$
   2 #
   3 # BioPerl module for SimpleDBContext
   4 #
   5 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   6 #
   7 # Cared for by Hilmar Lapp <hlapp at gmx.net>
   8 #
   9 # Copyright Hilmar Lapp
  10 #
  11 # You may distribute this module under the same terms as perl itself
  12
  13 #
  14 # (c) Hilmar Lapp, hlapp at gmx.net, 2002.
  15 # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002.
  16 #
  17 # You may distribute this module under the same terms as perl itself.
  18 # Refer to the Perl Artistic License (see the license accompanying this
  19 # software package, or see http://www.perl.com/language/misc/Artistic.html)
  20 # for the terms under which you may use, modify, and redistribute this module.
  21 #
  22 # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
  23 # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
  24 # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  25 #
  26
  27 # POD documentation - main docs before the code
  28
  29 =head1 NAME
  30
  31 Bio::DB::SimpleDBContext - a base implementation of Bio::DB::DBContextI
  32
  33 =head1 SYNOPSIS
  34
  35        # See Bio::DB::DBContextI.
  36
  37 =head1 DESCRIPTION
  38
  39 See Bio::DB::DBContextI.
  40
  41 =head1 FEEDBACK
  42
  43 =head2 Mailing Lists
  44
  45 User feedback is an integral part of the evolution of this and other
  46 Bioperl modules. Send your comments and suggestions preferably to
  47 the Bioperl mailing list.  Your participation is much appreciated.
  48
  49   bioperl-l@bioperl.org                  - General discussion
  50   http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  51
  52 =head2 Support
  53
  54 Please direct usage questions or support issues to the mailing list:
  55
  56 I<bioperl-l@bioperl.org>
  57
  58 rather than to the module maintainer directly. Many experienced and
  59 reponsive experts will be able look at the problem and quickly
  60 address it. Please include a thorough description of the problem
  61 with code and data examples if at all possible.
  62
  63 =head2 Reporting Bugs
  64
  65 Report bugs to the Bioperl bug tracking system to help us keep track
  66 of the bugs and their resolution. Bug reports can be submitted via
  67 the web:
  68
  69   http://redmine.open-bio.org/projects/bioperl/
  70
  71 =head1 AUTHOR - Hilmar Lapp
  72
  73 Email hlapp at gmx.net
  74
  75 Describe contact details here
  76
  77 =head1 CONTRIBUTORS
  78
  79 Additional contributors names and emails here
  80
  81 =head1 APPENDIX
  82
  83 The rest of the documentation details each of the object methods.
  84 Internal methods are usually preceded with a _
  85
  86 =cut
  87
  88
  89 # Let the code begin...
  90
  91
  92 package Bio::DB::SimpleDBContext;
  93 use vars qw(@ISA);
  94 use strict;
  95
  96 # Object preamble - inherits from Bio::Root::Root
  97
  98 use Bio::Root::Root;
  99 use Bio::DB::DBContextI;
 100 use Bio::DB::DBI;
 101
 102 @ISA = qw(Bio::Root::Root Bio::DB::DBContextI);
 103
 104 =head2 new
 105
 106  Title   : new
 107  Usage   : my $obj = Bio::DB::SimpleDBContext->new();
 108  Function: Builds a new Bio::DB::SimpleDBContext object
 109  Returns : an instance of Bio::DB::SimpleDBContext
 110  Args    : Named parameters. Currently recognized are
 111              -dbname    the name of the schema
 112              -host      the database host (to which to connect)
 113              -port      the port on the host to which to connect (optional)
 114              -driver    the DBI driver name for the RDBMS (e.g., mysql,
 115                         oracle, or Pg)
 116              -user      the username for connecting
 117              -pass      the password for the user
 118              -dsn       the DSN string to use verbatim for connecting;
 119                         if supplied, other parameters will not change
 120                         or add to the value (see method dsn())
 121              -schema    the schema under which the database tables
 122                         reside, if the driver needs this (for example,
 123                         for PostgreSQL)
 124
 125 =cut
 126
 127 sub new {
 128     my($class,@args) = @_;
 129
 130     my $self = $class->SUPER::new(@args);
 131     my ($dsn,
 132         $db,
 133         $host,
 134         $driver,
 135         $user,
 136         $password,
 137         $port,
 138         $schema,
 139         ) = $self->_rearrange([qw(DSN
 140                                   DBNAME
 141                                   HOST
 142                                   DRIVER
 143                                   USER
 144                                   PASS
 145                                   PORT
 146                                   SCHEMA
 147                                   )],@args);
 148
 149     $self->dsn($dsn) if $dsn;
 150     $self->username( $user );
 151     $self->host( $host ) if defined($host);
 152     $self->dbname( $db ) if defined($db);
 153     $self->driver($driver || "mysql") unless $self->driver();
 154     $self->password($password) if defined($password);
 155     $self->port($port) if defined($port);
 156     $self->schema($schema) if defined($schema);
 157     return $self;
 158 }
 159
 160 =head2 dsn
 161
 162  Title   : dsn
 163  Usage   : $obj->dsn($newval)
 164  Function: Get/set the DSN for the database connection.
 165
 166            The DSN typically contains all non-credential information
 167            necessary to connect to the database, like driver, database
 168            or instance name, host, etc. Therefore, setting the DSN
 169            overrides any other individual properties set before. We
 170            make an attempt to parse those properties out of the DSN
 171            string, but, in accordance with the interface contract,
 172            advise any client to use the dsn verbatim for connecting if
 173            set and not try to rebuild it from the parsed out
 174            properties.
 175
 176            I.e., if you set this property, setting any other
 177            individual properties will not alter the DSN used for
 178            connecting to the database. If you query the property, a
 179            value will not be automatically constructed if only
 180            individual properties have been set.
 181
 182  Example :
 183  Returns : value of dsn (a scalar)
 184  Args    : on set, new value (a scalar or undef, optional)
 185
 186
 187 =cut
 188
 189 sub dsn{
 190     my $self = shift;
 191
 192     if (@_) {
 193         my $dsn = shift;
 194         $self->{'dsn'} = $dsn;
 195         if ($dsn) {
 196             my @elts = split(/:/,$dsn);
 197             shift(@elts);                # first element is dbi or DBI
 198             $self->driver(shift(@elts)); # second is the driver
 199                                          # the rest is less predictable ...
 200             if (@elts && ($elts[0] =~ /^\w+$/)) { # just a plain dbname or sid?
 201                 $self->dbname(shift(@elts));
 202             }
 203             my @params = split(/;/,join(':',@elts));
 204             foreach my $param (@params) {
 205                 # check for dbname
 206                 if ($param =~ /^(dbname|database|sid)=(.+)/) {
 207                     $self->dbname($2);
 208                     next;
 209                 }
 210                 # check for host
 211                 if ($param =~ /^(host=|hostname=|\@)(.+)/) {
 212                     $self->host($2);
 213                     next;
 214                 }
 215                 # check for port
 216                 if ($param =~ /^(port=|:)(\d+)/) {
 217                     $self->port($2);
 218                 }
 219                 # anything else we could check for?
 220             }
 221         }
 222     }
 223     return $self->{'dsn'};
 224 }
 225
 226 =head2 dbname
 227
 228  Title   : dbname
 229  Usage   : $obj->dbname($newval)
 230  Function:
 231  Example :
 232  Returns : value of dbname (a scalar)
 233  Args    : new value (a scalar, optional)
 234
 235
 236 =cut
 237
 238 sub dbname{
 239     my $self = shift;
 240
 241     return $self->{'dbname'} = shift if @_;
 242     return $self->{'dbname'};
 243 }
 244
 245 =head2 driver
 246
 247  Title   : driver
 248  Usage   : $obj->driver($newval)
 249  Function:
 250  Example :
 251  Returns : value of driver (a scalar)
 252  Args    : new value (a scalar, optional)
 253
 254
 255 =cut
 256
 257 sub driver{
 258     my $self = shift;
 259
 260     return $self->{'driver'} = shift if @_;
 261     return $self->{'driver'};
 262 }
 263
 264 =head2 username
 265
 266  Title   : username
 267  Usage   : $obj->username($newval)
 268  Function:
 269  Example :
 270  Returns : value of username (a scalar)
 271  Args    : new value (a scalar, optional)
 272
 273
 274 =cut
 275
 276 sub username {
 277     my $self = shift;
 278
 279     return $self->{'username'} = shift if @_;
 280     return $self->{'username'};
 281 }
 282
 283 =head2 password
 284
 285  Title   : password
 286  Usage   : $obj->password($newval)
 287  Function:
 288  Example :
 289  Returns : value of password (a scalar)
 290  Args    : new value (a scalar, optional)
 291
 292
 293 =cut
 294
 295 sub password{
 296     my $self = shift;
 297
 298     return $self->{'password'} = shift if @_;
 299     return $self->{'password'};
 300 }
 301
 302 =head2 host
 303
 304  Title   : host
 305  Usage   : $obj->host($newval)
 306  Function:
 307  Example :
 308  Returns : value of host (a scalar)
 309  Args    : new value (a scalar, optional)
 310
 311
 312 =cut
 313
 314 sub host {
 315     my $self = shift;
 316
 317     return $self->{'host'} = shift if @_;
 318     return $self->{'host'};
 319 }
 320
 321 =head2 port
 322
 323  Title   : port
 324  Usage   : $obj->port($newval)
 325  Function:
 326  Example :
 327  Returns : value of port (a scalar)
 328  Args    : new value (a scalar, optional)
 329
 330
 331 =cut
 332
 333 sub port{
 334     my $self = shift;
 335
 336     return $self->{'port'} = shift if @_;
 337     return $self->{'port'};
 338 }
 339
 340 =head2 dbadaptor
 341
 342  Title   : get_adaptor
 343  Usage   : $dbadp = $dbc->dbadaptor();
 344  Function:
 345  Example :
 346  Returns : An Bio::DB::DBAdaptorI implementing object (an object adaptor
 347            factory).
 348  Args    : Optionally, on set an Bio::DB::DBAdaptorI implementing object (to
 349            be used as the object adaptor factory for the respective database)
 350
 351
 352 =cut
 353
 354 sub dbadaptor{
 355     my $self = shift;
 356
 357     return $self->{'dbadaptor'} = shift if @_;
 358     return $self->{'dbadaptor'};
 359 }
 360
 361 =head2 dbi
 362
 363  Title   : dbi
 364  Usage   :
 365  Function:
 366  Example :
 367  Returns : A Bio::DB::DBI implementing object
 368  Args    : Optionally, on set a Bio::DB::DBI implementing object
 369
 370
 371 =cut
 372
 373 sub dbi{
 374     my ($self,$value) = @_;
 375     if( defined $value) {
 376         $self->{'dbi'} = $value;
 377     }
 378     if(! exists($self->{'dbi'})) {
 379         my $dbimod = "Bio::DB::DBI::".$self->driver();
 380         $self->_load_module($dbimod);
 381         $self->{'dbi'} = $dbimod->new(-dbcontext => $self);
 382     }
 383     return $self->{'dbi'};
 384 }
 385
 386 =head2 schema
 387
 388  Title   : schema
 389  Usage   : $dbc->schema($newval)
 390  Function: Get/set the schema in which the database tables reside.
 391  Example :
 392  Returns : value of schema (a scalar)
 393  Args    : on set, new value (a scalar or undef, optional)
 394
 395
 396 =cut
 397
 398 sub schema{
 399     my $self = shift;
 400
 401     return $self->{'schema'} = shift if @_;
 402     return $self->{'schema'};
 403 }
 404
 405 1;