Commit | Line | Data |
---|---|---|
86530b38 AT |
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 | ||
25 | require DBI; | |
26 | DBI->require_version(1.0201); | |
27 | ||
28 | use RPC::PlClient 0.2000; | |
29 | ||
30 | ||
31 | ||
32 | package DBD::Proxy; | |
33 | ||
34 | use vars qw($VERSION $err $errstr $drh); | |
35 | ||
36 | ||
37 | $VERSION = "0.2003"; | |
38 | ||
39 | $err = 0; # holds error code for DBI::err | |
40 | $errstr = ""; # holds error string for DBI::errstr | |
41 | $drh = undef; # holds driver handle once initialised | |
42 | ||
43 | ||
44 | sub driver ($$) { | |
45 | if (!$drh) { | |
46 | my($class, $attr) = @_; | |
47 | ||
48 | $class .= "::dr"; | |
49 | ||
50 | $drh = DBI::_new_drh($class, { | |
51 | 'Name' => 'Proxy', | |
52 | 'Version' => $VERSION, | |
53 | 'Err' => \$DBD::Proxy::err, | |
54 | 'Errstr' => \$DBD::Proxy::errstr, | |
55 | 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', | |
56 | }); | |
57 | } | |
58 | $drh; | |
59 | } | |
60 | ||
61 | ||
62 | package DBD::Proxy::dr; # ====== DRIVER ====== | |
63 | ||
64 | $DBD::Proxy::dr::imp_data_size = 0; | |
65 | ||
66 | sub connect ($$;$$) { | |
67 | my($drh, $dsn, $user, $auth)= @_; | |
68 | my($dsnOrig) = $dsn; | |
69 | ||
70 | my %attr; | |
71 | my ($var, $val); | |
72 | while (length($dsn)) { | |
73 | if ($dsn =~ /^dsn=(.*)/) { | |
74 | $attr{'dsn'} = $1; | |
75 | last; | |
76 | } | |
77 | if ($dsn =~ /^(.*?);(.*)/) { | |
78 | $var = $1; | |
79 | $dsn = $2; | |
80 | } else { | |
81 | $var = $dsn; | |
82 | $dsn = ''; | |
83 | } | |
84 | if ($var =~ /^(.*?)=(.*)/) { | |
85 | $var = $1; | |
86 | $val = $2; | |
87 | $attr{$var} = $val; | |
88 | } | |
89 | } | |
90 | ||
91 | my $err = ''; | |
92 | if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; } | |
93 | if (!defined($attr{'port'})) { $err .= " Missing port."; } | |
94 | if (!defined($attr{'dsn'})) { $err .= " Missing remote dsn."; } | |
95 | ||
96 | # Create a cipher object, if requested | |
97 | my $cipherRef = undef; | |
98 | if ($attr{'cipher'}) { | |
99 | $cipherRef = eval { $attr{'cipher'}->new(pack('H*', | |
100 | $attr{'key'})) }; | |
101 | if ($@) { $err .= " Cannot create cipher object: $@."; } | |
102 | } | |
103 | my $userCipherRef = undef; | |
104 | if ($attr{'userkey'}) { | |
105 | my $cipher = $attr{'usercipher'} || $attr{'cipher'}; | |
106 | $userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) }; | |
107 | if ($@) { $err .= " Cannot create usercipher object: $@."; } | |
108 | } | |
109 | ||
110 | return DBI::set_err($drh, 1, $err) if $err; # Returns undef | |
111 | ||
112 | # Create an RPC::PlClient object. | |
113 | my($client, $msg) = eval { RPC::PlClient->new( | |
114 | 'peeraddr' => $attr{'hostname'}, | |
115 | 'peerport' => $attr{'port'}, | |
116 | 'socket_proto' => 'tcp', | |
117 | 'application' => $attr{dsn}, | |
118 | 'user' => $user || '', | |
119 | 'password' => $auth || '', | |
120 | 'version' => $DBD::Proxy::VERSION, | |
121 | 'cipher' => $cipherRef, | |
122 | 'debug' => $attr{debug} || 0, | |
123 | 'timeout' => $attr{timeout} || undef, | |
124 | 'logfile' => $attr{logfile} || undef | |
125 | ) }; | |
126 | ||
127 | return DBI::set_err($drh, 1, "Cannot log in to DBI::ProxyServer: $@") | |
128 | if $@; # Returns undef | |
129 | return DBI::set_err($drh, 1, "Constructor didn't return a handle: $msg") | |
130 | unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef | |
131 | ||
132 | $msg = RPC::PlClient::Object->new($1, $client, $msg); | |
133 | ||
134 | # Switch to user specific encryption mode, if desired | |
135 | if ($userCipherRef) { | |
136 | $client->{'cipher'} = $userCipherRef; | |
137 | } | |
138 | ||
139 | # create a 'blank' dbh | |
140 | my $this = DBI::_new_dbh($drh, { | |
141 | 'Name' => $dsnOrig, | |
142 | 'proxy_dbh' => $msg, | |
143 | 'proxy_client' => $client, | |
144 | 'RowCacheSize' => $attr{'RowCacheSize'} || 20 | |
145 | }); | |
146 | ||
147 | foreach $var (keys %attr) { | |
148 | if ($var =~ /proxy_/) { | |
149 | $this->{$var} = $attr{$var}; | |
150 | } | |
151 | } | |
152 | ||
153 | $this; | |
154 | } | |
155 | ||
156 | ||
157 | sub disconnect_all { } | |
158 | ||
159 | sub DESTROY { undef } | |
160 | ||
161 | ||
162 | package DBD::Proxy::db; # ====== DATABASE ====== | |
163 | ||
164 | $DBD::Proxy::db::imp_data_size = 0; | |
165 | ||
166 | sub commit; | |
167 | sub rollback; | |
168 | ||
169 | use vars qw(%ATTR $AUTOLOAD); | |
170 | ||
171 | %ATTR = ( | |
172 | 'Warn' => 'local', | |
173 | 'Active' => 'local', | |
174 | 'Kids' => 'local', | |
175 | 'CachedKids' => 'local', | |
176 | 'PrintError' => 'local', | |
177 | 'RaiseError' => 'local', | |
178 | 'RowCacheSize' => 'inherited' | |
179 | ); | |
180 | ||
181 | sub AUTOLOAD { | |
182 | my $method = $AUTOLOAD; | |
183 | $method =~ s/(.*::(.*)):://; | |
184 | my $class = $1; | |
185 | my $type = $2; | |
186 | my %expand = | |
187 | ( 'method' => $method, | |
188 | 'class' => $class, | |
189 | 'type' => $type, | |
190 | 'h' => "DBI::_::$type" | |
191 | ); | |
192 | my $method_code = UNIVERSAL::can($expand{'h'}, $method) ? | |
193 | q/package ~class~; | |
194 | sub ~method~ { | |
195 | my $h = shift; | |
196 | my @result = eval { $h->{'proxy_~type~h'}->~method~(@_) }; | |
197 | return DBI::set_err($h, 1, $@) if $@; | |
198 | wantarray ? @result : $result[0]; | |
199 | } | |
200 | / : | |
201 | q/package ~class~; | |
202 | sub ~method~ { | |
203 | my $h = shift; | |
204 | my @result = eval { $h->{'proxy_~type~h'}->func(@_, '~method~') }; | |
205 | return DBI::set_err($h, 1, $@) if $@; | |
206 | wantarray ? @result : $result[0]; | |
207 | } | |
208 | /; | |
209 | $method_code =~ s/\~(\w+)\~/$expand{$1}/eg; | |
210 | eval $method_code; | |
211 | die $@ if $@; | |
212 | goto &$AUTOLOAD; | |
213 | } | |
214 | ||
215 | sub DESTROY { | |
216 | # Just to avoid that DESTROY is autoloaded ... | |
217 | } | |
218 | ||
219 | sub disconnect ($) { | |
220 | my($dbh) = @_; | |
221 | # XXX this should call $rdbh->disconnect to get the right | |
222 | # disconnect behaviour. It should not undef these values. | |
223 | # A proxy_no_disconnect option could be added (like for finish) | |
224 | # to let people trade safety for speed if they need to. | |
225 | undef $dbh->{'proxy_dbh'}; # Bug in Perl 5.004; would prefer delete | |
226 | undef $dbh->{'proxy_client'}; | |
227 | 1; | |
228 | } | |
229 | ||
230 | ||
231 | sub STORE ($$$) { | |
232 | my($dbh, $attr, $val) = @_; | |
233 | my $type = $ATTR{$attr} || 'remote'; | |
234 | ||
235 | if ($attr =~ /^proxy_/ || $type eq 'inherited') { | |
236 | $dbh->{$attr} = $val; | |
237 | return 1; | |
238 | } | |
239 | ||
240 | if ($type eq 'remote') { | |
241 | my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) }; | |
242 | return DBI::set_err($dbh, 1, $@) if $@; # returns undef | |
243 | return $result; | |
244 | } | |
245 | return $dbh->SUPER::STORE($attr => $val); | |
246 | } | |
247 | ||
248 | sub FETCH ($$) { | |
249 | my($dbh, $attr) = @_; | |
250 | my $type = $ATTR{$attr} || 'remote'; | |
251 | ||
252 | if ($attr =~ /^proxy_/ || $type eq 'inherited') { | |
253 | return $dbh->{$attr}; | |
254 | } | |
255 | ||
256 | return $dbh->SUPER::FETCH($attr) unless $type eq 'remote'; | |
257 | ||
258 | my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) }; | |
259 | return DBI::set_err($dbh, 1, $@) if $@; | |
260 | return $result; | |
261 | } | |
262 | ||
263 | sub prepare ($$;$) { | |
264 | my($dbh, $stmt, $attr) = @_; | |
265 | ||
266 | # We *could* send the statement over the net immediately, but the | |
267 | # DBI specs allows us to defer that until the first 'execute'. | |
268 | # XXX should make this configurable | |
269 | my $sth = DBI::_new_sth($dbh, { | |
270 | 'Statement' => $stmt, | |
271 | 'proxy_attr' => $attr, | |
272 | 'proxy_params' => [], | |
273 | 'proxy_cache_only' => 0, | |
274 | }); | |
275 | $sth; | |
276 | } | |
277 | ||
278 | sub quote { | |
279 | my $dbh = shift; | |
280 | my $proxy_quote = $dbh->{proxy_quote} || 'remote'; | |
281 | ||
282 | return $dbh->SUPER::quote(@_) | |
283 | if $proxy_quote eq 'local' && @_ == 1; | |
284 | ||
285 | # For the common case of only a single argument | |
286 | # (no $data_type) we could learn and cache the behaviour. | |
287 | # Or we could probe the driver with a few test cases. | |
288 | # Or we could add a way to ask the DBI::ProxyServer | |
289 | # if $dbh->can('quote') == \&DBI::_::db::quote. | |
290 | # Tim | |
291 | # | |
292 | # Sounds all *very* smart to me. I'd rather suggest to | |
293 | # implement some of the typical quote possibilities | |
294 | # and let the user set | |
295 | # $dbh->{'proxy_quote'} = 'backslash_escaped'; | |
296 | # for example. | |
297 | # Jochen | |
298 | ||
299 | my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) }; | |
300 | return DBI::set_err($dbh, 1, $@) if $@; | |
301 | return $result; | |
302 | } | |
303 | ||
304 | sub table_info { | |
305 | my $dbh = shift; | |
306 | my $rdbh = $dbh->{'proxy_dbh'}; | |
307 | my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) }; | |
308 | my $sth = DBI::_new_sth($dbh, { | |
309 | 'Statement' => "SHOW TABLES", | |
310 | 'proxy_params' => [], | |
311 | 'proxy_data' => \@rows, | |
312 | 'proxy_attr_cache' => { | |
313 | 'NUM_OF_PARAMS' => 0, | |
314 | 'NUM_OF_FIELDS' => $numFields, | |
315 | 'NAME' => $names, | |
316 | 'TYPE' => $types | |
317 | }, | |
318 | 'proxy_cache_only' => 1, | |
319 | }); | |
320 | $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); | |
321 | return $sth; | |
322 | } | |
323 | ||
324 | sub type_info_all { | |
325 | my $dbh = shift; | |
326 | my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) }; | |
327 | return DBI::set_err($dbh, 1, $@) if $@; | |
328 | return $result; | |
329 | } | |
330 | ||
331 | ||
332 | package DBD::Proxy::st; # ====== STATEMENT ====== | |
333 | ||
334 | $DBD::Proxy::st::imp_data_size = 0; | |
335 | ||
336 | use vars qw(%ATTR); | |
337 | ||
338 | %ATTR = ( | |
339 | 'Warn' => 'local', | |
340 | 'Active' => 'local', | |
341 | 'Kids' => 'local', | |
342 | 'CachedKids' => 'local', | |
343 | 'PrintError' => 'local', | |
344 | 'RaiseError' => 'local', | |
345 | 'RowsInCache' => 'local', | |
346 | 'RowCacheSize' => 'inherited', | |
347 | 'NULLABLE' => 'cache_only', | |
348 | 'NAME' => 'cache_only', | |
349 | 'TYPE' => 'cache_only', | |
350 | 'PRECISION' => 'cache_only', | |
351 | 'SCALE' => 'cache_only', | |
352 | 'NUM_OF_FIELDS' => 'cache_only', | |
353 | 'NUM_OF_PARAMS' => 'cache_only' | |
354 | ); | |
355 | ||
356 | *AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD; | |
357 | ||
358 | sub execute ($@) { | |
359 | my $sth = shift; | |
360 | my $params = @_ ? \@_ : $sth->{'proxy_params'}; | |
361 | ||
362 | # new execute, so delete any cached rows from previous execute | |
363 | undef $sth->{'proxy_data'}; | |
364 | ||
365 | my $dbh = $sth->{'Database'}; | |
366 | my $client = $dbh->{'proxy_client'}; | |
367 | my $rsth = $sth->{proxy_sth}; | |
368 | ||
369 | my ($numFields, $numParams, $numRows, $names, $types, @outParams); | |
370 | ||
371 | if ($sth->{'proxy_data'}) { | |
372 | my $attrCache = $sth->{'proxy_attr_cache'}; | |
373 | $numFields = $attrCache->{'NUM_OF_FIELDS'}; | |
374 | $numParams = $attrCache->{'NUM_OF_PARAMS'}; | |
375 | $names = $attrCache->{'NAME'}; | |
376 | $types = $attrCache->{'TYPE'}; | |
377 | $numRows = scalar @{$sth->{'proxy_data'}}; | |
378 | } else { | |
379 | ||
380 | if (!$rsth) { | |
381 | my $rdbh = $dbh->{'proxy_dbh'}; | |
382 | ||
383 | ($rsth, $numFields, $numParams, $names, $types, $numRows, @outParams) = | |
384 | eval { $rdbh->prepare($sth->{'Statement'}, | |
385 | $sth->{'proxy_attr'}, $params) }; | |
386 | return DBI::set_err($sth, 1, $@) if $@; | |
387 | return DBI::set_err($sth, 1, | |
388 | "Constructor didn't return a handle: $rsth") | |
389 | unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); | |
390 | ||
391 | $rsth = RPC::PlClient::Object->new($1, $client, $rsth); | |
392 | ||
393 | $sth->{'proxy_sth'} = $rsth; | |
394 | $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); | |
395 | $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); | |
396 | } else { | |
397 | my $attrCache = $sth->{'proxy_attr_cache'}; | |
398 | $numFields = $attrCache->{'NUM_OF_FIELDS'}; | |
399 | $numParams = $attrCache->{'NUM_OF_PARAMS'}; | |
400 | $names = $attrCache->{'NAME'}; | |
401 | $types = $attrCache->{'TYPE'}; | |
402 | ($numRows, @outParams) = eval { $rsth->execute($params) }; | |
403 | return DBI::set_err($sth, 1, $@) if $@; | |
404 | } | |
405 | } | |
406 | $sth->{'proxy_rows'} = $numRows; | |
407 | $sth->{'proxy_attr_cache'} = { | |
408 | 'NUM_OF_FIELDS' => $numFields, | |
409 | 'NUM_OF_PARAMS' => $numParams, | |
410 | 'NAME' => $names | |
411 | }; | |
412 | ||
413 | $sth->SUPER::STORE('Active' => 1) if $numFields; # is SELECT | |
414 | ||
415 | if (@outParams) { | |
416 | foreach my $p (@$params) { | |
417 | if (ref($p) && @$p > 2) { | |
418 | my $ref = shift @outParams; | |
419 | ${$p->[0]} = $$ref; | |
420 | } | |
421 | } | |
422 | } | |
423 | ||
424 | $sth->{'proxy_rows'} || '0E0'; | |
425 | } | |
426 | ||
427 | sub fetch ($) { | |
428 | my $sth = shift; | |
429 | ||
430 | my $data = $sth->{'proxy_data'}; | |
431 | ||
432 | if(!$data || !@$data) { | |
433 | return undef unless $sth->SUPER::FETCH('Active'); | |
434 | ||
435 | my $rsth = $sth->{'proxy_sth'}; | |
436 | if (!$rsth) { | |
437 | die "Attempt to fetch row without execute"; | |
438 | } | |
439 | my $num_rows = $sth->FETCH('RowCacheSize') || 20; | |
440 | my @rows = eval { $rsth->fetch($num_rows) }; | |
441 | return DBI::set_err($sth, 1, $@) if $@; | |
442 | unless (@rows == $num_rows) { | |
443 | undef $sth->{'proxy_data'}; | |
444 | # server side has already called finish | |
445 | $sth->SUPER::STORE(Active => 0); | |
446 | } | |
447 | return undef unless @rows; | |
448 | $sth->{'proxy_data'} = $data = [@rows]; | |
449 | } | |
450 | my $row = shift @$data; | |
451 | ||
452 | $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data ); | |
453 | return $sth->_set_fbav($row); | |
454 | } | |
455 | *fetchrow_arrayref = \&fetch; | |
456 | ||
457 | sub rows ($) { | |
458 | my($sth) = @_; | |
459 | $sth->{'proxy_rows'}; | |
460 | } | |
461 | ||
462 | sub finish ($) { | |
463 | my($sth) = @_; | |
464 | return 1 unless $sth->SUPER::FETCH('Active'); | |
465 | my $rsth = $sth->{'proxy_sth'}; | |
466 | $sth->SUPER::STORE('Active' => 0); | |
467 | return 0 unless $rsth; # Something's out of sync | |
468 | my $no_finish = exists($sth->{'proxy_no_finish'}) | |
469 | ? $sth->{'proxy_no_finish'} | |
470 | : $sth->{Database}->{'proxy_no_finish'}; | |
471 | unless ($no_finish) { | |
472 | my $result = eval { $rsth->finish() }; | |
473 | return DBI::set_err($sth, 1, $@) if $@; | |
474 | return $result; | |
475 | } | |
476 | 1; | |
477 | } | |
478 | ||
479 | sub STORE ($$$) { | |
480 | my($sth, $attr, $val) = @_; | |
481 | my $type = $ATTR{$attr} || 'remote'; | |
482 | ||
483 | if ($attr =~ /^proxy_/ || $type eq 'inherited') { | |
484 | $sth->{$attr} = $val; | |
485 | return 1; | |
486 | } | |
487 | ||
488 | if ($type eq 'cache_only') { | |
489 | return 0; | |
490 | } | |
491 | ||
492 | if ($type eq 'remote') { | |
493 | my $rsth = $sth->{'proxy_sth'} or return undef; | |
494 | my $result = eval { $rsth->STORE($attr => $val) }; | |
495 | return DBI::set_err($sth, 1, $@) if ($@); | |
496 | return $result; | |
497 | } | |
498 | return $sth->SUPER::STORE($attr => $val); | |
499 | } | |
500 | ||
501 | sub FETCH ($$) { | |
502 | my($sth, $attr) = @_; | |
503 | ||
504 | if ($attr =~ /^proxy_/) { | |
505 | return $sth->{$attr}; | |
506 | } | |
507 | ||
508 | my $type = $ATTR{$attr} || 'remote'; | |
509 | if ($type eq 'inherited') { | |
510 | if (exists($sth->{$attr})) { | |
511 | return $sth->{$attr}; | |
512 | } | |
513 | return $sth->{'Database'}->{$attr}; | |
514 | } | |
515 | ||
516 | if ($type eq 'cache_only' && | |
517 | exists($sth->{'proxy_attr_cache'}->{$attr})) { | |
518 | return $sth->{'proxy_attr_cache'}->{$attr}; | |
519 | } | |
520 | ||
521 | if ($type ne 'local') { | |
522 | my $rsth = $sth->{'proxy_sth'} or return undef; | |
523 | my $result = eval { $rsth->FETCH($attr) }; | |
524 | return DBI::set_err($sth, 1, $@) if $@; | |
525 | return $result; | |
526 | } elsif ($attr eq 'RowsInCache') { | |
527 | my $data = $sth->{'proxy_data'}; | |
528 | $data ? @$data : 0; | |
529 | } else { | |
530 | $sth->SUPER::FETCH($attr); | |
531 | } | |
532 | } | |
533 | ||
534 | sub bind_param ($$$@) { | |
535 | my $sth = shift; my $param = shift; | |
536 | $sth->{'proxy_params'}->[$param-1] = [@_]; | |
537 | } | |
538 | *bind_param_inout = \&bind_param; | |
539 | ||
540 | sub DESTROY { | |
541 | # Just to avoid autoloading DESTROY ... | |
542 | } | |
543 | ||
544 | ||
545 | 1; | |
546 | ||
547 | ||
548 | __END__ | |
549 | ||
550 | =head1 NAME | |
551 | ||
552 | DBD::Proxy - A proxy driver for the DBI | |
553 | ||
554 | =head1 SYNOPSIS | |
555 | ||
556 | use DBI; | |
557 | ||
558 | $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db", | |
559 | $user, $passwd); | |
560 | ||
561 | # See the DBI module documentation for full details | |
562 | ||
563 | =head1 DESCRIPTION | |
564 | ||
565 | DBD::Proxy is a Perl module for connecting to a database via a remote | |
566 | DBI driver. | |
567 | ||
568 | This is of course not needed for DBI drivers which already | |
569 | support connecting to a remote database, but there are engines which | |
570 | don't offer network connectivity. | |
571 | ||
572 | Another application is offering database access through a firewall, as | |
573 | the driver offers query based restrictions. For example you can | |
574 | restrict queries to exactly those that are used in a given CGI | |
575 | application. | |
576 | ||
577 | Speaking of CGI, another application is (or rather, will be) to reduce | |
578 | the database connect/disconnect overhead from CGI scripts by using | |
579 | proxying the connect_cached method. The proxy server will hold the | |
580 | database connections open in a cache. The CGI script then trades the | |
581 | database connect/disconnect overhead for the DBD::Proxy | |
582 | connect/disconnect overhead which is typically much less. | |
583 | I<Note that the connect_cached method is new and still experimental.> | |
584 | ||
585 | ||
586 | =head1 CONNECTING TO THE DATABASE | |
587 | ||
588 | Before connecting to a remote database, you must ensure, that a Proxy | |
589 | server is running on the remote machine. There's no default port, so | |
590 | you have to ask your system administrator for the port number. See | |
591 | L<DBI::ProxyServer(3)> for details. | |
592 | ||
593 | Say, your Proxy server is running on machine "alpha", port 3334, and | |
594 | you'd like to connect to an ODBC database called "mydb" as user "joe" | |
595 | with password "hello". When using DBD::ODBC directly, you'd do a | |
596 | ||
597 | $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello"); | |
598 | ||
599 | With DBD::Proxy this becomes | |
600 | ||
601 | $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb"; | |
602 | $dbh = DBI->connect($dsn, "joe", "hello"); | |
603 | ||
604 | You see, this is mainly the same. The DBD::Proxy module will create a | |
605 | connection to the Proxy server on "alpha" which in turn will connect | |
606 | to the ODBC database. | |
607 | ||
608 | Refer to the L<DBI(3)> documentation on the C<connect> method for a way | |
609 | to automatically use DBD::Proxy without having to change your code. | |
610 | ||
611 | DBD::Proxy's DSN string has the format | |
612 | ||
613 | $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN"; | |
614 | ||
615 | In other words, it is a collection of key/value pairs. The following | |
616 | keys are recognized: | |
617 | ||
618 | =over 4 | |
619 | ||
620 | =item hostname | |
621 | ||
622 | =item port | |
623 | ||
624 | Hostname and port of the Proxy server; these keys must be present, | |
625 | no defaults. Example: | |
626 | ||
627 | hostname=alpha;port=3334 | |
628 | ||
629 | =item dsn | |
630 | ||
631 | The value of this attribute will be used as a dsn name by the Proxy | |
632 | server. Thus it must have the format C<DBI:driver:...>, in particular | |
633 | it will contain colons. The I<dsn> value may contain semicolons, hence | |
634 | this key *must* be the last and it's value will be the complete | |
635 | remaining part of the dsn. Example: | |
636 | ||
637 | dsn=DBI:ODBC:mydb | |
638 | ||
639 | =item cipher | |
640 | ||
641 | =item key | |
642 | ||
643 | =item usercipher | |
644 | ||
645 | =item userkey | |
646 | ||
647 | By using these fields you can enable encryption. If you set, | |
648 | for example, | |
649 | ||
650 | cipher=$class;key=$key | |
651 | ||
652 | (note the semicolon) then DBD::Proxy will create a new cipher object | |
653 | by executing | |
654 | ||
655 | $cipherRef = $class->new(pack("H*", $key)); | |
656 | ||
657 | and pass this object to the RPC::PlClient module when creating a | |
658 | client. See L<RPC::PlClient(3)>. Example: | |
659 | ||
660 | cipher=IDEA;key=97cd2375efa329aceef2098babdc9721 | |
661 | ||
662 | The usercipher/userkey attributes allow you to use two phase encryption: | |
663 | The cipher/key encryption will be used in the login and authorisation | |
664 | phase. Once the client is authorised, he will change to usercipher/userkey | |
665 | encryption. Thus the cipher/key pair is a B<host> based secret, typically | |
666 | less secure than the usercipher/userkey secret and readable by anyone. | |
667 | The usercipher/userkey secret is B<your> private secret. | |
668 | ||
669 | Of course encryption requires an appropriately configured server. See | |
670 | <DBD::ProxyServer(3)/CONFIGURATION FILE>. | |
671 | ||
672 | =item debug | |
673 | ||
674 | Turn on debugging mode | |
675 | ||
676 | =item stderr | |
677 | ||
678 | This attribute will set the corresponding attribute of the RPC::PlClient | |
679 | object, thus logging will not use syslog(), but redirected to stderr. | |
680 | This is the default under Windows. | |
681 | ||
682 | stderr=1 | |
683 | ||
684 | =item logfile | |
685 | ||
686 | Similar to the stderr attribute, but output will be redirected to the | |
687 | given file. | |
688 | ||
689 | logfile=/dev/null | |
690 | ||
691 | =item RowCacheSize | |
692 | ||
693 | The DBD::Proxy driver supports this attribute (which is DBI standard, | |
694 | as of DBI 1.02). It's used to reduce network round-trips by fetching | |
695 | multiple rows in one go. The current default value is 20, but this may | |
696 | change. | |
697 | ||
698 | ||
699 | =item proxy_no_finish | |
700 | ||
701 | This attribute can be used to reduce network traffic: If the | |
702 | application is calling $sth->finish() then the proxy tells the server | |
703 | to finish the remote statement handle. Of course this slows down things | |
704 | quite a lot, but is prefectly good for reducing memory usage with | |
705 | persistent connections. | |
706 | ||
707 | However, if you set the I<proxy_no_finish> attribute to a TRUE value, | |
708 | either in the database handle or in the statement handle, then finish() | |
709 | calls will be supressed. This is what you want, for example, in small | |
710 | and fast CGI applications. | |
711 | ||
712 | =item proxy_quote | |
713 | ||
714 | This attribute can be used to reduce network traffic: By default calls | |
715 | to $dbh->quote() are passed to the remote driver. Of course this slows | |
716 | down things quite a lot, but is the safest default behaviour. | |
717 | ||
718 | However, if you set the I<proxy_quote> attribute to the value 'C<local>' | |
719 | either in the database handle or in the statement handle, and the call | |
720 | to quote has only one parameter, then the local default DBI quote | |
721 | method will be used (which will be faster but may be wrong). | |
722 | ||
723 | =back | |
724 | ||
725 | =head1 KNOWN ISSUES | |
726 | ||
727 | =head2 Complex handle attributes | |
728 | ||
729 | Sometimes handles are having complex attributes like hash refs or | |
730 | array refs and not simple strings or integers. For example, with | |
731 | DBD::CSV, you would like to write something like | |
732 | ||
733 | $dbh->{"csv_tables"}->{"passwd"} = | |
734 | { "sep_char" => ":", "eol" => "\n"; | |
735 | ||
736 | The above example would advice the CSV driver to assume the file | |
737 | "passwd" to be in the format of the /etc/passwd file: Colons as | |
738 | separators and a line feed without carriage return as line | |
739 | terminator. | |
740 | ||
741 | Surprisingly this example doesn't work with the proxy driver. To understand | |
742 | the reasons, you should consider the following: The Perl compiler is | |
743 | executing the above example in two steps: | |
744 | ||
745 | =over | |
746 | ||
747 | =item 1.) | |
748 | ||
749 | The first step is fetching the value of the key "csv_tables" in the | |
750 | handle $dbh. The value returned is complex, a hash ref. | |
751 | ||
752 | =item 2.) | |
753 | ||
754 | The second step is storing some value (the right hand side of the | |
755 | assignment) as the key "passwd" in the hash ref from step 1. | |
756 | ||
757 | =back | |
758 | ||
759 | This becomes a little bit clearer, if we rewrite the above code: | |
760 | ||
761 | $tables = $dbh->{"csv_tables"}; | |
762 | $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; | |
763 | ||
764 | While the examples work fine without the proxy, the fail due to a | |
765 | subtile difference in step 1: By DBI magic, the hash ref | |
766 | $dbh->{'csv_tables'} is returned from the server to the client. | |
767 | The client creates a local copy. This local copy is the result of | |
768 | step 1. In other words, step 2 modifies a local copy of the hash ref, | |
769 | but not the server's hash ref. | |
770 | ||
771 | The workaround is storing the modified local copy back to the server: | |
772 | ||
773 | $tables = $dbh->{"csv_tables"}; | |
774 | $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; | |
775 | $dbh->{"csv_tables"} = $tables; | |
776 | ||
777 | ||
778 | =head1 AUTHOR AND COPYRIGHT | |
779 | ||
780 | This module is Copyright (c) 1997, 1998 | |
781 | ||
782 | Jochen Wiedmann | |
783 | Am Eisteich 9 | |
784 | 72555 Metzingen | |
785 | Germany | |
786 | ||
787 | Email: joe@ispsoft.de | |
788 | Phone: +49 7123 14887 | |
789 | ||
790 | The DBD::Proxy module is free software; you can redistribute it and/or | |
791 | modify it under the same terms as Perl itself. In particular permission | |
792 | is granted to Tim Bunce for distributing this as a part of the DBI. | |
793 | ||
794 | ||
795 | =head1 SEE ALSO | |
796 | ||
797 | L<DBI(3)>, L<RPC::PlClient(3)>, L<Storable(3)> | |
798 | ||
799 | =cut |