File: AutoDBI.PL

package info (click to toggle)
libchado-perl 1.31-6
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 44,716 kB
  • sloc: sql: 282,721; xml: 192,553; perl: 25,524; sh: 102; python: 73; makefile: 57
file content (129 lines) | stat: -rw-r--r-- 3,313 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
#!perl
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
use FindBin '$Bin';
use Cwd;
  
my %OPTIONS;
if (open F,"$Bin/../build.conf") {
  while (<F>) {
    next if /^\#/;
    chomp;
    $OPTIONS{$1} = $2 if /^(\w+)\s*=\s*(.+)/;
  }
  close F;
}

$file   = basename($0, '.PL','.PLS');
$file   = "$Bin/../lib/Bio/Chado/$file.pm";

open OUT,">$file" or die "Can't create $file: $!";
        
print "Extracting $file (with variable substitutions)\n";
               
my $startperl = $Config{startperl} ne '#!perl'
  ? $Config{startperl}
  : "#!$Config{perlpath}";
                       
print OUT <<'!NO!SUBS!';
########DBI########
package Bio::Chado::DBI;

# Created by SQL::Translator::Producer::TTSchema
# Template used: dbi.tt2

use strict;
use Data::Dumper;
use Bio::GMOD::Config;
use Bio::GMOD::DB::Config;
no warnings 'redefine';
use base qw(Class::DBI::Pg);

# This is how you normally connect with Class DBI's connection pooling but
# its very fragile for me on FC2.  I'm replacing it with the db_Main method below
#Bio::Chado::DBI->set_db('Main', 'dbi:Pg:dbname=chado', 'scott', '');

my $db_options = { __PACKAGE__->_default_attributes };
__PACKAGE__->_remember_handle('Main'); # so dbi_commit works
$db_options->{AutoCommit} = 0;

sub db_Main {
  my $DBPROFILE ||= 'default';   #might want to allow passing this in somehow
  my $gmod_conf = Bio::GMOD::Config->new();
  my $db_conf = Bio::GMOD::DB::Config->new( $gmod_conf, $DBPROFILE );

  my $dbname = $db_conf->name;
  my $dbhost = $db_conf->host;
  my $dbport = $db_conf->port;
  my $dbuser = $db_conf->user;
  my $dbpass = $db_conf->password;
 
  my $dbh;
  $dbh = DBI->connect_cached( 
      "dbi:Pg:dbname=$dbname;host=$dbhost;port=$dbport", 
      $dbuser, 
      $dbpass, 
      $db_options );
  # clear the connection cache if can't ping
  if ($dbh->ping() < 1) {
    my $CachedKids_hashref = $dbh->{Driver}->{CachedKids};
    %$CachedKids_hashref = () if $CachedKids_hashref;
    $dbh = DBI->connect_cached(
       "dbi:Pg:dbname=$dbname;host=$dbhost;port=$dbport",
       $dbuser, 
       $dbpass, 
       $db_options );
       warn("Database handle reset!: ".$dbh." ping: ".$dbh->ping());
  }
  return($dbh);
}

sub search_ilike { shift->_do_search(ILIKE => @_ ) }
sub search_lower {
   my $c = shift;
   my %q = @_;
   my %t;
   foreach my $k (keys %q){
     $t{"lower($k)"} = lc($q{$k});
   }
   $c->_do_search(LIKE => %t);
}


# debug method
sub dump {
  my $self = shift;
  my %arg  = %{shift @_};
  $arg{'indent'} ||= 1;
  $arg{'depth'} ||= 3;
  $Data::Dumper::Maxdepth = $arg{'depth'} if defined $arg{'depth'};
  $Data::Dumper::Indent = $arg{'indent'} if defined $arg{'indent'};
  return(Dumper($arg{'object'}));
}

#
#
# NOT PART OF THE API, but useful function which returns a single row
#  and throws an error if more than one is returned
#
# Added as a utility function for modware
#
sub get_single_row {
   my ($proto, @args) = @_;
   my $class = ref $proto || $proto;

   my @rows  = $class->search( @args );

   my $count = @rows;
   die "only one row expected, @rows returned" if @rows > 1;

   return $rows[0];
}


1;
!NO!SUBS!
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';