[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/i586-linux-thread-multi/DBD/ -> Proxy.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1