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 = FS::DBI->connect(
 128             $attrs->{'dsn'},
 129             $attrs->{'username'},
 130             $attrs->{'password'},
 131             {
 132                 'PrintError' => 0,
 133                 'AutoCommit' => 0,
 134             }
 135         );
 136
 137         if( not defined( $dbh ) )
 138         {
 139             Error('Error connecting to DBI source ' . $attrs->{'dsn'} . ': ' .
 140                   $FS::DBI::errstr);
 141         }
 142         else
 143         {
 144             $dbhPool{$poolkey} = $dbh;
 145         }
 146     }
 147
 148     return $dbh;
 149 }
 150
 151
 152 END
 153 {
 154     foreach my $dbh ( values %dbhPool )
 155     {
 156         $dbh->disconnect();
 157     }
 158 }
 159
 160
 161 sub new
 162 {
 163     my $class = shift;
 164     my $subtype = shift;
 165
 166     my $self = {};
 167
 168     $self->{'dbh'} = $class->dbh( $subtype );
 169     if( not defined( $self->{'dbh'} ) )
 170     {
 171         return undef;
 172     }
 173
 174     $self->{'sql'} = DBIx::Abstract->connect( $self->{'dbh'} );
 175
 176     $self->{'subtype'} = $subtype;
 177     $self->{'classname'} = $class;
 178
 179     bless ($self, $class);
 180     return $self;
 181 }
 182
 183
 184
 185 sub sequence
 186 {
 187     my $self = shift;
 188
 189     if( not defined( $self->{'sequence'} ) )
 190     {
 191         my $attrs = Torrus::SQL->getConnectionArgs( $self->{'classname'},
 192                                                     $self->{'subtype'} );
 193
 194         $self->{'sequence'} = DBIx::Sequence->new({
 195             dbh => $self->{'dbh'},
 196             allow_id_reuse => 1 });
 197     }
 198     return $self->{'sequence'};
 199 }
 200
 201
 202 sub sequenceNext
 203 {
 204     my $self = shift;
 205
 206     return $self->sequence()->Next($self->{'classname'});
 207 }
 208
 209
 210 sub fetchall
 211 {
 212     my $self = shift;
 213     my $columns = shift;
 214
 215     my $ret = [];
 216     while( defined( my $row = $self->{'sql'}->fetchrow_arrayref() ) )
 217     {
 218         my $retrecord = {};
 219         my $i = 0;
 220         foreach my $col ( @{$columns} )
 221         {
 222             $retrecord->{$col} = $row->[$i++];
 223         }
 224         push( @{$ret}, $retrecord );
 225     }
 226
 227     return $ret;
 228 }
 229
 230
 231 1;
 232
 233
 234 # Local Variables:
 235 # mode: perl
 236 # indent-tabs-mode: nil
 237 # perl-indent-level: 4
 238 # End: