torrus/perllib/Torrus/SQL.pm

   1 #  Copyright (C) 2005  Stanislav Sinyagin
   2 #
   3 #  This program is free software; you can redistribute it and/or modify
   4 #  it under the terms of the GNU General Public License as published by
   5 #  the Free Software Foundation; either version 2 of the License, or
   6 #  (at your option) any later version.
   7 #
   8 #  This program is distributed in the hope that it will be useful,
   9 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #  GNU General Public License for more details.
  12 #
  13 #  You should have received a copy of the GNU General Public License
  14 #  along with this program; if not, write to the Free Software
  15 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
  16
  17 # $Id: SQL.pm,v 1.1 2010-12-27 00:03:38 ivan Exp $
  18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
  19
  20 # Package for RDBMS communication management in Torrus
  21 # Classes should inherit Torrus::SQL and execute Torrus::SQL->new(),
  22 # and then use methods of DBIx::Abstract.
  23
  24 package Torrus::SQL;
  25
  26 use strict;
  27 use DBI;
  28 use DBIx::Abstract;
  29 use DBIx::Sequence;
  30
  31 use Torrus::Log;
  32
  33 my %connectionArgsCache;
  34
  35 # Obtain connection attributes for particular class and object subtype.
  36 # The attributes are defined in torrus-siteconfig.pl, in a hash
  37 # %Torrus::SQL::connections.
  38 # For a given Perl class and an optional subtype,
  39 # the connection attributes are derived in the following order:
  40 # 'Default', 'Default/[subtype]', '[Class]', '[Class]/[subtype]',
  41 # 'All/[subtype]'.
  42 # For a simple setup, the default attributes are usually defined for
  43 # 'Default' key.
  44 # The key attributes are: 'dsn', 'username', and 'password'.
  45 # Returns a hash reference with the same keys.
  46
  47 sub getConnectionArgs
  48 {
  49     my $class = shift;
  50     my $objClass = shift;
  51     my $subtype = shift;
  52
  53     my $cachekey = $objClass . ( defined( $subtype )? '/'.$subtype : '');
  54     if( defined( $connectionArgsCache{$cachekey} ) )
  55     {
  56         return $connectionArgsCache{$cachekey};
  57     }
  58
  59     my @lookup = ('Default');
  60     if( defined( $subtype ) )
  61     {
  62         push( @lookup, 'Default/' . $subtype );
  63     }
  64     push( @lookup, $objClass );
  65     if( defined( $subtype ) )
  66     {
  67         push( @lookup, $objClass . '/' . $subtype, 'All/' . $subtype );
  68     }
  69
  70     my $ret = {};
  71     foreach my $attr ( 'dsn', 'username', 'password' )
  72     {
  73         my $val;
  74         foreach my $key ( @lookup )
  75         {
  76             if( defined( $Torrus::SQL::connections{$key} ) )
  77             {
  78                 if( defined( $Torrus::SQL::connections{$key}{$attr} ) )
  79                 {
  80                     $val = $Torrus::SQL::connections{$key}{$attr};
  81                 }
  82             }
  83         }
  84         if( not defined( $val ) )
  85         {
  86             die('Undefined attribute in %Torrus::SQL::connections: ' . $attr);
  87         }
  88         $ret->{$attr} = $val;
  89     }
  90
  91     $connectionArgsCache{$cachekey} = $ret;
  92
  93     return $ret;
  94 }
  95
  96
  97 my %dbhPool;
  98
  99 # For those who want direct DBI manipulation, simply call
 100 # Class->dbh($subtype) with optional subtype. Then you don't use
 101 # any other methods of Torrus::SQL.
 102
 103 sub dbh
 104 {
 105     my $class = shift;
 106     my $subtype = shift;
 107
 108     my $attrs = Torrus::SQL->getConnectionArgs( $class, $subtype );
 109
 110     my $poolkey = $attrs->{'dsn'} . '//' . $attrs->{'username'} . '//' .
 111         $attrs->{'password'};
 112
 113     my $dbh;
 114
 115     if( exists( $dbhPool{$poolkey} ) )
 116     {
 117         $dbh = $dbhPool{$poolkey};
 118         if( not $dbh->ping() )
 119         {
 120             $dbh = undef;
 121             delete $dbhPool{$poolkey};
 122         }
 123     }
 124
 125     if( not defined( $dbh ) )
 126     {
 127         $dbh = DBI->connect( $attrs->{'dsn'},
 128                              $attrs->{'username'},
 129                              $attrs->{'password'},
 130                              { 'PrintError' => 0,
 131                                'AutoCommit' => 0 } );
 132
 133         if( not defined( $dbh ) )
 134         {
 135             Error('Error connecting to DBI source ' . $attrs->{'dsn'} . ': ' .
 136                   $DBI::errstr);
 137         }
 138         else
 139         {
 140             $dbhPool{$poolkey} = $dbh;
 141         }
 142     }
 143
 144     return $dbh;
 145 }
 146
 147
 148 END
 149 {
 150     foreach my $dbh ( values %dbhPool )
 151     {
 152         $dbh->disconnect();
 153     }
 154 }
 155
 156
 157 sub new
 158 {
 159     my $class = shift;
 160     my $subtype = shift;
 161
 162     my $self = {};
 163
 164     $self->{'dbh'} = $class->dbh( $subtype );
 165     if( not defined( $self->{'dbh'} ) )
 166     {
 167         return undef;
 168     }
 169
 170     $self->{'sql'} = DBIx::Abstract->connect( $self->{'dbh'} );
 171
 172     $self->{'subtype'} = $subtype;
 173     $self->{'classname'} = $class;
 174
 175     bless ($self, $class);
 176     return $self;
 177 }
 178
 179
 180
 181 sub sequence
 182 {
 183     my $self = shift;
 184
 185     if( not defined( $self->{'sequence'} ) )
 186     {
 187         my $attrs = Torrus::SQL->getConnectionArgs( $self->{'classname'},
 188                                                     $self->{'subtype'} );
 189
 190         $self->{'sequence'} = DBIx::Sequence->new({
 191             dbh => $self->{'dbh'},
 192             allow_id_reuse => 1 });
 193     }
 194     return $self->{'sequence'};
 195 }
 196
 197
 198 sub sequenceNext
 199 {
 200     my $self = shift;
 201
 202     return $self->sequence()->Next($self->{'classname'});
 203 }
 204
 205
 206 sub fetchall
 207 {
 208     my $self = shift;
 209     my $columns = shift;
 210
 211     my $ret = [];
 212     while( defined( my $row = $self->{'sql'}->fetchrow_arrayref() ) )
 213     {
 214         my $retrecord = {};
 215         my $i = 0;
 216         foreach my $col ( @{$columns} )
 217         {
 218             $retrecord->{$col} = $row->[$i++];
 219         }
 220         push( @{$ret}, $retrecord );
 221     }
 222
 223     return $ret;
 224 }
 225
 226
 227 1;
 228
 229
 230 # Local Variables:
 231 # mode: perl
 232 # indent-tabs-mode: nil
 233 # perl-indent-level: 4
 234 # End: