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