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							}
327
328							if (MP2) {
329							if (Apache2::Module::loaded('Apache2::Status')) {
330							Apache2::Status->menu_item(
331							'DBI' => 'DBI connections',
332							\&status_function
333							);
334							}
335							}
336							else {
337							if ($INC{'Apache.pm'} # is Apache.pm loaded?
338							and Apache->can('module') # really?
339							and Apache->module('Apache::Status')) { # Apache::Status too?
340							Apache::Status->menu_item(
341							'DBI' => 'DBI connections',
342							\&status_function
343							);
344							}
345							}
346
347							1;
348
349							__END__
350
351
352							=head1 NAME
353
354							Apache::DBI - Initiate a persistent database connection
355
356
357							=head1 SYNOPSIS
358
359							# Configuration in httpd.conf or startup.pl:
360
361							PerlModule Apache::DBI # this comes before all other modules using DBI
362
363							Do NOT change anything in your scripts. The usage of this module is
364							absolutely transparent !
365
366
367							=head1 DESCRIPTION
368
369							This module initiates a persistent database connection.
370
371							The database access uses Perl's DBI. For supported DBI drivers see:
372
373							http://dbi.perl.org/
374
375							When loading the DBI module (do not confuse this with the Apache::DBI module)
376							it looks if the environment variable GATEWAY_INTERFACE starts with 'CGI-Perl'
377							and if the module Apache::DBI has been loaded. In this case every connect
378							request will be forwarded to the Apache::DBI module. This looks if a database
379							handle from a previous connect request is already stored and if this handle is
380							still valid using the ping method. If these two conditions are fulfilled it
381							just returns the database handle. The parameters defining the connection have
382							to be exactly the same, including the connect attributes! If there is no
383							appropriate database handle or if the ping method fails, a new connection is
384							established and the handle is stored for later re-use. There is no need to
385							remove the disconnect statements from your code. They won't do anything
386							because the Apache::DBI module overloads the disconnect method.
387
388							The Apache::DBI module still has a limitation: it keeps database connections
389							persistent on a per process basis. The problem is, if a user accesses several
390							times a database, the http requests will be handled very likely by different
391							servers. Every server needs to do its own connect. It would be nice, if all
392							servers could share the database handles. Currently this is not possible,
393							because of the distinct name-space of every process. Also it is not possible
394							to create a database handle upon startup of the httpd and then inheriting this
395							handle to every subsequent server. This will cause clashes when the handle is
396							used by two processes at the same time.
397
398							With this limitation in mind, there are scenarios, where the usage of
399							Apache::DBI is depreciated. Think about a heavy loaded Web-site where every
400							user connects to the database with a unique userid. Every server would create
401							many database handles each of which spawning a new backend process. In a short
402							time this would kill the web server.
403
404							Another problem are timeouts: some databases disconnect the client after a
405							certain time of inactivity. The module tries to validate the database handle
406							using the ping-method of the DBI-module. This method returns true as default.
407							If the database handle is not valid and the driver has no implementation for
408							the ping method, you will get an error when accessing the database. As a
409							work-around you can try to replace the ping method by any database command,
410							which is cheap and safe or you can deactivate the usage of the ping method
411							(see CONFIGURATION below).
412
413							Here is generalized ping method, which can be added to the driver module:
414
415							package DBD::xxx::db; # ====== DATABASE ======
416							use strict;
417
418							sub ping {
419							my ($dbh) = @_;
420							my $ret = 0;
421							eval {
422							local $SIG{__DIE__} = sub { return (0); };
423							local $SIG{__WARN__} = sub { return (0); };
424							# adapt the select statement to your database:
425							$ret = $dbh->do('select 1');
426							};
427							return ($@) ? 0 : $ret;
428							}
429
430							Transactions: a standard DBI script will automatically perform a rollback
431							whenever the script exits. In the case of persistent database connections,
432							the database handle will not be destroyed and hence no automatic rollback
433							occurs. At a first glance it seems even to be possible, to handle a transaction
434							over multiple requests. But this should be avoided, because different
435							requests are handled by different servers and a server does not know the state
436							of a specific transaction which has been started by another server. In general
437							it is good practice to perform an explicit commit or rollback at the end of
438							every script. In order to avoid inconsistencies in the database in case
439							AutoCommit is off and the script finishes without an explicit rollback, the
440							Apache::DBI module uses a PerlCleanupHandler to issue a rollback at the
441							end of every request. Note, that this CleanupHandler will only be used, if
442							the initial data_source sets AutoCommit = 0 or AutoCommit is turned off, after
443							the connect has been done (ie begin_work). However, because a connection may
444							have set other parameters, the handle is reset to its initial connection state
445							before it is returned for a second time.
446
447							This module plugs in a menu item for Apache::Status or Apache2::Status.
448							The menu lists the current database connections. It should be considered
449							incomplete because of the limitations explained above. It shows the current
450							database connections for one specific server, the one which happens to serve
451							the current request. Other servers might have other database connections.
452							The Apache::Status/Apache2::Status module has to be loaded before the
453							Apache::DBI module !
454
455							=head1 CONFIGURATION
456
457							The module should be loaded upon startup of the Apache daemon.
458							Add the following line to your httpd.conf or startup.pl:
459
460							PerlModule Apache::DBI
461
462							It is important, to load this module before any other modules using DBI !
463
464							A common usage is to load the module in a startup file via the PerlRequire
465							directive. See eg/startup.pl and eg/startup2.pl for examples.
466
467							There are two configurations which are server-specific and which can be done
468							upon server startup:
469
470							Apache::DBI->connect_on_init($data_source, $username, $auth, \%attr)
471
472							This can be used as a simple way to have apache servers establish connections
473							on process startup.
474
475							Apache::DBI->setPingTimeOut($data_source, $timeout)
476
477							This configures the usage of the ping method, to validate a connection.
478							Setting the timeout to 0 will always validate the database connection
479							using the ping method (default). Setting the timeout < 0 will de-activate
480							the validation of the database handle. This can be used for drivers, which
481							do not implement the ping-method. Setting the timeout > 0 will ping the
482							database only if the last access was more than timeout seconds before.
483
484							For the menu item 'DBI connections' you need to call
485							Apache::Status/Apache2::Status BEFORE Apache::DBI ! For an example of the
486							configuration order see startup.pl.
487
488							To enable debugging the variable $Apache::DBI::DEBUG must be set. This
489							can either be done in startup.pl or in the user script. Setting the variable
490							to 1, just reports about a new connect. Setting the variable to 2 enables full
491							debug output.
492
493							=head1 PREREQUISITES
494
495							Note that this module needs mod_perl-1.08 or higher, apache_1.3.0 or higher
496							and that mod_perl needs to be configured with the appropriate call-back hooks:
497
498							PERL_CHILD_INIT=1 PERL_STACKED_HANDLERS=1.
499
500							=head1 MOD_PERL 2.0
501
502							Apache::DBI version 0.96 and should work under mod_perl 2.0 RC5 and later.
503							See the Changes file for more information. Beware that it has
504							only been tested very lightly.
505
506							=head1 SEE ALSO
507
508							L<Apache>, L<mod_perl>, L<DBI>
509
510							=head1 AUTHORS
511
512							=item *
513							Philip M. Gollucci <pgollucci@p6m7g8.com> is currently packaging new releases.
514							Ask Bjoern Hansen <ask@develooper.com> package a large number of releases.
515
516							=item *
517							Edmund Mergl was the original author of Apache::DBI. It is now
518							supported and maintained by the modperl mailinglist, see the mod_perl
519							documentation for instructions on how to subscribe.
520
521							=item *
522							mod_perl by Doug MacEachern.
523
524							=item *
525							DBI by Tim Bunce <dbi-users-subscribe@perl.org>
526
527							=head1 COPYRIGHT
528
529							The Apache::DBI module is free software; you can redistribute it and/or
530							modify it under the same terms as Perl itself.
531
532							=cut
533