File Coverage

blib/lib/DBD/Proxy.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
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 4     4   44308 use strict;
  4         8  
  4         110  
24 4     4   19 use Carp;
  4         9  
  4         273  
25              
26             require DBI;
27             DBI->require_version(1.0201);
28              
29 4     4   708 use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released
  0            
  0            
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 rollback;
233             sub ping;
234              
235             use vars qw(%ATTR $AUTOLOAD);
236              
237             # inherited: STORE / FETCH against this class.
238             # local: STORE / FETCH against parent class.
239             # cached: STORE to remote and local objects, FETCH from local.
240             # remote: STORE / FETCH against remote object only (default).
241             #
242             # Note: Attribute names starting with 'proxy_' always treated as 'inherited'.
243             #
244             %ATTR = ( # see also %ATTR in DBD::Proxy::st
245             %DBD::Proxy::ATTR,
246             RowCacheSize => 'inherited',
247             #AutoCommit => 'cached',
248             'FetchHashKeyName' => 'cached',
249             Statement => 'local',
250             Driver => 'local',
251             dbi_connect_closure => 'local',
252             Username => 'local',
253             );
254              
255             sub AUTOLOAD {
256             my $method = $AUTOLOAD;
257             $method =~ s/(.*::(.*)):://;
258             my $class = $1;
259             my $type = $2;
260             #warn "AUTOLOAD of $method (class=$class, type=$type)";
261             my %expand = (
262             'method' => $method,
263             'class' => $class,
264             'type' => $type,
265             'call' => "$method(\@_)",
266             # XXX was trying to be smart but was tripping up over the DBI's own
267             # smartness. Disabled, but left here in case there are issues.
268             # 'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')",
269             );
270              
271             my $method_code = q{
272             package ~class~;
273             sub ~method~ {
274             my $h = shift;
275             local $@;
276             my @result = wantarray
277             ? eval { $h->{'proxy_~type~h'}->~call~ }
278             : eval { scalar $h->{'proxy_~type~h'}->~call~ };
279             return DBD::Proxy::proxy_set_err($h, $@) if $@;
280             return wantarray ? @result : $result[0];
281             }
282             };
283             $method_code =~ s/\~(\w+)\~/$expand{$1}/eg;
284             local $SIG{__DIE__} = 'DEFAULT';
285             my $err = do { local $@; eval $method_code.2; $@ };
286             die $err if $err;
287             goto &$AUTOLOAD;
288             }
289              
290             sub DESTROY {
291             my $dbh = shift;
292             local $@ if $@; # protect $@
293             $dbh->disconnect if $dbh->SUPER::FETCH('Active');
294             }
295              
296              
297             sub connected { } # client-side not server-side, RT#75868
298              
299             sub disconnect ($) {
300             my ($dbh) = @_;
301              
302             # Sadly the Proxy too-often disagrees with the backend database
303             # on the subject of 'Active'. In the short term, I'd like the
304             # Proxy to ease up and let me decide when it's proper to go over
305             # the wire. This ultimately applies to finish() as well.
306             #return unless $dbh->SUPER::FETCH('Active');
307              
308             # Drop database connection at remote end
309             my $rdbh = $dbh->{'proxy_dbh'};
310             if ( $rdbh ) {
311             local $SIG{__DIE__} = 'DEFAULT';
312             local $@;
313             eval { $rdbh->disconnect() } ;
314             DBD::Proxy::proxy_set_err($dbh, $@) if $@;
315             }
316            
317             # Close TCP connect to remote
318             # XXX possibly best left till DESTROY? Add a config attribute to choose?
319             #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module
320             $dbh->{proxy_client}->{socket} = undef; # hack
321              
322             $dbh->SUPER::STORE('Active' => 0);
323             1;
324             }
325              
326              
327             sub STORE ($$$) {
328             my($dbh, $attr, $val) = @_;
329             my $type = $ATTR{$attr} || 'remote';
330              
331             if ($attr eq 'TraceLevel') {
332             warn("TraceLevel $val");
333             my $pc = $dbh->{proxy_client} || die;
334             $pc->{logfile} ||= 1; # XXX hack
335             $pc->{debug} = ($val && $val >= 4);
336             $pc->Debug("$pc debug enabled") if $pc->{debug};
337             }
338              
339             if ($attr =~ /^proxy_/ || $type eq 'inherited') {
340             $dbh->{$attr} = $val;
341             return 1;
342             }
343              
344             if ($type eq 'remote' || $type eq 'cached') {
345             local $SIG{__DIE__} = 'DEFAULT';
346             local $@;
347             my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) };
348             return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef
349             $dbh->SUPER::STORE($attr => $val) if $type eq 'cached';
350             return $result;
351             }
352             return $dbh->SUPER::STORE($attr => $val);
353             }
354              
355             sub FETCH ($$) {
356             my($dbh, $attr) = @_;
357             # we only get here for cached attribute values if the handle is in CompatMode
358             # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache.
359             my $type = $ATTR{$attr} || 'remote';
360              
361             if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') {
362             return $dbh->{$attr};
363             }
364              
365             return $dbh->SUPER::FETCH($attr) unless $type eq 'remote';
366              
367             local $SIG{__DIE__} = 'DEFAULT';
368             local $@;
369             my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) };
370             return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
371             return $result;
372             }
373              
374             sub prepare ($$;$) {
375             my($dbh, $stmt, $attr) = @_;
376             my $sth = DBI::_new_sth($dbh, {
377             'Statement' => $stmt,
378             'proxy_attr' => $attr,
379             'proxy_cache_only' => 0,
380             'proxy_params' => [],
381             }
382             );
383             my $proto_ver = $dbh->{'proxy_proto_ver'};
384             if ( $proto_ver > 1 ) {
385             $sth->{'proxy_attr_cache'} = {cache_filled => 0};
386             my $rdbh = $dbh->{'proxy_dbh'};
387             local $SIG{__DIE__} = 'DEFAULT';
388             local $@;
389             my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) };
390             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
391             return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth")
392             unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/);
393            
394             my $client = $dbh->{'proxy_client'};
395             $rsth = RPC::PlClient::Object->new($1, $client, $rsth);
396            
397             $sth->{'proxy_sth'} = $rsth;
398             # If statement is a positioned update we do not want any readahead.
399             $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i;
400             # Since resources are used by prepared remote handle, mark us active.
401             $sth->SUPER::STORE(Active => 1);
402             }
403             $sth;
404             }
405              
406             sub quote {
407             my $dbh = shift;
408             my $proxy_quote = $dbh->{proxy_quote} || 'remote';
409              
410             return $dbh->SUPER::quote(@_)
411             if $proxy_quote eq 'local' && @_ == 1;
412              
413             # For the common case of only a single argument
414             # (no $data_type) we could learn and cache the behaviour.
415             # Or we could probe the driver with a few test cases.
416             # Or we could add a way to ask the DBI::ProxyServer
417             # if $dbh->can('quote') == \&DBI::_::db::quote.
418             # Tim
419             #
420             # Sounds all *very* smart to me. I'd rather suggest to
421             # implement some of the typical quote possibilities
422             # and let the user set
423             # $dbh->{'proxy_quote'} = 'backslash_escaped';
424             # for example.
425             # Jochen
426             local $SIG{__DIE__} = 'DEFAULT';
427             local $@;
428             my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) };
429             return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
430             return $result;
431             }
432              
433             sub table_info {
434             my $dbh = shift;
435             my $rdbh = $dbh->{'proxy_dbh'};
436             #warn "table_info(@_)";
437             local $SIG{__DIE__} = 'DEFAULT';
438             local $@;
439             my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) };
440             return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
441             my ($sth, $inner) = DBI::_new_sth($dbh, {
442             'Statement' => "SHOW TABLES",
443             'proxy_params' => [],
444             'proxy_data' => \@rows,
445             'proxy_attr_cache' => {
446             'NUM_OF_PARAMS' => 0,
447             'NUM_OF_FIELDS' => $numFields,
448             'NAME' => $names,
449             'TYPE' => $types,
450             'cache_filled' => 1
451             },
452             'proxy_cache_only' => 1,
453             });
454             $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields);
455             $inner->{NAME} = $names;
456             $inner->{TYPE} = $types;
457             $sth->SUPER::STORE('Active' => 1); # already execute()'d
458             $sth->{'proxy_rows'} = @rows;
459             return $sth;
460             }
461              
462             sub tables {
463             my $dbh = shift;
464             #warn "tables(@_)";
465             return $dbh->SUPER::tables(@_);
466             }
467              
468              
469             sub type_info_all {
470             my $dbh = shift;
471             local $SIG{__DIE__} = 'DEFAULT';
472             local $@;
473             my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) };
474             return DBD::Proxy::proxy_set_err($dbh, $@) if $@;
475             return $result;
476             }
477              
478              
479             package DBD::Proxy::st; # ====== STATEMENT ======
480              
481             $DBD::Proxy::st::imp_data_size = 0;
482              
483             use vars qw(%ATTR);
484              
485             # inherited: STORE to current object. FETCH from current if exists, else call up
486             # to the (proxy) database object.
487             # local: STORE / FETCH against parent class.
488             # cache_only: STORE noop (read-only). FETCH from private_* if exists, else call
489             # remote and cache the result.
490             # remote: STORE / FETCH against remote object only (default).
491             #
492             # Note: Attribute names starting with 'proxy_' always treated as 'inherited'.
493             #
494             %ATTR = ( # see also %ATTR in DBD::Proxy::db
495             %DBD::Proxy::ATTR,
496             'Database' => 'local',
497             'RowsInCache' => 'local',
498             'RowCacheSize' => 'inherited',
499             'NULLABLE' => 'cache_only',
500             'NAME' => 'cache_only',
501             'TYPE' => 'cache_only',
502             'PRECISION' => 'cache_only',
503             'SCALE' => 'cache_only',
504             'NUM_OF_FIELDS' => 'cache_only',
505             'NUM_OF_PARAMS' => 'cache_only'
506             );
507              
508             *AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD;
509              
510             sub execute ($@) {
511             my $sth = shift;
512             my $params = @_ ? \@_ : $sth->{'proxy_params'};
513              
514             # new execute, so delete any cached rows from previous execute
515             undef $sth->{'proxy_data'};
516             undef $sth->{'proxy_rows'};
517              
518             my $rsth = $sth->{proxy_sth};
519             my $dbh = $sth->FETCH('Database');
520             my $proto_ver = $dbh->{proxy_proto_ver};
521              
522             my ($numRows, @outData);
523              
524             local $SIG{__DIE__} = 'DEFAULT';
525             local $@;
526             if ( $proto_ver > 1 ) {
527             ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) };
528             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
529            
530             # Attributes passed back only on the first execute() of a statement.
531             unless ($sth->{proxy_attr_cache}->{cache_filled}) {
532             my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4);
533             $sth->{'proxy_attr_cache'} = {
534             'NUM_OF_FIELDS' => $numFields,
535             'NUM_OF_PARAMS' => $numParams,
536             'NAME' => $names,
537             'cache_filled' => 1
538             };
539             $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields);
540             $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams);
541             }
542              
543             }
544             else {
545             if ($rsth) {
546             ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) };
547             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
548              
549             }
550             else {
551             my $rdbh = $dbh->{'proxy_dbh'};
552            
553             # Legacy prepare is actually prepare + first execute on the server.
554             ($rsth, @outData) =
555             eval { $rdbh->prepare($sth->{'Statement'},
556             $sth->{'proxy_attr'}, $params, $proto_ver) };
557             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
558             return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth")
559             unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/);
560            
561             my $client = $dbh->{'proxy_client'};
562             $rsth = RPC::PlClient::Object->new($1, $client, $rsth);
563              
564             my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4);
565             $sth->{'proxy_sth'} = $rsth;
566             $sth->{'proxy_attr_cache'} = {
567             'NUM_OF_FIELDS' => $numFields,
568             'NUM_OF_PARAMS' => $numParams,
569             'NAME' => $names
570             };
571             $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields);
572             $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams);
573             $numRows = shift @outData;
574             }
575             }
576             # Always condition active flag.
577             $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT
578             $sth->{'proxy_rows'} = $numRows;
579             # Any remaining items are output params.
580             if (@outData) {
581             foreach my $p (@$params) {
582             if (ref($p->[0])) {
583             my $ref = shift @outData;
584             ${$p->[0]} = $$ref;
585             }
586             }
587             }
588              
589             $sth->{'proxy_rows'} || '0E0';
590             }
591              
592             sub fetch ($) {
593             my $sth = shift;
594              
595             my $data = $sth->{'proxy_data'};
596              
597             $sth->{'proxy_rows'} = 0 unless defined $sth->{'proxy_rows'};
598              
599             if(!$data || !@$data) {
600             return undef unless $sth->SUPER::FETCH('Active');
601              
602             my $rsth = $sth->{'proxy_sth'};
603             if (!$rsth) {
604             die "Attempt to fetch row without execute";
605             }
606             my $num_rows = $sth->FETCH('RowCacheSize') || 20;
607             local $SIG{__DIE__} = 'DEFAULT';
608             local $@;
609             my @rows = eval { $rsth->fetch($num_rows) };
610             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
611             unless (@rows == $num_rows) {
612             undef $sth->{'proxy_data'};
613             # server side has already called finish
614             $sth->SUPER::STORE(Active => 0);
615             }
616             return undef unless @rows;
617             $sth->{'proxy_data'} = $data = [@rows];
618             }
619             my $row = shift @$data;
620              
621             $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data );
622             $sth->{'proxy_rows'}++;
623             return $sth->_set_fbav($row);
624             }
625             *fetchrow_arrayref = \&fetch;
626              
627             sub rows ($) {
628             my $rows = shift->{'proxy_rows'};
629             return (defined $rows) ? $rows : -1;
630             }
631              
632             sub finish ($) {
633             my($sth) = @_;
634             return 1 unless $sth->SUPER::FETCH('Active');
635             my $rsth = $sth->{'proxy_sth'};
636             $sth->SUPER::STORE('Active' => 0);
637             return 0 unless $rsth; # Something's out of sync
638             my $no_finish = exists($sth->{'proxy_no_finish'})
639             ? $sth->{'proxy_no_finish'}
640             : $sth->FETCH('Database')->{'proxy_no_finish'};
641             unless ($no_finish) {
642             local $SIG{__DIE__} = 'DEFAULT';
643             local $@;
644             my $result = eval { $rsth->finish() };
645             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
646             return $result;
647             }
648             1;
649             }
650              
651             sub STORE ($$$) {
652             my($sth, $attr, $val) = @_;
653             my $type = $ATTR{$attr} || 'remote';
654              
655             if ($attr =~ /^proxy_/ || $type eq 'inherited') {
656             $sth->{$attr} = $val;
657             return 1;
658             }
659              
660             if ($type eq 'cache_only') {
661             return 0;
662             }
663              
664             if ($type eq 'remote' || $type eq 'cached') {
665             my $rsth = $sth->{'proxy_sth'} or return undef;
666             local $SIG{__DIE__} = 'DEFAULT';
667             local $@;
668             my $result = eval { $rsth->STORE($attr => $val) };
669             return DBD::Proxy::proxy_set_err($sth, $@) if ($@);
670             return $result if $type eq 'remote'; # else fall through to cache locally
671             }
672             return $sth->SUPER::STORE($attr => $val);
673             }
674              
675             sub FETCH ($$) {
676             my($sth, $attr) = @_;
677              
678             if ($attr =~ /^proxy_/) {
679             return $sth->{$attr};
680             }
681              
682             my $type = $ATTR{$attr} || 'remote';
683             if ($type eq 'inherited') {
684             if (exists($sth->{$attr})) {
685             return $sth->{$attr};
686             }
687             return $sth->FETCH('Database')->{$attr};
688             }
689              
690             if ($type eq 'cache_only' &&
691             exists($sth->{'proxy_attr_cache'}->{$attr})) {
692             return $sth->{'proxy_attr_cache'}->{$attr};
693             }
694              
695             if ($type ne 'local') {
696             my $rsth = $sth->{'proxy_sth'} or return undef;
697             local $SIG{__DIE__} = 'DEFAULT';
698             local $@;
699             my $result = eval { $rsth->FETCH($attr) };
700             return DBD::Proxy::proxy_set_err($sth, $@) if $@;
701             return $result;
702             }
703             elsif ($attr eq 'RowsInCache') {
704             my $data = $sth->{'proxy_data'};
705             $data ? @$data : 0;
706             }
707             else {
708             $sth->SUPER::FETCH($attr);
709             }
710             }
711              
712             sub bind_param ($$$@) {
713             my $sth = shift; my $param = shift;
714             $sth->{'proxy_params'}->[$param-1] = [@_];
715             }
716             *bind_param_inout = \&bind_param;
717              
718             sub DESTROY {
719             my $sth = shift;
720             $sth->finish if $sth->SUPER::FETCH('Active');
721             }
722              
723              
724             1;
725              
726              
727             __END__