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