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