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