1 # Copyright (C) 2005 Stanislav Sinyagin
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.
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.
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.
17 # $Id: SQL.pm,v 1.1 2010-12-27 00:03:38 ivan Exp $
18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
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.
33 my %connectionArgsCache;
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]',
42 # For a simple setup, the default attributes are usually defined for
44 # The key attributes are: 'dsn', 'username', and 'password'.
45 # Returns a hash reference with the same keys.
53 my $cachekey = $objClass . ( defined( $subtype )? '/'.$subtype : '');
54 if( defined( $connectionArgsCache{$cachekey} ) )
56 return $connectionArgsCache{$cachekey};
59 my @lookup = ('Default');
60 if( defined( $subtype ) )
62 push( @lookup, 'Default/' . $subtype );
64 push( @lookup, $objClass );
65 if( defined( $subtype ) )
67 push( @lookup, $objClass . '/' . $subtype, 'All/' . $subtype );
71 foreach my $attr ( 'dsn', 'username', 'password' )
74 foreach my $key ( @lookup )
76 if( defined( $Torrus::SQL::connections{$key} ) )
78 if( defined( $Torrus::SQL::connections{$key}{$attr} ) )
80 $val = $Torrus::SQL::connections{$key}{$attr};
84 if( not defined( $val ) )
86 die('Undefined attribute in %Torrus::SQL::connections: ' . $attr);
91 $connectionArgsCache{$cachekey} = $ret;
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.
108 my $attrs = Torrus::SQL->getConnectionArgs( $class, $subtype );
110 my $poolkey = $attrs->{'dsn'} . '//' . $attrs->{'username'} . '//' .
111 $attrs->{'password'};
115 if( exists( $dbhPool{$poolkey} ) )
117 $dbh = $dbhPool{$poolkey};
118 if( not $dbh->ping() )
121 delete $dbhPool{$poolkey};
125 if( not defined( $dbh ) )
127 $dbh = DBI->connect( $attrs->{'dsn'},
128 $attrs->{'username'},
129 $attrs->{'password'},
131 'AutoCommit' => 0 } );
133 if( not defined( $dbh ) )
135 Error('Error connecting to DBI source ' . $attrs->{'dsn'} . ': ' .
140 $dbhPool{$poolkey} = $dbh;
150 foreach my $dbh ( values %dbhPool )
164 $self->{'dbh'} = $class->dbh( $subtype );
165 if( not defined( $self->{'dbh'} ) )
170 $self->{'sql'} = DBIx::Abstract->connect( $self->{'dbh'} );
172 $self->{'subtype'} = $subtype;
173 $self->{'classname'} = $class;
175 bless ($self, $class);
185 if( not defined( $self->{'sequence'} ) )
187 my $attrs = Torrus::SQL->getConnectionArgs( $self->{'classname'},
188 $self->{'subtype'} );
190 $self->{'sequence'} = DBIx::Sequence->new({
191 dbh => $self->{'dbh'},
192 allow_id_reuse => 1 });
194 return $self->{'sequence'};
202 return $self->sequence()->Next($self->{'classname'});
212 while( defined( my $row = $self->{'sql'}->fetchrow_arrayref() ) )
216 foreach my $col ( @{$columns} )
218 $retrecord->{$col} = $row->[$i++];
220 push( @{$ret}, $retrecord );
232 # indent-tabs-mode: nil
233 # perl-indent-level: 4