1# $Id: DBI.pm 1140245 2011-06-27 17:25:53Z phred $ 2package Apache::DBI; 3use strict; 4 5use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} && 6 $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0; 7 8BEGIN { 9 if (MP2) { 10 require mod_perl2; 11 require Apache2::Module; 12 require Apache2::RequestUtil; 13 require Apache2::ServerUtil; 14 } 15 elsif (defined $modperl::VERSION && $modperl::VERSION > 1 && 16 $modperl::VERSION < 1.99) { 17 require Apache; 18 } 19} 20use DBI (); 21use Carp (); 22 23require_version DBI 1.00; 24 25$Apache::DBI::VERSION = '1.11'; 26 27# 1: report about new connect 28# 2: full debug output 29$Apache::DBI::DEBUG = 0; 30#DBI->trace(2); 31 32my %Connected; # cache for database handles 33my @ChildConnect; # connections to be established when a new 34 # httpd child is created 35my %Rollback; # keeps track of pushed PerlCleanupHandler 36 # which can do a rollback after the request 37 # has finished 38my %PingTimeOut; # stores the timeout values per data_source, 39 # a negative value de-activates ping, 40 # default = 0 41my %LastPingTime; # keeps track of last ping per data_source 42my $ChildExitHandlerInstalled; # set to true on installation of 43 # PerlChildExitHandler 44my $InChild; 45 46# Check to see if we need to reset TaintIn and TaintOut 47my $TaintInOut = ($DBI::VERSION >= 1.31) ? 1 : 0; 48 49sub debug { 50 print STDERR "$_[1]\n" if $Apache::DBI::DEBUG >= $_[0]; 51} 52 53# supposed to be called in a startup script. 54# stores the data_source of all connections, which are supposed to be created 55# upon server startup, and creates a PerlChildInitHandler, which initiates 56# the connections. Provide a handler which creates all connections during 57# server startup 58sub connect_on_init { 59 60 if (MP2) { 61 if (!@ChildConnect) { 62 my $s = Apache2::ServerUtil->server; 63 $s->push_handlers(PerlChildInitHandler => \&childinit); 64 } 65 } 66 else { 67 Carp::carp("Apache.pm was not loaded\n") 68 and return unless $INC{'Apache.pm'}; 69 70 if (!@ChildConnect and Apache->can('push_handlers')) { 71 Apache->push_handlers(PerlChildInitHandler => \&childinit); 72 } 73 } 74 75 # store connections 76 push @ChildConnect, [@_]; 77} 78 79# supposed to be called in a startup script. 80# stores the timeout per data_source for the ping function. 81# use a DSN without attribute settings specified within ! 82sub setPingTimeOut { 83 my $class = shift; 84 my $data_source = shift; 85 my $timeout = shift; 86 87 # sanity check 88 if ($data_source =~ /dbi:\w+:.*/ and $timeout =~ /\-*\d+/) { 89 $PingTimeOut{$data_source} = $timeout; 90 } 91} 92 93# the connect method called from DBI::connect 94sub connect { 95 my $class = shift; 96 unshift @_, $class if ref $class; 97 my $drh = shift; 98 99 my @args = map { defined $_ ? $_ : "" } @_; 100 my $dsn = "dbi:$drh->{Name}:$args[0]"; 101 my $prefix = "$$ Apache::DBI "; 102 103 # key of %Connected and %Rollback. 104 my $Idx = join $;, $args[0], $args[1], $args[2]; 105 106 # the hash-reference differs between calls even in the same 107 # process, so de-reference the hash-reference 108 if (3 == $#args and ref $args[3] eq "HASH") { 109 # should we default to '__undef__' or something for undef values? 110 map { 111 $Idx .= "$;$_=" . 112 (defined $args[3]->{$_} 113 ? $args[3]->{$_} 114 : '') 115 } sort keys %{$args[3]}; 116 } 117 elsif (3 == $#args) { 118 pop @args; 119 } 120 121 # don't cache connections created during server initialization; they 122 # won't be useful after ChildInit, since multiple processes trying to 123 # work over the same database connection simultaneously will receive 124 # unpredictable query results. 125 # See: http://perl.apache.org/docs/2.0/user/porting/compat.html#C__Apache__Server__Starting__and_C__Apache__Server__ReStarting_ 126 if (MP2) { 127 require Apache2::ServerUtil; 128 if (Apache2::ServerUtil::restart_count() == 1) { 129 debug(2, "$prefix skipping connection during server startup, read the docu !!"); 130 return $drh->connect(@args); 131 } 132 } 133 else { 134 if ($Apache::ServerStarting and $Apache::ServerStarting == 1) { 135 debug(2, "$prefix skipping connection during server startup, read the docu !!"); 136 return $drh->connect(@args); 137 } 138 } 139 140 # this PerlChildExitHandler is supposed to disconnect all open 141 # connections to the database 142 if (!$ChildExitHandlerInstalled) { 143 $ChildExitHandlerInstalled = 1; 144 my $s; 145 if (MP2) { 146 $s = Apache2::ServerUtil->server; 147 } 148 elsif (Apache->can('push_handlers')) { 149 $s = 'Apache'; 150 } 151 if ($s) { 152 debug(2, "$prefix push PerlChildExitHandler"); 153 $s->push_handlers(PerlChildExitHandler => \&childexit); 154 } 155 } 156 157 # this PerlCleanupHandler is supposed to initiate a rollback after the 158 # script has finished if AutoCommit is off. however, cleanup can only 159 # be determined at end of handle life as begin_work may have been called 160 # to temporarily turn off AutoCommit. 161 if (!$Rollback{$Idx}) { 162 my $r; 163 if (MP2) { 164 # We may not actually be in a request, but in <Perl> (or 165 # equivalent such as startup.pl), in which case this would die. 166 eval { $r = Apache2::RequestUtil->request }; 167 } 168 elsif (Apache->can('push_handlers')) { 169 $r = 'Apache'; 170 } 171 if ($r) { 172 debug(2, "$prefix push PerlCleanupHandler"); 173 $r->push_handlers("PerlCleanupHandler", sub { cleanup($Idx) }); 174 # make sure, that the rollback is called only once for every 175 # request, even if the script calls connect more than once 176 $Rollback{$Idx} = 1; 177 } 178 } 179 180 # do we need to ping the database ? 181 $PingTimeOut{$dsn} = 0 unless $PingTimeOut{$dsn}; 182 $LastPingTime{$dsn} = 0 unless $LastPingTime{$dsn}; 183 my $now = time; 184 # Must ping if TimeOut = 0 else base on time 185 my $needping = ($PingTimeOut{$dsn} == 0 or 186 ($PingTimeOut{$dsn} > 0 and 187 $now - $LastPingTime{$dsn} > $PingTimeOut{$dsn}) 188 ) ? 1 : 0; 189 debug(2, "$prefix need ping: " . ($needping == 1 ? "yes" : "no")); 190 $LastPingTime{$dsn} = $now; 191 192 # check first if there is already a database-handle cached 193 # if this is the case, possibly verify the database-handle 194 # using the ping-method. Use eval for checking the connection 195 # handle in order to avoid problems (dying inside ping) when 196 # RaiseError being on and the handle is invalid. 197 if ($Connected{$Idx} and (!$needping or eval{$Connected{$Idx}->ping})) { 198 debug(2, "$prefix already connected to '$Idx'"); 199 200 # Force clean up of handle in case previous transaction failed to 201 # clean up the handle 202 &reset_startup_state($Idx); 203 204 return (bless $Connected{$Idx}, 'Apache::DBI::db'); 205 } 206 207 # either there is no database handle-cached or it is not valid, 208 # so get a new database-handle and store it in the cache 209 delete $Connected{$Idx}; 210 $Connected{$Idx} = $drh->connect(@args); 211 return undef if !$Connected{$Idx}; 212 213 # store the parameters of the initial connection in the handle 214 set_startup_state($Idx); 215 216 # return the new database handle 217 debug(1, "$prefix new connect to '$Idx'"); 218 return (bless $Connected{$Idx}, 'Apache::DBI::db'); 219} 220 221# The PerlChildInitHandler creates all connections during server startup. 222# Note: this handler runs in every child server, but not in the main server. 223sub childinit { 224 225 my $prefix = "$$ Apache::DBI "; 226 debug(2, "$prefix PerlChildInitHandler"); 227 228 %Connected = () if MP2; 229 230 if (@ChildConnect) { 231 for my $aref (@ChildConnect) { 232 shift @$aref; 233 DBI->connect(@$aref); 234 $LastPingTime{@$aref[0]} = time; 235 } 236 } 237 238 1; 239} 240 241# The PerlChildExitHandler disconnects all open connections 242sub childexit { 243 244 my $prefix = "$$ Apache::DBI "; 245 debug(2, "$prefix PerlChildExitHandler"); 246 247 foreach my $dbh (values(%Connected)) { 248 eval { DBI::db::disconnect($dbh) }; 249 if ($@) { 250 debug(2, "$prefix DBI::db::disconnect failed - $@"); 251 } 252 } 253 254 1; 255} 256 257# The PerlCleanupHandler is supposed to initiate a rollback after the script 258# has finished if AutoCommit is off. 259# Note: the PerlCleanupHandler runs after the response has been sent to 260# the client 261sub cleanup { 262 my $Idx = shift; 263 264 my $prefix = "$$ Apache::DBI "; 265 debug(2, "$prefix PerlCleanupHandler"); 266 267 my $dbh = $Connected{$Idx}; 268 if ($Rollback{$Idx} 269 and $dbh 270 and $dbh->{Active} 271 and !$dbh->{AutoCommit} 272 and eval {$dbh->rollback}) { 273 debug (2, "$prefix PerlCleanupHandler rollback for '$Idx'"); 274 } 275 276 delete $Rollback{$Idx}; 277 278 1; 279} 280 281# Store the default start state of each dbh in the handle 282# Note: This uses private_Apache_DBI hash ref to store it in the handle itself 283my @attrs = qw( 284 AutoCommit Warn CompatMode InactiveDestroy 285 PrintError RaiseError HandleError 286 ShowErrorStatement TraceLevel FetchHashKeyName 287 ChopBlanks LongReadLen LongTruncOk 288 Taint Profile 289); 290 291sub set_startup_state { 292 my $Idx = shift; 293 294 foreach my $key (@attrs) { 295 $Connected{$Idx}->{private_Apache_DBI}{$key} = 296 $Connected{$Idx}->{$key}; 297 } 298 299 if ($TaintInOut) { 300 foreach my $key ( qw{ TaintIn TaintOut } ) { 301 $Connected{$Idx}->{private_Apache_DBI}{$key} = 302 $Connected{$Idx}->{$key}; 303 } 304 } 305 306 1; 307} 308 309# Restore the default start state of each dbh 310sub reset_startup_state { 311 my $Idx = shift; 312 313 # Rollback current transaction if currently in one 314 $Connected{$Idx}->{Active} 315 and !$Connected{$Idx}->{AutoCommit} 316 and eval {$Connected{$Idx}->rollback}; 317 318 foreach my $key (@attrs) { 319 $Connected{$Idx}->{$key} = 320 $Connected{$Idx}->{private_Apache_DBI}{$key}; 321 } 322 323 if ($TaintInOut) { 324 foreach my $key ( qw{ TaintIn TaintOut } ) { 325 $Connected{$Idx}->{$key} = 326 $Connected{$Idx}->{private_Apache_DBI}{$key}; 327 } 328 } 329 330 1; 331} 332 333 334# This function can be called from other handlers to perform tasks on all 335# cached database handles. 336sub all_handlers { return \%Connected } 337 338# patch from Tim Bunce: Apache::DBI will not return a DBD ref cursor 339@Apache::DBI::st::ISA = ('DBI::st'); 340 341# overload disconnect 342{ 343 package Apache::DBI::db; 344 no strict; 345 @ISA=qw(DBI::db); 346 use strict; 347 sub disconnect { 348 my $prefix = "$$ Apache::DBI "; 349 Apache::DBI::debug(2, "$prefix disconnect (overloaded)"); 350 1; 351 } 352 ; 353} 354 355# prepare menu item for Apache::Status 356sub status_function { 357 my($r, $q) = @_; 358 359 my(@s) = qw(<TABLE><TR><TD>Datasource</TD><TD>Username</TD></TR>); 360 for (keys %Connected) { 361 push @s, '<TR><TD>', 362 join('</TD><TD>', 363 (split($;, $_))[0,1]), "</TD></TR>\n"; 364 } 365 push @s, '</TABLE>'; 366 367 \@s; 368} 369 370if (MP2) { 371 if (Apache2::Module::loaded('Apache2::Status')) { 372 Apache2::Status->menu_item( 373 'DBI' => 'DBI connections', 374 \&status_function 375 ); 376 } 377} 378else { 379 if ($INC{'Apache.pm'} # is Apache.pm loaded? 380 and Apache->can('module') # really? 381 and Apache->module('Apache::Status')) { # Apache::Status too? 382 Apache::Status->menu_item( 383 'DBI' => 'DBI connections', 384 \&status_function 385 ); 386 } 387} 388 3891; 390 391__END__ 392 393 394=head1 NAME 395 396Apache::DBI - Initiate a persistent database connection 397 398 399=head1 SYNOPSIS 400 401 # Configuration in httpd.conf or startup.pl: 402 403 PerlModule Apache::DBI # this comes before all other modules using DBI 404 405Do NOT change anything in your scripts. The usage of this module is 406absolutely transparent ! 407 408 409=head1 DESCRIPTION 410 411This module initiates a persistent database connection. 412 413The database access uses Perl's DBI. For supported DBI drivers see: 414 415 http://dbi.perl.org/ 416 417When loading the DBI module (do not confuse this with the Apache::DBI module) 418it checks if the environment variable 'MOD_PERL' has been set 419and if the module Apache::DBI has been loaded. In this case every connect 420request will be forwarded to the Apache::DBI module. This checks if a database 421handle from a previous connect request is already stored and if this handle is 422still valid using the ping method. If these two conditions are fulfilled it 423just returns the database handle. The parameters defining the connection have 424to be exactly the same, including the connect attributes! If there is no 425appropriate database handle or if the ping method fails, a new connection is 426established and the handle is stored for later re-use. There is no need to 427remove the disconnect statements from your code. They won't do anything 428because the Apache::DBI module overloads the disconnect method. 429 430The Apache::DBI module still has a limitation: it keeps database connections 431persistent on a per process basis. The problem is, if a user accesses a database 432several times, the http requests will be handled very likely by different 433processes. Every process needs to do its own connect. It would be nice if all 434servers could share the database handles, but currently this is not possible 435because of the distinct memory-space of each process. Also it is not possible 436to create a database handle upon startup of the httpd and then inherit this 437handle to every subsequent server. This will cause clashes when the handle is 438used by two processes at the same time. Apache::DBI has built-in protection 439against this. It will not make a connection persistent if it sees that it is 440being opened during the server startup. This allows you to safely open a connection 441for grabbing data needed at startup and disconnect it normally before the end of 442startup. 443 444With this limitation in mind, there are scenarios, where the usage of 445Apache::DBI is depreciated. Think about a heavy loaded Web-site where every 446user connects to the database with a unique userid. Every server would create 447many database handles each of which spawning a new backend process. In a short 448time this would kill the web server. 449 450Another problem are timeouts: some databases disconnect the client after a 451certain period of inactivity. The module tries to validate the database handle 452using the C<ping()> method of the DBI-module. This method returns true by default. 453Most DBI drivers have a working C<ping()> method, but if the driver you're using 454doesn't have one and the database handle is no longer valid, you will get an error 455when accessing the database. As a work-around you can try to add your own C<ping()> 456method using any database command which is cheap and safe, or you can deactivate the 457usage of the ping method (see CONFIGURATION below). 458 459Here is a generalized ping method, which can be added to the driver module: 460 461 package DBD::xxx::db; # ====== DATABASE ====== 462 use strict; 463 464 sub ping { 465 my ($dbh) = @_; 466 my $ret = 0; 467 eval { 468 local $SIG{__DIE__} = sub { return (0); }; 469 local $SIG{__WARN__} = sub { return (0); }; 470 # adapt the select statement to your database: 471 $ret = $dbh->do('select 1'); 472 }; 473 return ($@) ? 0 : $ret; 474 } 475 476Transactions: a standard DBI script will automatically perform a rollback 477whenever the script exits. In the case of persistent database connections, 478the database handle will not be destroyed and hence no automatic rollback 479will occur. At a first glance it even seems possible to handle a transaction 480over multiple requests. But this should be avoided, because different 481requests are handled by different processes and a process does not know the state 482of a specific transaction which has been started by another process. In general, 483it is good practice to perform an explicit commit or rollback at the end of 484every request. In order to avoid inconsistencies in the database in case 485AutoCommit is off and the script finishes without an explicit rollback, the 486Apache::DBI module uses a PerlCleanupHandler to issue a rollback at the 487end of every request. Note, that this CleanupHandler will only be used, if 488the initial data_source sets AutoCommit = 0 or AutoCommit is turned off, after 489the connect has been done (ie begin_work). However, because a connection may 490have set other parameters, the handle is reset to its initial connection state 491before it is returned for a second time. 492 493This module plugs in a menu item for Apache::Status or Apache2::Status. 494The menu lists the current database connections. It should be considered 495incomplete because of the limitations explained above. It shows the current 496database connections for one specific process, the one which happens to serve 497the current request. Other processes might have other database connections. 498The Apache::Status/Apache2::Status module has to be loaded before the 499Apache::DBI module ! 500 501=head1 CONFIGURATION 502 503The module should be loaded upon startup of the Apache daemon. 504Add the following line to your httpd.conf or startup.pl: 505 506 PerlModule Apache::DBI 507 508It is important, to load this module before any other modules using DBI ! 509 510A common usage is to load the module in a startup file called via the PerlRequire 511directive. See eg/startup.pl and eg/startup2.pl for examples. 512 513There are two configurations which are server-specific and which can be done 514upon server startup: 515 516 Apache::DBI->connect_on_init($data_source, $username, $auth, \%attr) 517 518This can be used as a simple way to have apache servers establish connections 519on process startup. 520 521 Apache::DBI->setPingTimeOut($data_source, $timeout) 522 523This configures the usage of the ping method, to validate a connection. 524Setting the timeout to 0 will always validate the database connection 525using the ping method (default). Setting the timeout < 0 will de-activate 526the validation of the database handle. This can be used for drivers, which 527do not implement the ping-method. Setting the timeout > 0 will ping the 528database only if the last access was more than timeout seconds before. 529 530For the menu item 'DBI connections' you need to call 531Apache::Status/Apache2::Status BEFORE Apache::DBI ! For an example of the 532configuration order see startup.pl. 533 534To enable debugging the variable $Apache::DBI::DEBUG must be set. This 535can either be done in startup.pl or in the user script. Setting the variable 536to 1, just reports about a new connect. Setting the variable to 2 enables full 537debug output. 538 539=head1 PREREQUISITES 540 541=head2 MOD_PERL 2.0 542 543Apache::DBI version 0.96 and later should work under mod_perl 2.0 RC5 and later 544with httpd 2.0.49 and later. 545 546Apache::DBI versions less than 1.00 are NO longer supported. Additionally, 547mod_perl versions less then 2.0.0 are NO longer supported. 548 549=head2 MOD_PERL 1.0 550Note that this module needs mod_perl-1.08 or higher, apache_1.3.0 or higher 551and that mod_perl needs to be configured with the appropriate call-back hooks: 552 553 PERL_CHILD_INIT=1 PERL_STACKED_HANDLERS=1 554 555Apache::DBI v0.94 was the last version before dual mod_perl 2.x support was begun. 556It still recommended that you use the latest version of Apache::DBI because Apache::DBI 557versions less than 1.00 are NO longer supported. 558 559=head1 DO YOU NEED THIS MODULE? 560 561Note that this module is intended for use in porting existing DBI code to mod_perl, 562or writing code that can run under both mod_perl and CGI. If you are using a 563database abstraction layer such as Class::DBI or DBIx::Class that already manages persistent connections for you, there is no need to use this module 564in addition. (Another popular choice, Rose::DB::Object, can cooperate with 565Apache::DBI or use your own custom connection handling.) If you are developing 566new code that is strictly for use in mod_perl, you may choose to use 567C<< DBI->connect_cached() >> instead, but consider adding an automatic rollback 568after each request, as described above. 569 570=head1 SEE ALSO 571 572L<Apache>, L<mod_perl>, L<DBI> 573 574=head1 AUTHORS 575 576=over 577 578=item * 579Philip M. Gollucci <pgollucci@p6m7g8.com> is currently packaging new releases. 580 581Ask Bjoern Hansen <ask@develooper.com> packaged a large number of releases. 582 583=item * 584Edmund Mergl was the original author of Apache::DBI. It is now 585supported and maintained by the modperl mailinglist, see the mod_perl 586documentation for instructions on how to subscribe. 587 588=item * 589mod_perl by Doug MacEachern. 590 591=item * 592DBI by Tim Bunce <dbi-users-subscribe@perl.org> 593 594=back 595 596=head1 COPYRIGHT 597 598The Apache::DBI module is free software; you can redistribute it and/or 599modify it under the same terms as Perl itself. 600 601=cut 602