[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # -*- perl -*- 2 # 3 # 4 # DBD::Proxy - DBI Proxy driver 5 # 6 # 7 # Copyright (c) 1997,1998 Jochen Wiedmann 8 # 9 # The DBD::Proxy module is free software; you can redistribute it and/or 10 # modify it under the same terms as Perl itself. In particular permission 11 # is granted to Tim Bunce for distributing this as a part of the DBI. 12 # 13 # 14 # Author: Jochen Wiedmann 15 # Am Eisteich 9 16 # 72555 Metzingen 17 # Germany 18 # 19 # Email: joe@ispsoft.de 20 # Phone: +49 7123 14881 21 # 22 23 use strict; 24 use Carp; 25 26 require DBI; 27 DBI->require_version(1.0201); 28 29 use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released 30 31 { package DBD::Proxy::RPC::PlClient; 32 @DBD::Proxy::RPC::PlClient::ISA = qw(RPC::PlClient); 33 sub Call { 34 my $self = shift; 35 if ($self->{debug}) { 36 my ($rpcmeth, $obj, $method, @args) = @_; 37 local $^W; # silence undefs 38 Carp::carp("Server $rpcmeth $method(@args)"); 39 } 40 return $self->SUPER::Call(@_); 41 } 42 } 43 44 45 package DBD::Proxy; 46 47 use vars qw($VERSION $drh %ATTR); 48 49 $VERSION = "0.2004"; 50 51 $drh = undef; # holds driver handle once initialised 52 53 %ATTR = ( # common to db & st, see also %ATTR in DBD::Proxy::db & ::st 54 'Warn' => 'local', 55 'Active' => 'local', 56 'Kids' => 'local', 57 'CachedKids' => 'local', 58 'PrintError' => 'local', 59 'RaiseError' => 'local', 60 'HandleError' => 'local', 61 'TraceLevel' => 'cached', 62 'CompatMode' => 'local', 63 ); 64 65 sub driver ($$) { 66 if (!$drh) { 67 my($class, $attr) = @_; 68 69 $class .= "::dr"; 70 71 $drh = DBI::_new_drh($class, { 72 'Name' => 'Proxy', 73 'Version' => $VERSION, 74 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', 75 }); 76 $drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH) 77 } 78 $drh; 79 } 80 81 sub CLONE { 82 undef $drh; 83 } 84 85 sub proxy_set_err { 86 my ($h,$errmsg) = @_; 87 my ($err, $state) = ($errmsg =~ s/ \[err=(.*?),state=(.*?)\]//) 88 ? ($1, $2) : (1, ' ' x 5); 89 return $h->set_err($err, $errmsg, $state); 90 } 91 92 package DBD::Proxy::dr; # ====== DRIVER ====== 93 94 $DBD::Proxy::dr::imp_data_size = 0; 95 96 sub connect ($$;$$) { 97 my($drh, $dsn, $user, $auth, $attr)= @_; 98 my($dsnOrig) = $dsn; 99 100 my %attr = %$attr; 101 my ($var, $val); 102 while (length($dsn)) { 103 if ($dsn =~ /^dsn=(.*)/) { 104 $attr{'dsn'} = $1; 105 last; 106 } 107 if ($dsn =~ /^(.*?);(.*)/) { 108 $var = $1; 109 $dsn = $2; 110 } else { 111 $var = $dsn; 112 $dsn = ''; 113 } 114 if ($var =~ /^(.*?)=(.*)/) { 115 $var = $1; 116 $val = $2; 117 $attr{$var} = $val; 118 } 119 } 120 121 my $err = ''; 122 if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; } 123 if (!defined($attr{'port'})) { $err .= " Missing port."; } 124 if (!defined($attr{'dsn'})) { $err .= " Missing remote dsn."; } 125 126 # Create a cipher object, if requested 127 my $cipherRef = undef; 128 if ($attr{'cipher'}) { 129 $cipherRef = eval { $attr{'cipher'}->new(pack('H*', 130 $attr{'key'})) }; 131 if ($@) { $err .= " Cannot create cipher object: $@."; } 132 } 133 my $userCipherRef = undef; 134 if ($attr{'userkey'}) { 135 my $cipher = $attr{'usercipher'} || $attr{'cipher'}; 136 $userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) }; 137 if ($@) { $err .= " Cannot create usercipher object: $@."; } 138 } 139 140 return DBD::Proxy::proxy_set_err($drh, $err) if $err; # Returns undef 141 142 my %client_opts = ( 143 'peeraddr' => $attr{'hostname'}, 144 'peerport' => $attr{'port'}, 145 'socket_proto' => 'tcp', 146 'application' => $attr{dsn}, 147 'user' => $user || '', 148 'password' => $auth || '', 149 'version' => $DBD::Proxy::VERSION, 150 'cipher' => $cipherRef, 151 'debug' => $attr{debug} || 0, 152 'timeout' => $attr{timeout} || undef, 153 'logfile' => $attr{logfile} || undef 154 ); 155 # Options starting with 'proxy_rpc_' are forwarded to the RPC layer after 156 # stripping the prefix. 157 while (my($var,$val) = each %attr) { 158 if ($var =~ s/^proxy_rpc_//) { 159 $client_opts{$var} = $val; 160 } 161 } 162 # Create an RPC::PlClient object. 163 my($client, $msg) = eval { DBD::Proxy::RPC::PlClient->new(%client_opts) }; 164 165 return DBD::Proxy::proxy_set_err($drh, "Cannot log in to DBI::ProxyServer: $@") 166 if $@; # Returns undef 167 return DBD::Proxy::proxy_set_err($drh, "Constructor didn't return a handle: $msg") 168 unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef 169 170 $msg = RPC::PlClient::Object->new($1, $client, $msg); 171 172 my $max_proto_ver; 173 my ($server_ver_str) = eval { $client->Call('Version') }; 174 if ( $@ ) { 175 # Server denies call, assume legacy protocol. 176 $max_proto_ver = 1; 177 } else { 178 # Parse proxy server version. 179 my ($server_ver_num) = $server_ver_str =~ /^DBI::ProxyServer\s+([\d\.]+)/; 180 $max_proto_ver = $server_ver_num >= 0.3 ? 2 : 1; 181 } 182 my $req_proto_ver; 183 if ( exists $attr{proxy_lazy_prepare} ) { 184 $req_proto_ver = ($attr{proxy_lazy_prepare} == 0) ? 2 : 1; 185 return DBD::Proxy::proxy_set_err($drh, 186 "DBI::ProxyServer does not support synchronous statement preparation.") 187 if $max_proto_ver < $req_proto_ver; 188 } 189 190 # Switch to user specific encryption mode, if desired 191 if ($userCipherRef) { 192 $client->{'cipher'} = $userCipherRef; 193 } 194 195 # create a 'blank' dbh 196 my $this = DBI::_new_dbh($drh, { 197 'Name' => $dsnOrig, 198 'proxy_dbh' => $msg, 199 'proxy_client' => $client, 200 'RowCacheSize' => $attr{'RowCacheSize'} || 20, 201 'proxy_proto_ver' => $req_proto_ver || 1 202 }); 203 204 foreach $var (keys %attr) { 205 if ($var =~ /proxy_/) { 206 $this->{$var} = $attr{$var}; 207 } 208 } 209 $this->SUPER::STORE('Active' => 1); 210 211 $this; 212 } 213 214 215 sub DESTROY { undef } 216 217 218 package DBD::Proxy::db; # ====== DATABASE ====== 219 220 $DBD::Proxy::db::imp_data_size = 0; 221 222 # XXX probably many more methods need to be added here 223 # in order to trigger our AUTOLOAD to redirect them to the server. 224 # (Unless the sub is declared it's bypassed by perl method lookup.) 225 # See notes in ToDo about method metadata 226 # The question is whether to add all the methods in %DBI::DBI_methods 227 # to the corresponding classes (::db, ::st etc) 228 # Also need to consider methods that, if proxied, would change the server state 229 # in a way that might not be visible on the client, ie begin_work -> AutoCommit. 230 231 sub commit; 232 sub connected; 233 sub rollback; 234 sub ping; 235 236 237 use vars qw(%ATTR $AUTOLOAD); 238 239 # inherited: STORE / FETCH against this class. 240 # local: STORE / FETCH against parent class. 241 # cached: STORE to remote and local objects, FETCH from local. 242 # remote: STORE / FETCH against remote object only (default). 243 # 244 # Note: Attribute names starting with 'proxy_' always treated as 'inherited'. 245 # 246 %ATTR = ( # see also %ATTR in DBD::Proxy::st 247 %DBD::Proxy::ATTR, 248 RowCacheSize => 'inherited', 249 #AutoCommit => 'cached', 250 'FetchHashKeyName' => 'cached', 251 Statement => 'local', 252 Driver => 'local', 253 dbi_connect_closure => 'local', 254 Username => 'local', 255 ); 256 257 sub AUTOLOAD { 258 my $method = $AUTOLOAD; 259 $method =~ s/(.*::(.*)):://; 260 my $class = $1; 261 my $type = $2; 262 #warn "AUTOLOAD of $method (class=$class, type=$type)"; 263 my %expand = ( 264 'method' => $method, 265 'class' => $class, 266 'type' => $type, 267 'call' => "$method(\@_)", 268 # XXX was trying to be smart but was tripping up over the DBI's own 269 # smartness. Disabled, but left here in case there are issues. 270 # 'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')", 271 ); 272 273 my $method_code = q{ 274 package ~class~; 275 sub ~method~ { 276 my $h = shift; 277 local $@; 278 my @result = wantarray 279 ? eval { $h->{'proxy_~type~h'}->~call~ } 280 : eval { scalar $h->{'proxy_~type~h'}->~call~ }; 281 return DBD::Proxy::proxy_set_err($h, $@) if $@; 282 return wantarray ? @result : $result[0]; 283 } 284 }; 285 $method_code =~ s/\~(\w+)\~/$expand{$1}/eg; 286 local $SIG{__DIE__} = 'DEFAULT'; 287 my $err = do { local $@; eval $method_code.2; $@ }; 288 die $err if $err; 289 goto &$AUTOLOAD; 290 } 291 292 sub DESTROY { 293 my $dbh = shift; 294 local $@ if $@; # protect $@ 295 $dbh->disconnect if $dbh->SUPER::FETCH('Active'); 296 } 297 298 sub disconnect ($) { 299 my ($dbh) = @_; 300 301 # Sadly the Proxy too-often disagrees with the backend database 302 # on the subject of 'Active'. In the short term, I'd like the 303 # Proxy to ease up and let me decide when it's proper to go over 304 # the wire. This ultimately applies to finish() as well. 305 #return unless $dbh->SUPER::FETCH('Active'); 306 307 # Drop database connection at remote end 308 my $rdbh = $dbh->{'proxy_dbh'}; 309 if ( $rdbh ) { 310 local $SIG{__DIE__} = 'DEFAULT'; 311 local $@; 312 eval { $rdbh->disconnect() } ; 313 DBD::Proxy::proxy_set_err($dbh, $@) if $@; 314 } 315 316 # Close TCP connect to remote 317 # XXX possibly best left till DESTROY? Add a config attribute to choose? 318 #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module 319 $dbh->{proxy_client}->{socket} = undef; # hack 320 321 $dbh->SUPER::STORE('Active' => 0); 322 1; 323 } 324 325 326 sub STORE ($$$) { 327 my($dbh, $attr, $val) = @_; 328 my $type = $ATTR{$attr} || 'remote'; 329 330 if ($attr eq 'TraceLevel') { 331 warn("TraceLevel $val"); 332 my $pc = $dbh->{proxy_client} || die; 333 $pc->{logfile} ||= 1; # XXX hack 334 $pc->{debug} = ($val && $val >= 4); 335 $pc->Debug("$pc debug enabled") if $pc->{debug}; 336 } 337 338 if ($attr =~ /^proxy_/ || $type eq 'inherited') { 339 $dbh->{$attr} = $val; 340 return 1; 341 } 342 343 if ($type eq 'remote' || $type eq 'cached') { 344 local $SIG{__DIE__} = 'DEFAULT'; 345 local $@; 346 my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) }; 347 return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef 348 $dbh->SUPER::STORE($attr => $val) if $type eq 'cached'; 349 return $result; 350 } 351 return $dbh->SUPER::STORE($attr => $val); 352 } 353 354 sub FETCH ($$) { 355 my($dbh, $attr) = @_; 356 # we only get here for cached attribute values if the handle is in CompatMode 357 # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache. 358 my $type = $ATTR{$attr} || 'remote'; 359 360 if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') { 361 return $dbh->{$attr}; 362 } 363 364 return $dbh->SUPER::FETCH($attr) unless $type eq 'remote'; 365 366 local $SIG{__DIE__} = 'DEFAULT'; 367 local $@; 368 my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) }; 369 return DBD::Proxy::proxy_set_err($dbh, $@) if $@; 370 return $result; 371 } 372 373 sub prepare ($$;$) { 374 my($dbh, $stmt, $attr) = @_; 375 my $sth = DBI::_new_sth($dbh, { 376 'Statement' => $stmt, 377 'proxy_attr' => $attr, 378 'proxy_cache_only' => 0, 379 'proxy_params' => [], 380 } 381 ); 382 my $proto_ver = $dbh->{'proxy_proto_ver'}; 383 if ( $proto_ver > 1 ) { 384 $sth->{'proxy_attr_cache'} = {cache_filled => 0}; 385 my $rdbh = $dbh->{'proxy_dbh'}; 386 local $SIG{__DIE__} = 'DEFAULT'; 387 local $@; 388 my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) }; 389 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 390 return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") 391 unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); 392 393 my $client = $dbh->{'proxy_client'}; 394 $rsth = RPC::PlClient::Object->new($1, $client, $rsth); 395 396 $sth->{'proxy_sth'} = $rsth; 397 # If statement is a positioned update we do not want any readahead. 398 $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i; 399 # Since resources are used by prepared remote handle, mark us active. 400 $sth->SUPER::STORE(Active => 1); 401 } 402 $sth; 403 } 404 405 sub quote { 406 my $dbh = shift; 407 my $proxy_quote = $dbh->{proxy_quote} || 'remote'; 408 409 return $dbh->SUPER::quote(@_) 410 if $proxy_quote eq 'local' && @_ == 1; 411 412 # For the common case of only a single argument 413 # (no $data_type) we could learn and cache the behaviour. 414 # Or we could probe the driver with a few test cases. 415 # Or we could add a way to ask the DBI::ProxyServer 416 # if $dbh->can('quote') == \&DBI::_::db::quote. 417 # Tim 418 # 419 # Sounds all *very* smart to me. I'd rather suggest to 420 # implement some of the typical quote possibilities 421 # and let the user set 422 # $dbh->{'proxy_quote'} = 'backslash_escaped'; 423 # for example. 424 # Jochen 425 local $SIG{__DIE__} = 'DEFAULT'; 426 local $@; 427 my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) }; 428 return DBD::Proxy::proxy_set_err($dbh, $@) if $@; 429 return $result; 430 } 431 432 sub table_info { 433 my $dbh = shift; 434 my $rdbh = $dbh->{'proxy_dbh'}; 435 #warn "table_info(@_)"; 436 local $SIG{__DIE__} = 'DEFAULT'; 437 local $@; 438 my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) }; 439 return DBD::Proxy::proxy_set_err($dbh, $@) if $@; 440 my ($sth, $inner) = DBI::_new_sth($dbh, { 441 'Statement' => "SHOW TABLES", 442 'proxy_params' => [], 443 'proxy_data' => \@rows, 444 'proxy_attr_cache' => { 445 'NUM_OF_PARAMS' => 0, 446 'NUM_OF_FIELDS' => $numFields, 447 'NAME' => $names, 448 'TYPE' => $types, 449 'cache_filled' => 1 450 }, 451 'proxy_cache_only' => 1, 452 }); 453 $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); 454 $inner->{NAME} = $names; 455 $inner->{TYPE} = $types; 456 $sth->SUPER::STORE('Active' => 1); # already execute()'d 457 $sth->{'proxy_rows'} = @rows; 458 return $sth; 459 } 460 461 sub tables { 462 my $dbh = shift; 463 #warn "tables(@_)"; 464 return $dbh->SUPER::tables(@_); 465 } 466 467 468 sub type_info_all { 469 my $dbh = shift; 470 local $SIG{__DIE__} = 'DEFAULT'; 471 local $@; 472 my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) }; 473 return DBD::Proxy::proxy_set_err($dbh, $@) if $@; 474 return $result; 475 } 476 477 478 package DBD::Proxy::st; # ====== STATEMENT ====== 479 480 $DBD::Proxy::st::imp_data_size = 0; 481 482 use vars qw(%ATTR); 483 484 # inherited: STORE to current object. FETCH from current if exists, else call up 485 # to the (proxy) database object. 486 # local: STORE / FETCH against parent class. 487 # cache_only: STORE noop (read-only). FETCH from private_* if exists, else call 488 # remote and cache the result. 489 # remote: STORE / FETCH against remote object only (default). 490 # 491 # Note: Attribute names starting with 'proxy_' always treated as 'inherited'. 492 # 493 %ATTR = ( # see also %ATTR in DBD::Proxy::db 494 %DBD::Proxy::ATTR, 495 'Database' => 'local', 496 'RowsInCache' => 'local', 497 'RowCacheSize' => 'inherited', 498 'NULLABLE' => 'cache_only', 499 'NAME' => 'cache_only', 500 'TYPE' => 'cache_only', 501 'PRECISION' => 'cache_only', 502 'SCALE' => 'cache_only', 503 'NUM_OF_FIELDS' => 'cache_only', 504 'NUM_OF_PARAMS' => 'cache_only' 505 ); 506 507 *AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD; 508 509 sub execute ($@) { 510 my $sth = shift; 511 my $params = @_ ? \@_ : $sth->{'proxy_params'}; 512 513 # new execute, so delete any cached rows from previous execute 514 undef $sth->{'proxy_data'}; 515 undef $sth->{'proxy_rows'}; 516 517 my $rsth = $sth->{proxy_sth}; 518 my $dbh = $sth->FETCH('Database'); 519 my $proto_ver = $dbh->{proxy_proto_ver}; 520 521 my ($numRows, @outData); 522 523 local $SIG{__DIE__} = 'DEFAULT'; 524 local $@; 525 if ( $proto_ver > 1 ) { 526 ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; 527 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 528 529 # Attributes passed back only on the first execute() of a statement. 530 unless ($sth->{proxy_attr_cache}->{cache_filled}) { 531 my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); 532 $sth->{'proxy_attr_cache'} = { 533 'NUM_OF_FIELDS' => $numFields, 534 'NUM_OF_PARAMS' => $numParams, 535 'NAME' => $names, 536 'cache_filled' => 1 537 }; 538 $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); 539 $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); 540 } 541 542 } 543 else { 544 if ($rsth) { 545 ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; 546 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 547 548 } 549 else { 550 my $rdbh = $dbh->{'proxy_dbh'}; 551 552 # Legacy prepare is actually prepare + first execute on the server. 553 ($rsth, @outData) = 554 eval { $rdbh->prepare($sth->{'Statement'}, 555 $sth->{'proxy_attr'}, $params, $proto_ver) }; 556 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 557 return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") 558 unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); 559 560 my $client = $dbh->{'proxy_client'}; 561 $rsth = RPC::PlClient::Object->new($1, $client, $rsth); 562 563 my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); 564 $sth->{'proxy_sth'} = $rsth; 565 $sth->{'proxy_attr_cache'} = { 566 'NUM_OF_FIELDS' => $numFields, 567 'NUM_OF_PARAMS' => $numParams, 568 'NAME' => $names 569 }; 570 $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); 571 $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); 572 $numRows = shift @outData; 573 } 574 } 575 # Always condition active flag. 576 $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT 577 $sth->{'proxy_rows'} = $numRows; 578 # Any remaining items are output params. 579 if (@outData) { 580 foreach my $p (@$params) { 581 if (ref($p->[0])) { 582 my $ref = shift @outData; 583 ${$p->[0]} = $$ref; 584 } 585 } 586 } 587 588 $sth->{'proxy_rows'} || '0E0'; 589 } 590 591 sub fetch ($) { 592 my $sth = shift; 593 594 my $data = $sth->{'proxy_data'}; 595 596 $sth->{'proxy_rows'} = 0 unless defined $sth->{'proxy_rows'}; 597 598 if(!$data || !@$data) { 599 return undef unless $sth->SUPER::FETCH('Active'); 600 601 my $rsth = $sth->{'proxy_sth'}; 602 if (!$rsth) { 603 die "Attempt to fetch row without execute"; 604 } 605 my $num_rows = $sth->FETCH('RowCacheSize') || 20; 606 local $SIG{__DIE__} = 'DEFAULT'; 607 local $@; 608 my @rows = eval { $rsth->fetch($num_rows) }; 609 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 610 unless (@rows == $num_rows) { 611 undef $sth->{'proxy_data'}; 612 # server side has already called finish 613 $sth->SUPER::STORE(Active => 0); 614 } 615 return undef unless @rows; 616 $sth->{'proxy_data'} = $data = [@rows]; 617 } 618 my $row = shift @$data; 619 620 $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data ); 621 $sth->{'proxy_rows'}++; 622 return $sth->_set_fbav($row); 623 } 624 *fetchrow_arrayref = \&fetch; 625 626 sub rows ($) { 627 my $rows = shift->{'proxy_rows'}; 628 return (defined $rows) ? $rows : -1; 629 } 630 631 sub finish ($) { 632 my($sth) = @_; 633 return 1 unless $sth->SUPER::FETCH('Active'); 634 my $rsth = $sth->{'proxy_sth'}; 635 $sth->SUPER::STORE('Active' => 0); 636 return 0 unless $rsth; # Something's out of sync 637 my $no_finish = exists($sth->{'proxy_no_finish'}) 638 ? $sth->{'proxy_no_finish'} 639 : $sth->FETCH('Database')->{'proxy_no_finish'}; 640 unless ($no_finish) { 641 local $SIG{__DIE__} = 'DEFAULT'; 642 local $@; 643 my $result = eval { $rsth->finish() }; 644 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 645 return $result; 646 } 647 1; 648 } 649 650 sub STORE ($$$) { 651 my($sth, $attr, $val) = @_; 652 my $type = $ATTR{$attr} || 'remote'; 653 654 if ($attr =~ /^proxy_/ || $type eq 'inherited') { 655 $sth->{$attr} = $val; 656 return 1; 657 } 658 659 if ($type eq 'cache_only') { 660 return 0; 661 } 662 663 if ($type eq 'remote' || $type eq 'cached') { 664 my $rsth = $sth->{'proxy_sth'} or return undef; 665 local $SIG{__DIE__} = 'DEFAULT'; 666 local $@; 667 my $result = eval { $rsth->STORE($attr => $val) }; 668 return DBD::Proxy::proxy_set_err($sth, $@) if ($@); 669 return $result if $type eq 'remote'; # else fall through to cache locally 670 } 671 return $sth->SUPER::STORE($attr => $val); 672 } 673 674 sub FETCH ($$) { 675 my($sth, $attr) = @_; 676 677 if ($attr =~ /^proxy_/) { 678 return $sth->{$attr}; 679 } 680 681 my $type = $ATTR{$attr} || 'remote'; 682 if ($type eq 'inherited') { 683 if (exists($sth->{$attr})) { 684 return $sth->{$attr}; 685 } 686 return $sth->FETCH('Database')->{$attr}; 687 } 688 689 if ($type eq 'cache_only' && 690 exists($sth->{'proxy_attr_cache'}->{$attr})) { 691 return $sth->{'proxy_attr_cache'}->{$attr}; 692 } 693 694 if ($type ne 'local') { 695 my $rsth = $sth->{'proxy_sth'} or return undef; 696 local $SIG{__DIE__} = 'DEFAULT'; 697 local $@; 698 my $result = eval { $rsth->FETCH($attr) }; 699 return DBD::Proxy::proxy_set_err($sth, $@) if $@; 700 return $result; 701 } 702 elsif ($attr eq 'RowsInCache') { 703 my $data = $sth->{'proxy_data'}; 704 $data ? @$data : 0; 705 } 706 else { 707 $sth->SUPER::FETCH($attr); 708 } 709 } 710 711 sub bind_param ($$$@) { 712 my $sth = shift; my $param = shift; 713 $sth->{'proxy_params'}->[$param-1] = [@_]; 714 } 715 *bind_param_inout = \&bind_param; 716 717 sub DESTROY { 718 my $sth = shift; 719 $sth->finish if $sth->SUPER::FETCH('Active'); 720 } 721 722 723 1; 724 725 726 __END__ 727 728 =head1 NAME 729 730 DBD::Proxy - A proxy driver for the DBI 731 732 =head1 SYNOPSIS 733 734 use DBI; 735 736 $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db", 737 $user, $passwd); 738 739 # See the DBI module documentation for full details 740 741 =head1 DESCRIPTION 742 743 DBD::Proxy is a Perl module for connecting to a database via a remote 744 DBI driver. See L<DBD::Gofer> for an alternative with different trade-offs. 745 746 This is of course not needed for DBI drivers which already 747 support connecting to a remote database, but there are engines which 748 don't offer network connectivity. 749 750 Another application is offering database access through a firewall, as 751 the driver offers query based restrictions. For example you can 752 restrict queries to exactly those that are used in a given CGI 753 application. 754 755 Speaking of CGI, another application is (or rather, will be) to reduce 756 the database connect/disconnect overhead from CGI scripts by using 757 proxying the connect_cached method. The proxy server will hold the 758 database connections open in a cache. The CGI script then trades the 759 database connect/disconnect overhead for the DBD::Proxy 760 connect/disconnect overhead which is typically much less. 761 I<Note that the connect_cached method is new and still experimental.> 762 763 764 =head1 CONNECTING TO THE DATABASE 765 766 Before connecting to a remote database, you must ensure, that a Proxy 767 server is running on the remote machine. There's no default port, so 768 you have to ask your system administrator for the port number. See 769 L<DBI::ProxyServer> for details. 770 771 Say, your Proxy server is running on machine "alpha", port 3334, and 772 you'd like to connect to an ODBC database called "mydb" as user "joe" 773 with password "hello". When using DBD::ODBC directly, you'd do a 774 775 $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello"); 776 777 With DBD::Proxy this becomes 778 779 $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb"; 780 $dbh = DBI->connect($dsn, "joe", "hello"); 781 782 You see, this is mainly the same. The DBD::Proxy module will create a 783 connection to the Proxy server on "alpha" which in turn will connect 784 to the ODBC database. 785 786 Refer to the L<DBI> documentation on the C<connect> method for a way 787 to automatically use DBD::Proxy without having to change your code. 788 789 DBD::Proxy's DSN string has the format 790 791 $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN"; 792 793 In other words, it is a collection of key/value pairs. The following 794 keys are recognized: 795 796 =over 4 797 798 =item hostname 799 800 =item port 801 802 Hostname and port of the Proxy server; these keys must be present, 803 no defaults. Example: 804 805 hostname=alpha;port=3334 806 807 =item dsn 808 809 The value of this attribute will be used as a dsn name by the Proxy 810 server. Thus it must have the format C<DBI:driver:...>, in particular 811 it will contain colons. The I<dsn> value may contain semicolons, hence 812 this key *must* be the last and it's value will be the complete 813 remaining part of the dsn. Example: 814 815 dsn=DBI:ODBC:mydb 816 817 =item cipher 818 819 =item key 820 821 =item usercipher 822 823 =item userkey 824 825 By using these fields you can enable encryption. If you set, 826 for example, 827 828 cipher=$class;key=$key 829 830 (note the semicolon) then DBD::Proxy will create a new cipher object 831 by executing 832 833 $cipherRef = $class->new(pack("H*", $key)); 834 835 and pass this object to the RPC::PlClient module when creating a 836 client. See L<RPC::PlClient>. Example: 837 838 cipher=IDEA;key=97cd2375efa329aceef2098babdc9721 839 840 The usercipher/userkey attributes allow you to use two phase encryption: 841 The cipher/key encryption will be used in the login and authorisation 842 phase. Once the client is authorised, he will change to usercipher/userkey 843 encryption. Thus the cipher/key pair is a B<host> based secret, typically 844 less secure than the usercipher/userkey secret and readable by anyone. 845 The usercipher/userkey secret is B<your> private secret. 846 847 Of course encryption requires an appropriately configured server. See 848 <DBD::ProxyServer/CONFIGURATION FILE>. 849 850 =item debug 851 852 Turn on debugging mode 853 854 =item stderr 855 856 This attribute will set the corresponding attribute of the RPC::PlClient 857 object, thus logging will not use syslog(), but redirected to stderr. 858 This is the default under Windows. 859 860 stderr=1 861 862 =item logfile 863 864 Similar to the stderr attribute, but output will be redirected to the 865 given file. 866 867 logfile=/dev/null 868 869 =item RowCacheSize 870 871 The DBD::Proxy driver supports this attribute (which is DBI standard, 872 as of DBI 1.02). It's used to reduce network round-trips by fetching 873 multiple rows in one go. The current default value is 20, but this may 874 change. 875 876 877 =item proxy_no_finish 878 879 This attribute can be used to reduce network traffic: If the 880 application is calling $sth->finish() then the proxy tells the server 881 to finish the remote statement handle. Of course this slows down things 882 quite a lot, but is prefectly good for reducing memory usage with 883 persistent connections. 884 885 However, if you set the I<proxy_no_finish> attribute to a TRUE value, 886 either in the database handle or in the statement handle, then finish() 887 calls will be supressed. This is what you want, for example, in small 888 and fast CGI applications. 889 890 =item proxy_quote 891 892 This attribute can be used to reduce network traffic: By default calls 893 to $dbh->quote() are passed to the remote driver. Of course this slows 894 down things quite a lot, but is the safest default behaviour. 895 896 However, if you set the I<proxy_quote> attribute to the value 'C<local>' 897 either in the database handle or in the statement handle, and the call 898 to quote has only one parameter, then the local default DBI quote 899 method will be used (which will be faster but may be wrong). 900 901 =back 902 903 =head1 KNOWN ISSUES 904 905 =head2 Unproxied method calls 906 907 If a method isn't being proxied, try declaring a stub sub in the appropriate 908 package (DBD::Proxy::db for a dbh method, and DBD::Proxy::st for an sth method). 909 For example: 910 911 sub DBD::Proxy::db::selectall_arrayref; 912 913 That will enable selectall_arrayref to be proxied. 914 915 Currently many methods aren't explicitly proxied and so you get the DBI's 916 default methods executed on the client. 917 918 Some of those methods, like selectall_arrayref, may then call other methods 919 that are proxied (selectall_arrayref calls fetchall_arrayref which calls fetch 920 which is proxied). So things may appear to work but operate more slowly than 921 the could. 922 923 This may all change in a later version. 924 925 =head2 Complex handle attributes 926 927 Sometimes handles are having complex attributes like hash refs or 928 array refs and not simple strings or integers. For example, with 929 DBD::CSV, you would like to write something like 930 931 $dbh->{"csv_tables"}->{"passwd"} = 932 { "sep_char" => ":", "eol" => "\n"; 933 934 The above example would advice the CSV driver to assume the file 935 "passwd" to be in the format of the /etc/passwd file: Colons as 936 separators and a line feed without carriage return as line 937 terminator. 938 939 Surprisingly this example doesn't work with the proxy driver. To understand 940 the reasons, you should consider the following: The Perl compiler is 941 executing the above example in two steps: 942 943 =over 944 945 =item 1 946 947 The first step is fetching the value of the key "csv_tables" in the 948 handle $dbh. The value returned is complex, a hash ref. 949 950 =item 2 951 952 The second step is storing some value (the right hand side of the 953 assignment) as the key "passwd" in the hash ref from step 1. 954 955 =back 956 957 This becomes a little bit clearer, if we rewrite the above code: 958 959 $tables = $dbh->{"csv_tables"}; 960 $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; 961 962 While the examples work fine without the proxy, the fail due to a 963 subtile difference in step 1: By DBI magic, the hash ref 964 $dbh->{'csv_tables'} is returned from the server to the client. 965 The client creates a local copy. This local copy is the result of 966 step 1. In other words, step 2 modifies a local copy of the hash ref, 967 but not the server's hash ref. 968 969 The workaround is storing the modified local copy back to the server: 970 971 $tables = $dbh->{"csv_tables"}; 972 $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; 973 $dbh->{"csv_tables"} = $tables; 974 975 976 =head1 AUTHOR AND COPYRIGHT 977 978 This module is Copyright (c) 1997, 1998 979 980 Jochen Wiedmann 981 Am Eisteich 9 982 72555 Metzingen 983 Germany 984 985 Email: joe@ispsoft.de 986 Phone: +49 7123 14887 987 988 The DBD::Proxy module is free software; you can redistribute it and/or 989 modify it under the same terms as Perl itself. In particular permission 990 is granted to Tim Bunce for distributing this as a part of the DBI. 991 992 993 =head1 SEE ALSO 994 995 L<DBI>, L<RPC::PlClient>, L<Storable> 996 997 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |