File Coverage

blib/lib/Apache/DBI.pm
Criterion Covered Total %
statement 19 116 16.4
branch 2 48 4.2
condition 3 54 5.6
subroutine 7 20 35.0
pod 0 10 0.0
total 31 248 12.5


line stmt bran cond sub pod time code
1             # $Id: DBI.pm 8010 2006-11-04 06:17:42Z pgollucci@p6m7g8.com $
2             package Apache::DBI;
3 1     1   15 use strict;
  1         14  
  1         16  
4              
5 1 50 33     24 use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} &&
6 1     1   15                      $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
  1         9  
7              
8             BEGIN {
9 1 50 33 1   50     if (MP2) {
      33        
10                     require mod_perl2;
11                     require Apache2::Module;
12                     require Apache2::ServerUtil;
13                 }
14                 elsif (defined $modperl::VERSION && $modperl::VERSION > 1 &&
15                          $modperl::VERSION < 1.99) {
16 0         0         require Apache;
17                 }
18             }
19 1     1   29 use DBI ();
  1         2347  
  1         11  
20 1     1   21 use Carp ();
  1         9  
  1         9  
21              
22             require_version DBI 1.00;
23              
24             $Apache::DBI::VERSION = '1.05';
25              
26             # 1: report about new connect
27             # 2: full debug output
28             $Apache::DBI::DEBUG = 0;
29             #DBI->trace(2);
30              
31             my %Connected; # cache for database handles
32             my @ChildConnect; # connections to be established when a new
33             # httpd child is created
34             my %Rollback; # keeps track of pushed PerlCleanupHandler
35             # which can do a rollback after the request
36             # has finished
37             my %PingTimeOut; # stores the timeout values per data_source,
38             # a negative value de-activates ping,
39             # default = 0
40             my %LastPingTime; # keeps track of last ping per data_source
41              
42             # Check to see if we need to reset TaintIn and TaintOut
43             my $TaintInOut = ($DBI::VERSION >= 1.31) ? 1 : 0;
44              
45             sub debug {
46 0 0   0 0     print STDERR "$_[1]\n" if $Apache::DBI::DEBUG >= $_[0];
47             }
48              
49             # supposed to be called in a startup script.
50             # stores the data_source of all connections, which are supposed to be created
51             # upon server startup, and creates a PerlChildInitHandler, which initiates
52             # the connections. Provide a handler which creates all connections during
53             # server startup
54             sub connect_on_init {
55              
56 0     0 0       if (MP2) {
57                     if (!@ChildConnect) {
58                         my $s = Apache2::ServerUtil->server;
59                         $s->push_handlers(PerlChildInitHandler => \&childinit);
60                     }
61                 }
62                 else {
63 0 0 0               Carp::carp("Apache.pm was not loaded\n")
64                           and return unless $INC{'Apache.pm'};
65              
66 0 0 0               if (!@ChildConnect and Apache->can('push_handlers')) {
67 0                       Apache->push_handlers(PerlChildInitHandler => \&childinit);
68                     }
69                 }
70              
71             # store connections
72 0               push @ChildConnect, [@_];
73             }
74              
75             # supposed to be called in a startup script.
76             # stores the timeout per data_source for the ping function.
77             # use a DSN without attribute settings specified within !
78             sub setPingTimeOut {
79 0     0 0       my $class = shift;
80 0               my $data_source = shift;
81 0               my $timeout = shift;
82              
83             # sanity check
84 0 0 0           if ($data_source =~ /dbi:\w+:.*/ and $timeout =~ /\-*\d+/) {
85 0                   $PingTimeOut{$data_source} = $timeout;
86                 }
87             }
88              
89             # the connect method called from DBI::connect
90             sub connect {
91 0     0 0       my $class = shift;
92 0 0             unshift @_, $class if ref $class;
93 0               my $drh = shift;
94              
95 0 0             my @args = map { defined $_ ? $_ : "" } @_;
  0            
96 0               my $dsn = "dbi:$drh->{Name}:$args[0]";
97 0               my $prefix = "$$ Apache::DBI ";
98              
99             # key of %Connected and %Rollback.
100 0               my $Idx = join $;, $args[0], $args[1], $args[2];
101              
102             # the hash-reference differs between calls even in the same
103             # process, so de-reference the hash-reference
104 0 0 0           if (3 == $#args and ref $args[3] eq "HASH") {
    0          
105             # should we default to '__undef__' or something for undef values?
106 0 0                 map {
107 0                       $Idx .= "$;$_=" .
108                             (defined $args[3]->{$_}
109                              ? $args[3]->{$_}
110                              : '')
111 0                       } sort keys %{$args[3]};
112                 }
113                 elsif (3 == $#args) {
114 0                   pop @args;
115                 }
116              
117             # don't cache connections created during server initialization; they
118             # won't be useful after ChildInit, since multiple processes trying to
119             # work over the same database connection simultaneously will receive
120             # unpredictable query results.
121             # See: http://perl.apache.org/docs/2.0/user/porting/compat.html#C__Apache__Server__Starting__and_C__Apache__Server__ReStarting_
122 0               if (MP2) {
123                     require Apache2::ServerUtil;
124                     if (Apache2::ServerUtil::restart_count() == 1) {
125                         debug(2, "$prefix skipping connection during server startup, read the docu !!");
126                         return $drh->connect(@args);
127                     }
128                 }
129                 else {
130 0 0 0               if ($Apache::ServerStarting and $Apache::ServerStarting == 1) {
131 0                       debug(2, "$prefix skipping connection during server startup, read the docu !!");
132 0                       return $drh->connect(@args);
133                     }
134                 }
135              
136             # this PerlCleanupHandler is supposed to initiate a rollback after the
137             # script has finished if AutoCommit is off. however, cleanup can only
138             # be determined at end of handle life as begin_work may have been called
139             # to temporarily turn off AutoCommit.
140 0 0 0           if (!$Rollback{$Idx} and Apache->can('push_handlers')) {
141 0                   debug(2, "$prefix push PerlCleanupHandler");
142 0                   if (MP2) {
143                         my $s = Apache2::ServerUtil->server;
144 0     0                 $s->push_handlers("PerlCleanupHandler", sub { cleanup($Idx) });
145                     }
146                     else {
147 0     0                 Apache->push_handlers("PerlCleanupHandler", sub { cleanup($Idx) });
  0            
148                     }
149             # make sure, that the rollback is called only once for every
150             # request, even if the script calls connect more than once
151 0                   $Rollback{$Idx} = 1;
152                 }
153              
154             # do we need to ping the database ?
155 0 0             $PingTimeOut{$dsn} = 0 unless $PingTimeOut{$dsn};
156 0 0             $LastPingTime{$dsn} = 0 unless $LastPingTime{$dsn};
157 0               my $now = time;
158             # Must ping if TimeOut = 0 else base on time
159 0 0 0           my $needping = ($PingTimeOut{$dsn} == 0 or
      0        
160                                 ($PingTimeOut{$dsn} > 0 and
161                                  $now - $LastPingTime{$dsn} > $PingTimeOut{$dsn})
162                                ) ? 1 : 0;
163 0 0             debug(2, "$prefix need ping: " . ($needping == 1 ? "yes" : "no"));
164 0               $LastPingTime{$dsn} = $now;
165              
166             # check first if there is already a database-handle cached
167             # if this is the case, possibly verify the database-handle
168             # using the ping-method. Use eval for checking the connection
169             # handle in order to avoid problems (dying inside ping) when
170             # RaiseError being on and the handle is invalid.
171 0 0 0           if ($Connected{$Idx} and (!$needping or eval{$Connected{$Idx}->ping})) {
  0   0        
172 0                   debug(2, "$prefix already connected to '$Idx'");
173              
174             # Force clean up of handle in case previous transaction failed to
175             # clean up the handle
176 0                   &reset_startup_state($Idx);
177              
178 0                   return (bless $Connected{$Idx}, 'Apache::DBI::db');
179                 }
180              
181             # either there is no database handle-cached or it is not valid,
182             # so get a new database-handle and store it in the cache
183 0               delete $Connected{$Idx};
184 0               $Connected{$Idx} = $drh->connect(@args);
185 0 0             return undef if !$Connected{$Idx};
186              
187             # store the parameters of the initial connection in the handle
188 0               set_startup_state($Idx);
189              
190             # return the new database handle
191 0               debug(1, "$prefix new connect to '$Idx'");
192 0               return (bless $Connected{$Idx}, 'Apache::DBI::db');
193             }
194              
195             # The PerlChildInitHandler creates all connections during server startup.
196             # Note: this handler runs in every child server, but not in the main server.
197             sub childinit {
198              
199 0     0 0       my $prefix = "$$ Apache::DBI ";
200 0               debug(2, "$prefix PerlChildInitHandler");
201              
202 0               %Connected = () if MP2;
203              
204 0 0             if (@ChildConnect) {
205 0                   for my $aref (@ChildConnect) {
206 0                       shift @$aref;
207 0                       DBI->connect(@$aref);
208 0                       $LastPingTime{@$aref[0]} = time;
209                     }
210                 }
211              
212 0               1;
213             }
214              
215             # The PerlCleanupHandler is supposed to initiate a rollback after the script
216             # has finished if AutoCommit is off.
217             # Note: the PerlCleanupHandler runs after the response has been sent to
218             # the client
219             sub cleanup {
220 0     0 0       my $Idx = shift;
221              
222 0               my $prefix = "$$ Apache::DBI ";
223 0               debug(2, "$prefix PerlCleanupHandler");
224              
225 0               my $dbh = $Connected{$Idx};
226 0 0 0           if ($Rollback{$Idx}
  0   0        
      0        
      0        
227                     and $dbh
228                     and $dbh->{Active}
229                     and !$dbh->{AutoCommit}
230                     and eval {$dbh->rollback}) {
231 0                   debug (2, "$prefix PerlCleanupHandler rollback for '$Idx'");
232                 }
233              
234 0               delete $Rollback{$Idx};
235              
236 0               1;
237             }
238              
239             # Store the default start state of each dbh in the handle
240             # Note: This uses private_Apache_DBI hash ref to store it in the handle itself
241             my @attrs = qw(
242             AutoCommit Warn CompatMode InactiveDestroy
243             PrintError RaiseError HandleError
244             ShowErrorStatement TraceLevel FetchHashKeyName
245             ChopBlanks LongReadLen LongTruncOk
246             Taint Profile
247             );
248              
249             sub set_startup_state {
250 0     0 0       my $Idx = shift;
251              
252 0               foreach my $key (@attrs) {
253 0                   $Connected{$Idx}->{private_Apache_DBI}{$key} =
254                         $Connected{$Idx}->{$key};
255                 }
256              
257 0 0             if ($TaintInOut) {
258 0                   foreach my $key qw{ TaintIn TaintOut } {
259 0                       $Connected{$Idx}->{private_Apache_DBI}{$key} =
260                             $Connected{$Idx}->{$key};
261                     }
262                 }
263              
264 0               1;
265             }
266              
267             # Restore the default start state of each dbh
268             sub reset_startup_state {
269 0     0 0       my $Idx = shift;
270              
271             # Rollback current transaction if currently in one
272 0               $Connected{$Idx}->{Active}
273                   and !$Connected{$Idx}->{AutoCommit}
274 0 0 0             and eval {$Connected{$Idx}->rollback};
275              
276 0               foreach my $key (@attrs) {
277 0                   $Connected{$Idx}->{$key} =
278                         $Connected{$Idx}->{private_Apache_DBI}{$key};
279                 }
280              
281 0 0             if ($TaintInOut) {
282 0                   foreach my $key qw{ TaintIn TaintOut } {
283 0                       $Connected{$Idx}->{$key} =
284                             $Connected{$Idx}->{private_Apache_DBI}{$key};
285                     }
286                 }
287              
288 0               1;
289             }
290              
291              
292             # This function can be called from other handlers to perform tasks on all
293             # cached database handles.
294 0     0 0   sub all_handlers { return \%Connected }
295              
296             # patch from Tim Bunce: Apache::DBI will not return a DBD ref cursor
297             @Apache::DBI::st::ISA = ('DBI::st');
298              
299             # overload disconnect
300             {
301               package Apache::DBI::db;
302 1     1   26   no strict;
  1         12  
  1         20  
303               @ISA=qw(DBI::db);
304 1     1   15   use strict;
  1         9  
  1         13  
305               sub disconnect {
306 0     0           my $prefix = "$$ Apache::DBI ";
307 0                 Apache::DBI::debug(2, "$prefix disconnect (overloaded)");
308 0                 1;
309               }
310               ;
311             }
312              
313             # prepare menu item for Apache::Status
314             sub status_function {
315 0     0 0       my($r, $q) = @_;
316              
317 0               my(@s) = qw(<TABLE><TR><TD>Datasource</TD><TD>Username</TD></TR>);
318 0               for (keys %Connected) {
319 0                   push @s, '<TR><TD>',
320                         join('</TD><TD>',
321                              (split($;, $_))[0,1]), "</TD></TR>\n";
322                 }
323 0               push @s, '</TABLE>';
324              
325 0               \@s;
326