File Coverage

blib/lib/LittleORM/Db.pm
Criterion Covered Total %
statement 6 66 9.0
branch 0 26 0.0
condition 0 3 0.0
subroutine 2 14 14.2
pod 0 11 0.0
total 8 120 6.6


line stmt bran cond sub pod time code
1 1     1   4 use strict;
  1         1  
  1         45  
2              
3             package LittleORM::Db;
4              
5             my $cached_read_dbh = [];
6             my $cached_write_dbh = [];
7              
8 1     1   3 use Carp::Assert 'assert';
  1         2  
  1         7  
9              
10             sub dbh_is_ok
11             {
12 0     0 0   my $dbh = shift;
13              
14 0           my $rv = $dbh;
15              
16 0 0         if( $dbh )
17             {
18 0 0         unless( $dbh -> ping() )
19             {
20 0           $rv = undef;
21             }
22             }
23              
24 0           return $rv;
25             }
26              
27             sub init
28             {
29 0     0 0   my ( $self, $dbh ) = @_;
30              
31 0 0         unless( $dbh )
32             {
33             # non-object call ?
34 0           $dbh = $self;
35             }
36              
37 0 0         if( ref( $dbh ) eq 'HASH' )
38             {
39 0           my ( $rdbh, $wdbh ) = @{ $dbh }{ 'read', 'write' };
  0            
40 0   0       assert( $rdbh and $wdbh );
41              
42 0 0         $cached_read_dbh = ( ref( $rdbh ) eq 'ARRAY' ? $rdbh : [ $rdbh ] );
43 0 0         $cached_write_dbh = ( ref( $wdbh ) eq 'ARRAY' ? $wdbh : [ $wdbh ] );
44              
45             } else
46             {
47             # $cached_dbh = $dbh;
48             # old way
49            
50 0           $cached_read_dbh = [ $dbh ];
51 0           $cached_write_dbh = [ $dbh ];
52             }
53             }
54              
55             sub __get_rand_array_el
56             {
57 0     0     my $arr = shift;
58             # return $arr -> [ 0 ]; # not very random
59              
60              
61             # sub rand_el
62             # {
63             # my $arr = shift;
64              
65 0           return $arr -> [ rand @{ $arr } ];
  0            
66              
67             #}
68              
69              
70             # this method is tested to work:
71              
72              
73             # use strict;
74              
75              
76             # my @arr = ( 1 .. 10 );
77              
78             # my %stats = ();
79              
80             # foreach ( 1 .. 10000 )
81             # {
82             # $stats{ &rand_el( \@arr ) } ++;
83             # }
84              
85             # while( my ( $k, $v ) = each %stats )
86             # {
87             # print $k, " => ", $v, "\n";
88             # }
89              
90              
91             # sub rand_el
92             # {
93             # my $arr = shift;
94              
95             # return $arr -> [ rand @{ $arr } ];
96              
97             # }
98              
99             # 6 => 1023
100             # 3 => 1000
101             # 7 => 961
102             # 9 => 945
103             # 2 => 998
104             # 8 => 1040
105             # 1 => 1071
106             # 4 => 974
107             # 10 => 997
108             # 5 => 991
109             # eugenek@carbon:~$ perl /tmp/test.pl
110             # 6 => 995
111             # 3 => 979
112             # 7 => 984
113             # 9 => 1026
114             # 2 => 983
115             # 8 => 984
116             # 4 => 1008
117             # 1 => 1048
118             # 10 => 1021
119             # 5 => 972
120              
121              
122             }
123              
124             sub get_dbh
125             {
126 0     0 0   my $for_what = shift;
127              
128 0           my $rv = undef;
129              
130 0 0         if( $for_what eq 'write' )
131             {
132 0           $rv = &get_write_dbh();
133             } else
134             {
135 0           $rv = &get_read_dbh();
136             }
137 0           return $rv;
138              
139             }
140              
141             sub get_read_dbh
142             {
143 0     0 0   return &__get_rand_array_el( $cached_read_dbh );
144             }
145              
146             sub get_write_dbh
147             {
148 0     0 0   return &__get_rand_array_el( $cached_write_dbh );
149             }
150              
151             sub dbq
152             {
153 0     0 0   my ( $v, $dbh ) = @_;
154              
155 0 0         unless( $dbh )
156             {
157 0           $dbh = &get_read_dbh();
158             }
159              
160 0           my $rv = undef;
161              
162 0           eval {
163 0           $rv = $dbh -> quote( $v );
164             };
165              
166 0 0         if( my $err = $@ )
167             {
168 0           assert( 0, $err );
169             }
170              
171 0           return $rv;
172             }
173              
174             sub getrow
175             {
176 0     0 0   my ( $sql, $dbh ) = @_;
177              
178 0 0         unless( $dbh )
179             {
180 0           warn( "(getrow) no DBH passed, failing back to write DBH" );
181 0           $dbh = &get_write_dbh();
182             # assert( 0, 'cant safely fall back to read dbh here' );
183             }
184              
185              
186 0           return $dbh -> selectrow_hashref( $sql );
187              
188             }
189              
190             sub prep
191             {
192 0     0 0   my ( $sql, $dbh ) = @_;
193              
194 0 0         unless( $dbh )
195             {
196 0           warn( "(prep) no DBH passed, failing back to write DBH" );
197 0           $dbh = &get_write_dbh();
198             # assert( 0, 'cant safely fall back to read dbh here' );
199             }
200              
201 0           return $dbh -> prepare( $sql );
202            
203             }
204              
205             sub doit
206             {
207 0     0 0   my ( $sql, $dbh ) = @_;
208              
209 0 0         unless( $dbh )
210             {
211 0           warn( "(doit) no DBH passed, failing back to write DBH" );
212 0           $dbh = &get_write_dbh();
213             #assert( 0, 'cant safely fall back to read dbh here too' );
214             }
215              
216 0           return $dbh -> do( $sql );
217             }
218              
219             sub errstr
220             {
221 0     0 0   my $dbh = shift;
222              
223 0           return $dbh -> errstr();
224             }
225              
226             sub nextval
227             {
228 0     0 0   my ( $sn, $dbh ) = @_;
229              
230 0 0         unless( $dbh )
231             {
232 0           $dbh = &get_write_dbh();
233             }
234              
235 0           my $sql = sprintf( "SELECT nextval(%s) AS newval", &dbq( $sn, $dbh ) );
236              
237 0           assert( my $rec = &getrow( $sql, $dbh ),
238             sprintf( 'could not get new value from sequence %s: %s',
239             $sn,
240             &errstr( $dbh ) ) );
241              
242 0           return $rec -> { 'newval' };
243             }
244              
245             42;