[ 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/DBD/ -> PgPP.pm (source)

   1  package DBD::PgPP;
   2  use strict;
   3  
   4  use DBI;
   5  use Carp ();
   6  use IO::Socket ();
   7  
   8  =head1 NAME
   9  
  10  DBD::PgPP - Pure Perl PostgreSQL driver for the DBI
  11  
  12  =head1 SYNOPSIS
  13  
  14    use DBI;
  15  
  16    my $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', '');
  17  
  18    # See the DBI module documentation for full details
  19  
  20  =cut
  21  
  22  our $VERSION = '0.06';
  23  my $BUFFER_LEN = 1500;
  24  my $DEBUG;
  25  
  26  my %BYTEA_DEMANGLE = (
  27      '\\' => '\\',
  28      map { sprintf('%03o', $_) => chr $_ } 0 .. 255,
  29  );
  30  
  31  {
  32      my $drh;
  33      sub driver {
  34          my ($class, $attr) = @_;
  35          return $drh ||= DBI::_new_drh("$class\::dr", {
  36              Name        => 'PgPP',
  37              Version     => $VERSION,
  38              Err         => \(my $err    = 0),
  39              Errstr      => \(my $errstr = ''),
  40              State       => \(my $state  = undef),
  41              Attribution => 'DBD::PgPP by Hiroyuki OYAMA',
  42          }, {});
  43      }
  44  }
  45  
  46  sub pgpp_server_identification { $_[0]->FETCH('pgpp_connection')->{server_identification} }
  47  sub pgpp_server_version_num    { $_[0]->FETCH('pgpp_connection')->{server_version_num} }
  48  sub pgpp_server_version        { $_[0]->FETCH('pgpp_connection')->{server_version} }
  49  
  50  sub _parse_dsn {
  51      my ($class, $dsn, $args) = @_;
  52  
  53      return if !defined $dsn;
  54  
  55      my ($hash, $var, $val);
  56      while (length $dsn) {
  57          if ($dsn =~ /([^:;]*)[:;](.*)/) {
  58              $val = $1;
  59              $dsn = $2;
  60          }
  61          else {
  62              $val = $dsn;
  63              $dsn = '';
  64          }
  65          if ($val =~ /([^=]*)=(.*)/) {
  66              $var = $1;
  67              $val = $2;
  68              if ($var eq 'hostname' || $var eq 'host') {
  69                  $hash->{'host'} = $val;
  70              }
  71              elsif ($var eq 'db' || $var eq 'dbname') {
  72                  $hash->{'database'} = $val;
  73              }
  74              else {
  75                  $hash->{$var} = $val;
  76              }
  77          }
  78          else {
  79              for $var (@$args) {
  80                  if (!defined($hash->{$var})) {
  81                      $hash->{$var} = $val;
  82                      last;
  83                  }
  84              }
  85          }
  86      }
  87      return $hash;
  88  }
  89  
  90  sub _parse_dsn_host {
  91      my ($class, $dsn) = @_;
  92      my $hash = $class->_parse_dsn($dsn, ['host', 'port']);
  93      return @$hash{qw<host port>};
  94  }
  95  
  96  
  97  package DBD::PgPP::dr;
  98  
  99  $DBD::PgPP::dr::imp_data_size = 0;
 100  
 101  sub connect {
 102      my ($drh, $dsn, $user, $password, $attrhash) = @_;
 103  
 104      my $data_source_info
 105          = DBD::PgPP->_parse_dsn($dsn, ['database', 'host', 'port']);
 106      $user     ||= '';
 107      $password ||= '';
 108  
 109      my $dbh = DBI::_new_dbh($drh, { Name => $dsn, USER => $user }, {});
 110      eval {
 111          my $pgsql = DBD::PgPP::Protocol->new(
 112              hostname => $data_source_info->{host},
 113              port     => $data_source_info->{port},
 114              database => $data_source_info->{database},
 115              user     => $user,
 116              password => $password,
 117              debug    => $data_source_info->{debug},
 118              path     => $data_source_info->{path},
 119          );
 120          $dbh->STORE(pgpp_connection => $pgsql);
 121      };
 122      if ($@) {
 123          $dbh->DBI::set_err(1, $@);
 124          return undef;
 125      }
 126      return $dbh;
 127  }
 128  
 129  sub data_sources { 'dbi:PgPP:' }
 130  
 131  sub disconnect_all {}
 132  
 133  
 134  package DBD::PgPP::db;
 135  
 136  $DBD::PgPP::db::imp_data_size = 0;
 137  
 138  # We need to implement ->quote, because otherwise we get the default DBI
 139  # one, which ignores backslashes.  The DBD::Pg implementation doubles all
 140  # backslashes and apostrophes; this version backslash-protects all of them.
 141  # XXX: What about null characters, or byte sequences that don't form valid
 142  # characters in the relevant encoding?
 143  # XXX: What about the mysterious additional '$data_type' argument?
 144  sub quote {
 145      my ($dbh, $s) = @_;
 146  
 147      if (!defined $s) {
 148          # Yes, _every_ DBD that needs its own quote method has to check for
 149          # nulls separately.
 150          return 'NULL';
 151      }
 152      else {
 153          die 'Cannot quote values containing \0 bytes'
 154              if $s =~ /\0/;
 155  
 156          # In PostgreSQL versions before 8.1, plain old string literals are
 157          # assumed to use backslash escaping.  But that's incompatible with
 158          # the SQL standard, which admits no special meaning for \ in a
 159          # string literal, and requires the single-quote character to be
 160          # doubled for inclusion in a literal.  So PostgreSQL 8.1 introduces
 161          # a new extension: an "escaped string" syntax E'...'  which is
 162          # unambiguously defined to support backslash sequences.  The plan is
 163          # apparently that some future version of PostgreSQL will change
 164          # plain old literals to use the SQL-standard interpretation.  So the
 165          # only way I can quote reliably on both current versions and that
 166          # hypothetical future version is to (a) always put backslashes in
 167          # front of both single-quote and backslash, and (b) use the E'...'
 168          # syntax if we know we're speaking to a version recent enough to
 169          # support it.
 170          #
 171          # Also, it's best to always quote the value, even if it looks like a
 172          # simple integer.  Otherwise you can't compare the result of quoting
 173          # Perl numeric zero to a boolean column.  (You can't _reliably_
 174          # compare a Perl scalar to a boolean column anyway, because there
 175          # are six Postgres syntaxes for TRUE, and six for FALSE, and
 176          # everything else is an error -- but that's another story, and at
 177          # least if you quote '0' it looks false to Postgres.  Sigh.  I have
 178          # some plans for a pure-Perl DBD which understands the 7.4 protocol,
 179          # and can therefore fix up bools in _both_ directions.)
 180  
 181          my $version = $dbh->FETCH('pgpp_connection')->{server_version_num};
 182          $s =~ s/(?=[\\\'])/\\/g;
 183          return $version >= 80100 ? "E'$s'" : "'$s'";
 184      }
 185  }
 186  
 187  sub prepare {
 188      my ($dbh, $statement, @attribs) = @_;
 189  
 190      die 'PostgreSQL cannot accept queries containing \0 bytes'
 191          if $statement =~ /\0/;
 192  
 193      my $pgsql = $dbh->FETCH('pgpp_connection');
 194      my $parsed = $pgsql->parse_statement($statement);
 195  
 196      my $sth = DBI::_new_sth($dbh, { Statement => $statement });
 197      $sth->STORE(pgpp_parsed_stmt => $parsed);
 198      $sth->STORE(pgpp_handle => $pgsql);
 199      $sth->STORE(pgpp_params => []);
 200      $sth->STORE(NUM_OF_PARAMS => scalar grep { ref } @$parsed);
 201      $sth;
 202  }
 203  
 204  sub commit {
 205      my ($dbh) = @_;
 206  
 207      my $pgsql = $dbh->FETCH('pgpp_connection');
 208      eval {
 209          my $pgsth = $pgsql->prepare('COMMIT');
 210          $pgsth->execute;
 211      };
 212      if ($@) {
 213          $dbh->DBI::set_err(1, $@); # $pgsql->get_error_message ???
 214          return undef;
 215      }
 216      return 1;
 217  }
 218  
 219  sub rollback {
 220      my ($dbh) = @_;
 221      my $pgsql = $dbh->FETCH('pgpp_connection');
 222      eval {
 223          my $pgsth = $pgsql->prepare('ROLLBACK');
 224          $pgsth->execute;
 225      };
 226      if ($@) {
 227          $dbh->DBI::set_err(1, $@); # $pgsql->get_error_message ???
 228          return undef;
 229      }
 230      return 1;
 231  }
 232  
 233  sub disconnect {
 234      my ($dbh) = @_;
 235  
 236      if (my $conn = $dbh->FETCH('pgpp_connection')) {
 237          $conn->close;
 238          $dbh->STORE('pgpp_connection', undef);
 239      }
 240  
 241      return 1;
 242  }
 243  
 244  sub FETCH {
 245      my ($dbh, $key) = @_;
 246  
 247      return $dbh->{$key} if $key =~ /^pgpp_/;
 248      return $dbh->{AutoCommit} if $key eq 'AutoCommit';
 249      return $dbh->SUPER::FETCH($key);
 250  }
 251  
 252  sub STORE {
 253      my ($dbh, $key, $new) = @_;
 254  
 255      if ($key eq 'AutoCommit') {
 256          my $old = $dbh->{$key};
 257          my $never_set = !$dbh->{pgpp_ever_set_autocommit};
 258  
 259          # This logic is stolen from DBD::Pg
 260          if (!$old && $new && $never_set) {
 261              # Do nothing; fall through
 262          }
 263          elsif (!$old && $new) {
 264              # Turning it on: commit
 265              # XXX: Avoid this if no uncommitted changes.
 266              # XXX: Desirable?  See dbi-dev archives.
 267              # XXX: Handle errors.
 268              my $st = $dbh->{pgpp_connection}->prepare('COMMIT');
 269              $st->execute;
 270          }
 271          elsif ($old && !$new   ||  !$old && !$new && $never_set) {
 272              # Turning it off, or initializing it to off at
 273              # connection time: begin a new transaction
 274              # XXX: Handle errors.
 275              my $st = $dbh->{pgpp_connection}->prepare('BEGIN');
 276              $st->execute;
 277          }
 278  
 279          $dbh->{pgpp_ever_set_autocommit} = 1;
 280          $dbh->{$key} = $new;
 281  
 282          return 1;
 283      }
 284  
 285      if ($key =~ /^pgpp_/) {
 286          $dbh->{$key} = $new;
 287          return 1;
 288      }
 289  
 290      return $dbh->SUPER::STORE($key, $new);
 291  }
 292  
 293  sub last_insert_id {
 294      my ($db, undef, $schema, $table, undef, $attr) = @_;
 295      # DBI uses (catalog,schema,table,column), but we don't make use of
 296      # catalog or column, so don't bother storing them.
 297  
 298      my $pgsql = $db->FETCH('pgpp_connection');
 299  
 300      if (!defined $attr) {
 301          $attr = {};
 302      }
 303      elsif (!ref $attr && $attr ne '') {
 304          # If not a hash, assume it is a sequence name
 305          $attr = { sequence => $attr };
 306      }
 307      elsif (ref $attr ne 'HASH') {
 308          return $db->set_err(1, "last_insert_id attrs must be a hashref");
 309      }
 310  
 311      # Catalog and col are not used
 312      $schema = '' if !defined $schema;
 313      $table = ''  if !defined $table;
 314  
 315      # Cache all of our table lookups? Default is yes
 316      my $use_cache = exists $attr->{pgpp_cache} ? $attr->{pgpp_cache} : 1;
 317  
 318      # Cache key.  Note we must distinguish ("a.b", "c") from ("a", "b.c")
 319      # (and XXX: we ought really to have tests for that)
 320      my $cache_key = join '.', map { quotemeta } $schema, $table;
 321  
 322      my $sequence;
 323      if (defined $attr->{sequence}) {
 324          # Named sequence overrides any table or schema settings
 325          $sequence = $attr->{sequence};
 326      }
 327      elsif ($use_cache && exists $db->{pgpp_liicache}{$cache_key}) {
 328          $sequence = $db->{pgpp_liicache}{$cache_key};
 329      }
 330      else {
 331          # At this point, we must have a valid table name
 332          return $db->set_err(1, "last_insert_id needs a sequence or table name")
 333              if $table eq '';
 334  
 335          my @args = $table;
 336  
 337          # Only 7.3 and up can use schemas
 338          my $pg_catalog;
 339          if ($pgsql->{server_version_num} < 70300) {
 340              $schema = '';
 341              $pg_catalog = '';
 342          }
 343          else {
 344              $pg_catalog = 'pg_catalog.';
 345          }
 346  
 347          # Make sure the table in question exists and grab its oid
 348          my ($schemajoin, $schemawhere) = ('','');
 349          if (length $schema) {
 350              $schemajoin =
 351                  ' JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace';
 352              $schemawhere = ' AND n.nspname = ?';
 353              push @args, $schema;
 354          }
 355  
 356          my $st = $db->prepare(qq[
 357              SELECT c.oid FROM $pg_catalog}pg_class c $schemajoin
 358              WHERE relname = ? $schemawhere
 359          ]);
 360          my $count = $st->execute(@args);
 361          if (!defined $count) {
 362              $st->finish;
 363              my $message = qq{Could not find the table "$table"};
 364              $message .= qq{ in the schema "$schema"} if $schema ne '';
 365              return $db->set_err(1, $message);
 366          }
 367          my $oid = $st->fetchall_arrayref->[0][0];
 368          # This table has a primary key. Is there a sequence associated with
 369          # it via a unique, indexed column?
 370          $st = $db->prepare(qq[
 371              SELECT a.attname, i.indisprimary, substring(d.adsrc for 128) AS def
 372              FROM $pg_catalog}pg_index i
 373              JOIN $pg_catalog}pg_attribute a ON a.attrelid = i.indrelid
 374                                              AND a.attnum   = i.indkey[0]
 375              JOIN $pg_catalog}pg_attrdef d   ON d.adrelid = a.attrelid
 376                                              AND d.adnum   = a.attnum
 377              WHERE i.indrelid = $oid
 378                AND a.attrelid = $oid
 379                AND i.indisunique IS TRUE
 380                AND a.atthasdef IS TRUE
 381                AND d.adsrc ~ '^nextval'
 382          ]);
 383          $count = $st->execute;
 384          if (!defined $count) {
 385              $st->finish;
 386              return $db->set_err(1, qq{No suitable column found for last_insert_id of table "$table"});
 387          }
 388          my $info = $st->fetchall_arrayref;
 389  
 390          # We have at least one with a default value. See if we can determine
 391          # sequences
 392          my @def;
 393          for (@$info) {
 394              my ($seq) = $_->[2] =~ /^nextval\('([^']+)'::/ or next;
 395              push @def, [@$_, $seq];
 396          }
 397  
 398          return $db->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n})
 399              if !@def;
 400  
 401          # Tiebreaker goes to the primary keys
 402          if (@def > 1) {
 403              my @pri = grep { $_->[1] } @def;
 404              return $db->set_err(1, qq{No suitable column found for last_insert_id of table "$table"\n})
 405                  if @pri != 1;
 406              @def = @pri;
 407          }
 408  
 409          $sequence = $def[0][3];
 410  
 411          # Cache this information for subsequent calls
 412          $db->{pgpp_liicache}{$cache_key} = $sequence;
 413      }
 414  
 415      my $st = $db->prepare("SELECT currval(?)");
 416      $st->execute($sequence);
 417      return $st->fetchall_arrayref->[0][0];
 418  }
 419  
 420  sub DESTROY {
 421      my ($dbh) = @_;
 422      $dbh->disconnect;
 423  }
 424  
 425  package DBD::PgPP::st;
 426  
 427  $DBD::PgPP::st::imp_data_size = 0;
 428  
 429  sub bind_param {
 430      my ($sth, $index, $value, $attr) = @_;
 431      my $type = ref($attr) ? $attr->{TYPE} : $attr;
 432      my $dbh = $sth->{Database};
 433      my $params = $sth->FETCH('pgpp_params');
 434      $params->[$index - 1] = $dbh->quote($value, $type);
 435  }
 436  
 437  sub execute {
 438      my ($sth, @args) = @_;
 439  
 440      my $pgsql = $sth->FETCH('pgpp_handle');
 441      die "execute on disconnected database" if $pgsql->{closed};
 442  
 443      my $num_params = $sth->FETCH('NUM_OF_PARAMS');
 444  
 445      if (@args) {
 446          return $sth->set_err(1, "Wrong number of arguments")
 447              if @args != $num_params;
 448          my $dbh = $sth->{Database};
 449          $_ = $dbh->quote($_) for @args;
 450      }
 451      else {
 452          my $bind_params = $sth->FETCH('pgpp_params');
 453          return $sth->set_err(1, "Wrong number of bound parameters")
 454              if @$bind_params != $num_params;
 455  
 456          # They've already been quoted by ->bind_param
 457          @args = @$bind_params;
 458      }
 459  
 460      my $parsed_statement = $sth->FETCH('pgpp_parsed_stmt');
 461      my $statement = join '', map { ref() ? $args[$$_] : $_ } @$parsed_statement;
 462  
 463      my $result;
 464      eval {
 465          $sth->{pgpp_record_iterator} = undef;
 466          my $pgsql_sth = $pgsql->prepare($statement);
 467          $pgsql_sth->execute;
 468          $sth->{pgpp_record_iterator} = $pgsql_sth;
 469          my $dbh = $sth->{Database};
 470  
 471          if (defined $pgsql_sth->{affected_rows}) {
 472              $sth->{pgpp_rows} = $pgsql_sth->{affected_rows};
 473              $result = $pgsql_sth->{affected_rows};
 474          }
 475          else {
 476              $sth->{pgpp_rows} = 0;
 477              $result = $pgsql_sth->{affected_rows};
 478          }
 479          if (!$pgsql_sth->{row_description}) {
 480              $sth->STORE(NUM_OF_FIELDS => 0);
 481              $sth->STORE(NAME          => []);
 482          }
 483          else {
 484              $sth->STORE(NUM_OF_FIELDS => scalar @{$pgsql_sth->{row_description}});
 485              $sth->STORE(NAME => [ map {$_->{name}} @{$pgsql_sth->{row_description}} ]);
 486          }
 487      };
 488      if ($@) {
 489          $sth->DBI::set_err(1, $@);
 490          return undef;
 491      }
 492  
 493      return $pgsql->has_error ? undef
 494           : $result           ? $result
 495           :                     '0E0';
 496  }
 497  
 498  sub fetch {
 499      my ($sth) = @_;
 500  
 501      my $iterator = $sth->FETCH('pgpp_record_iterator');
 502      return undef if $iterator->{finished};
 503  
 504      if (my $row = $iterator->fetch) {
 505          if ($sth->FETCH('ChopBlanks')) {
 506              s/\s+\z// for @$row;
 507          }
 508          return $sth->_set_fbav($row);
 509      }
 510  
 511      $iterator->{finished} = 1;
 512      return undef;
 513  }
 514  *fetchrow_arrayref = \&fetch;
 515  
 516  sub rows {
 517      my ($sth) = @_;
 518      return defined $sth->{pgpp_rows} ? $sth->{pgpp_rows} : 0;
 519  }
 520  
 521  sub FETCH {
 522      my ($dbh, $key) = @_;
 523  
 524      # return $dbh->{AutoCommit} if $key eq 'AutoCommit';
 525      return $dbh->{NAME} if $key eq 'NAME';
 526      return $dbh->{$key} if $key =~ /^pgpp_/;
 527      return $dbh->SUPER::FETCH($key);
 528  }
 529  
 530  sub STORE {
 531      my ($sth, $key, $value) = @_;
 532  
 533      if ($key eq 'NAME') {
 534          $sth->{NAME} = $value;
 535          return 1;
 536      }
 537      elsif ($key =~ /^pgpp_/) {
 538          $sth->{$key} = $value;
 539          return 1;
 540      }
 541      elsif ($key eq 'NUM_OF_FIELDS') {
 542          # Don't set this twice; DBI doesn't seem to like it.
 543          # XXX: why not?  Perhaps this conceals a PgPP bug.
 544          my $curr = $sth->FETCH($key);
 545          return 1 if $curr && $curr == $value;
 546      }
 547      return $sth->SUPER::STORE($key, $value);
 548  }
 549  
 550  sub DESTROY { return }
 551  
 552  
 553  package DBD::PgPP::Protocol;
 554  
 555  use constant DEFAULT_UNIX_SOCKET => '/tmp';
 556  use constant DEFAULT_PORT_NUMBER => 5432;
 557  use constant DEFAULT_TIMEOUT     => 60;
 558  
 559  use constant AUTH_OK                 => 0;
 560  use constant AUTH_KERBEROS_V4        => 1;
 561  use constant AUTH_KERBEROS_V5        => 2;
 562  use constant AUTH_CLEARTEXT_PASSWORD => 3;
 563  use constant AUTH_CRYPT_PASSWORD     => 4;
 564  use constant AUTH_MD5_PASSWORD       => 5;
 565  use constant AUTH_SCM_CREDENTIAL     => 6;
 566  
 567  sub new {
 568      my ($class, %args) = @_;
 569  
 570      my $self = bless {
 571          hostname              => $args{hostname},
 572          path                  => $args{path}     || DEFAULT_UNIX_SOCKET,
 573          port                  => $args{port}     || DEFAULT_PORT_NUMBER,
 574          database              => $args{database} || $ENV{USER} || '',
 575          user                  => $args{user}     || $ENV{USER} || '',
 576          password              => $args{password} || '',
 577          args                  => $args{args}     || '',
 578          tty                   => $args{tty}      || '',
 579          timeout               => $args{timeout}  || DEFAULT_TIMEOUT,
 580          'socket'              => undef,
 581          backend_pid           => '',
 582          secret_key            => '',
 583          selected_record       => undef,
 584          error_message         => '',
 585          last_oid              => undef,
 586          server_identification => '',
 587          server_version        => '0.0.0',
 588          server_version_num    => 0,
 589      }, $class;
 590      $DEBUG = 1 if $args{debug};
 591      $self->_initialize;
 592      return $self;
 593  }
 594  
 595  sub close {
 596      my ($self) = @_;
 597      my $socket = $self->{'socket'} or return;
 598      return if !fileno $socket;
 599  
 600      my $terminate_packet = 'X' . pack 'N', 5;
 601      print " ==> Terminate\n" if $DEBUG;
 602      _dump_packet($terminate_packet);
 603      $socket->send($terminate_packet, 0);
 604      $socket->close;
 605      $self->{closed} = 1;
 606  }
 607  
 608  sub DESTROY {
 609      my ($self) = @_;
 610      $self->close if $self;
 611  }
 612  
 613  sub _initialize {
 614      my ($self) = @_;
 615      $self->_connect;
 616      $self->_do_startup;
 617      $self->_find_server_version;
 618  }
 619  
 620  sub _connect {
 621      my ($self) = @_;
 622  
 623      my $sock;
 624      if ($self->{hostname}) {
 625          $sock = IO::Socket::INET->new(
 626              PeerAddr => $self->{hostname},
 627              PeerPort => $self->{port},
 628              Proto    => 'tcp',
 629              Timeout  => $self->{timeout},
 630          ) or Carp::croak("Couldn't connect to $self->{hostname}:$self->{port}/tcp: $!");
 631      }
 632      else {
 633          (my $path = $self->{path}) =~ s{/*\z}{/.s.PGSQL.$self->{port}};
 634          $sock = IO::Socket::UNIX->new(
 635              Type => IO::Socket::SOCK_STREAM,
 636              Peer => $path,
 637          ) or Carp::croak("Couldn't connect to $path: $!");
 638      }
 639      $sock->autoflush(1);
 640      $self->{socket} = $sock;
 641  }
 642  
 643  sub get_handle { $_[0]{socket} }
 644  
 645  sub _do_startup {
 646      my ($self) = @_;
 647  
 648      # create message body
 649      my $packet = pack 'n n a64 a32 a64 a64 a64', (
 650          2,                      # Protocol major version - Int16bit
 651          0,                      # Protocol minor version - Int16bit
 652          $self->{database},      # Database name          - LimString64
 653          $self->{user},          # User name              - LimString32
 654          $self->{args},          # Command line args      - LimString64
 655          '',                     # Unused                 - LimString64
 656          $self->{tty}            # Debugging msg tty      - LimString64
 657      );
 658  
 659      # add packet length
 660      $packet = pack('N', length($packet) + 4). $packet;
 661  
 662      print " ==> StartupPacket\n" if $DEBUG;
 663      _dump_packet($packet);
 664      $self->{socket}->send($packet, 0);
 665      $self->_do_authentication;
 666  }
 667  
 668  sub _find_server_version {
 669      my ($self) = @_;
 670      eval {
 671          # If this function doesn't exist (as was the case in PostgreSQL 7.1
 672          # and earlier), we'll end up leaving the version as 0.0.0.  I can
 673          # live with that.
 674          my $st = $self->prepare(q[SELECT version()]);
 675          $st->execute;
 676          my $data = $st->fetch;
 677          1 while $st->fetch;
 678          my $id = $data->[0];
 679          $self->{server_identification} = $id;
 680          if (my ($ver) = $id =~ /\A PostgreSQL \s+ ([0-9._]+) (?:\s|\z)/x) {
 681              $self->{server_version} = $ver;
 682              if (my ($maj, $min, $sub)
 683                      = $ver =~ /\A ([0-9]+)\.([0-9]{1,2})\.([0-9]{1,2}) \z/x) {
 684                  $self->{server_version_num} = ($maj * 100 + $min) * 100 + $sub;
 685              }
 686          }
 687      };
 688  }
 689  
 690  sub _dump_packet {
 691      return unless $DBD::PgPP::Protocol::DEBUG;
 692  
 693      my ($packet) = @_;
 694  
 695      printf "%s()\n", (caller 1)[3];
 696      while ($packet =~ m/(.{1,16})/g) {
 697          my $chunk = $1;
 698          print join ' ', map { sprintf '%02X', ord $_ } split //, $chunk;
 699          print '   ' x (16 - length $chunk);
 700          print '  ';
 701          print join '',
 702              map { sprintf '%s', (/[[:graph:] ]/) ? $_ : '.' } split //, $chunk;
 703          print "\n";
 704      }
 705  }
 706  
 707  sub get_stream {
 708      my ($self) = @_;
 709      $self->{stream} = DBD::PgPP::PacketStream->new($self->{'socket'})
 710          if !defined $self->{stream};
 711      return $self->{stream};
 712  }
 713  
 714  sub _do_authentication {
 715      my ($self) = @_;
 716      my $stream = $self->get_stream;
 717      while (1) {
 718          my $packet = $stream->each;
 719          last if $packet->is_end_of_response;
 720          Carp::croak($packet->get_message) if $packet->is_error;
 721          $packet->compute($self);
 722      }
 723  }
 724  
 725  sub prepare {
 726      my ($self, $sql) = @_;
 727  
 728      $self->{error_message} = '';
 729      return DBD::PgPP::ProtocolStatement->new($self, $sql);
 730  }
 731  
 732  sub has_error {
 733      my ($self) = @_;
 734      return 1 if $self->{error_message};
 735  }
 736  
 737  sub get_error_message {
 738      my ($self) = @_;
 739      return $self->{error_message};
 740  }
 741  
 742  sub parse_statement {
 743      my ($invocant, $statement) = @_;
 744  
 745      my $param_num = 0;
 746      my $comment_depth = 0;
 747      my @tokens = ('');
 748    Parse: for ($statement) {
 749          # Observe the default action at the end
 750          if    (m{\G \z}xmsgc) { last Parse }
 751          elsif (m{\G( /\* .*? ) (?= /\* | \*/) }xmsgc) { $comment_depth++ }
 752          elsif ($comment_depth && m{\G( .*? ) (?= /\* | \*/)}xmsgc) { }
 753          elsif ($comment_depth && m{\G( \*/ )}xmsgc)   { $comment_depth-- }
 754          elsif (m{\G \?}xmsgc) {
 755              pop @tokens if $tokens[-1] eq '';
 756              push @tokens, \(my $tmp = $param_num++), '';
 757              redo Parse;
 758          }
 759          elsif (m{\G( -- [^\n]* )}xmsgc) { }
 760          elsif (m{\G( \' (?> [^\\\']* (?> \\. [^\\\']*)* ) \' )}xmsgc) { }
 761          elsif (m{\G( \" [^\"]* \" )}xmsgc) { }
 762          elsif (m{\G( \s+ | \w+ | ::? | \$[0-9]+ | [-/*\$]
 763                   | [^[:ascii:]]+ | [\0-\037\177]+)}xmsgc) { }
 764          elsif (m{\G( [+<>=~!\@\#%^&|`,;.()\[\]{}]+ )}xmsgc) { }
 765          elsif (m{\G( [\'\"\\] )}xmsgc) { } # unmatched: a bug in your query
 766          else {
 767              my $pos = pos;
 768              die "BUG: can't parse statement at $pos\n$statement\n";
 769          }
 770  
 771          $tokens[-1] .= $1;
 772          redo Parse;
 773      }
 774  
 775      pop @tokens if @tokens > 1 && $tokens[-1] eq '';
 776  
 777      return \@tokens;
 778  }
 779  
 780  
 781  package DBD::PgPP::ProtocolStatement;
 782  
 783  sub new {
 784      my ($class, $pgsql, $statement) = @_;
 785      bless {
 786          postgres  => $pgsql,
 787          statement => $statement,
 788          rows      => [],
 789      }, $class;
 790  }
 791  
 792  sub execute {
 793      my ($self) = @_;
 794  
 795      my $pgsql = $self->{postgres};
 796      my $handle = $pgsql->get_handle;
 797  
 798      my $query_packet = "Q$self->{statement}\0";
 799      print " ==> Query\n" if $DEBUG;
 800      DBD::PgPP::Protocol::_dump_packet($query_packet);
 801      $handle->send($query_packet, 0);
 802      $self->{affected_rows} = 0;
 803      $self->{last_oid}      = undef;
 804      $self->{rows}          = [];
 805  
 806      my $stream = $pgsql->get_stream;
 807      my $packet = $stream->each;
 808      if ($packet->is_error) {
 809          $self->_to_end_of_response($stream);
 810          die $packet->get_message;
 811      }
 812      elsif ($packet->is_end_of_response) {
 813          return;
 814      }
 815      elsif ($packet->is_empty) {
 816          $self->_to_end_of_response($stream);
 817          return;
 818      }
 819      while ($packet->is_notice_response) {
 820          # XXX: discard it for now
 821          $packet = $stream->each;
 822      }
 823      if ($packet->is_cursor_response) {
 824          $packet->compute($pgsql);
 825          my $row_info = $stream->each; # fetch RowDescription
 826          if ($row_info->is_error) {
 827              $self->_to_end_of_response($stream);
 828              Carp::croak($row_info->get_message);
 829          }
 830          $row_info->compute($self);
 831          while (1) {
 832              my $row_packet = $stream->each;
 833              if ($row_packet->is_error) {
 834                  $self->_to_end_of_response($stream);
 835                  Carp::croak($row_packet->get_message);
 836              }
 837              $row_packet->compute($self);
 838              push @{ $self->{rows} }, $row_packet->get_result;
 839              last if $row_packet->is_end_of_response;
 840          }
 841          return;
 842      }
 843      else {                      # CompletedResponse
 844          $packet->compute($self);
 845          while (1) {
 846              my $end = $stream->each;
 847              if ($end->is_error) {
 848                  $self->_to_end_of_response($stream);
 849                  Carp::croak($end->get_message);
 850              }
 851              last if $end->is_end_of_response;
 852          }
 853          return;
 854      }
 855  }
 856  
 857  sub _to_end_of_response {
 858      my ($self, $stream) = @_;
 859  
 860      while (1) {
 861          my $packet = $stream->each;
 862          $packet->compute($self);
 863          last if $packet->is_end_of_response;
 864      }
 865  }
 866  
 867  sub fetch {
 868      my ($self) = @_;
 869      return shift @{ $self->{rows} }; # shift returns undef if empty
 870  }
 871  
 872  
 873  package DBD::PgPP::PacketStream;
 874  
 875  # Message Identifiers
 876  use constant ASCII_ROW             => 'D';
 877  use constant AUTHENTICATION        => 'R';
 878  use constant BACKEND_KEY_DATA      => 'K';
 879  use constant BINARY_ROW            => 'B';
 880  use constant COMPLETED_RESPONSE    => 'C';
 881  use constant COPY_IN_RESPONSE      => 'G';
 882  use constant COPY_OUT_RESPONSE     => 'H';
 883  use constant CURSOR_RESPONSE       => 'P';
 884  use constant EMPTY_QUERY_RESPONSE  => 'I';
 885  use constant ERROR_RESPONSE        => 'E';
 886  use constant FUNCTION_RESPONSE     => 'V';
 887  use constant NOTICE_RESPONSE       => 'N';
 888  use constant NOTIFICATION_RESPONSE => 'A';
 889  use constant READY_FOR_QUERY       => 'Z';
 890  use constant ROW_DESCRIPTION       => 'T';
 891  
 892  # Authentication Message specifiers
 893  use constant AUTHENTICATION_OK                 => 0;
 894  use constant AUTHENTICATION_KERBEROS_V4        => 1;
 895  use constant AUTHENTICATION_KERBEROS_V5        => 2;
 896  use constant AUTHENTICATION_CLEARTEXT_PASSWORD => 3;
 897  use constant AUTHENTICATION_CRYPT_PASSWORD     => 4;
 898  use constant AUTHENTICATION_MD5_PASSWORD       => 5;
 899  use constant AUTHENTICATION_SCM_CREDENTIAL     => 6;
 900  
 901  sub new {
 902      my ($class, $handle) = @_;
 903      bless {
 904          handle => $handle,
 905          buffer => '',
 906      }, $class;
 907  }
 908  
 909  sub set_buffer {
 910      my ($self, $buffer) = @_;
 911      $self->{buffer} = $buffer;
 912  }
 913  
 914  sub get_buffer { $_[0]{buffer} }
 915  
 916  sub each {
 917      my ($self) = @_;
 918      my $type = $self->_get_byte;
 919      # XXX: This would perhaps be better as a dispatch table
 920      my $p  = $type eq ASCII_ROW             ? $self->_each_ascii_row
 921             : $type eq AUTHENTICATION        ? $self->_each_authentication
 922             : $type eq BACKEND_KEY_DATA      ? $self->_each_backend_key_data
 923             : $type eq BINARY_ROW            ? $self->_each_binary_row
 924             : $type eq COMPLETED_RESPONSE    ? $self->_each_completed_response
 925             : $type eq COPY_IN_RESPONSE      ? $self->_each_copy_in_response
 926             : $type eq COPY_OUT_RESPONSE     ? $self->_each_copy_out_response
 927             : $type eq CURSOR_RESPONSE       ? $self->_each_cursor_response
 928             : $type eq EMPTY_QUERY_RESPONSE  ? $self->_each_empty_query_response
 929             : $type eq ERROR_RESPONSE        ? $self->_each_error_response
 930             : $type eq FUNCTION_RESPONSE     ? $self->_each_function_response
 931             : $type eq NOTICE_RESPONSE       ? $self->_each_notice_response
 932             : $type eq NOTIFICATION_RESPONSE ? $self->_each_notification_response
 933             : $type eq READY_FOR_QUERY       ? $self->_each_ready_for_query
 934             : $type eq ROW_DESCRIPTION       ? $self->_each_row_description
 935             :         Carp::croak("Unknown message type: '$type'");
 936      if ($DEBUG) {
 937          (my $type = ref $p) =~ s/.*:://;
 938          print "<==  $type\n";
 939      }
 940      return $p;
 941  }
 942  
 943  sub _each_authentication {
 944      my ($self) = @_;
 945  
 946      my $code = $self->_get_int32;
 947      if ($code == AUTHENTICATION_OK) {
 948          return DBD::PgPP::AuthenticationOk->new;
 949      }
 950      elsif ($code == AUTHENTICATION_KERBEROS_V4) {
 951          return DBD::PgPP::AuthenticationKerberosV4->new;
 952      }
 953      elsif ($code == AUTHENTICATION_KERBEROS_V5) {
 954          return DBD::PgPP::AuthenticationKerberosV5->new;
 955      }
 956      elsif ($code == AUTHENTICATION_CLEARTEXT_PASSWORD) {
 957          return DBD::PgPP::AuthenticationCleartextPassword->new;
 958      }
 959      elsif ($code == AUTHENTICATION_CRYPT_PASSWORD) {
 960          my $salt = $self->_get_byte(2);
 961          return DBD::PgPP::AuthenticationCryptPassword->new($salt);
 962      }
 963      elsif ($code == AUTHENTICATION_MD5_PASSWORD) {
 964          my $salt = $self->_get_byte(4);
 965          return DBD::PgPP::AuthenticationMD5Password->new($salt);
 966      }
 967      elsif ($code == AUTHENTICATION_SCM_CREDENTIAL) {
 968          return DBD::PgPP::AuthenticationSCMCredential->new;
 969      }
 970      else {
 971          Carp::croak("Unknown authentication type: $code");
 972      }
 973  }
 974  
 975  sub _each_backend_key_data {
 976      my ($self) = @_;
 977      my $process_id = $self->_get_int32;
 978      my $secret_key = $self->_get_int32;
 979      return DBD::PgPP::BackendKeyData->new($process_id, $secret_key);
 980  }
 981  
 982  sub _each_error_response {
 983      my ($self) = @_;
 984      my $error_message = $self->_get_c_string;
 985      return DBD::PgPP::ErrorResponse->new($error_message);
 986  }
 987  
 988  sub _each_notice_response {
 989      my ($self) = @_;
 990      my $notice_message = $self->_get_c_string;
 991      return DBD::PgPP::NoticeResponse->new($notice_message);
 992  }
 993  
 994  sub _each_notification_response {
 995      my ($self) = @_;
 996      my $process_id = $self->_get_int32;
 997      my $condition = $self->_get_c_string;
 998      return DBD::PgPP::NotificationResponse->new($process_id, $condition);
 999  }
1000  
1001  sub _each_ready_for_query {
1002      my ($self) = @_;
1003      return DBD::PgPP::ReadyForQuery->new;
1004  }
1005  
1006  sub _each_cursor_response {
1007      my ($self) = @_;
1008      my $name = $self->_get_c_string;
1009      return DBD::PgPP::CursorResponse->new($name);
1010  }
1011  
1012  sub _each_row_description {
1013      my ($self) = @_;
1014      my $row_number = $self->_get_int16;
1015      my @description;
1016      for my $i (1 .. $row_number) {
1017          push @description, {
1018              name     => $self->_get_c_string,
1019              type     => $self->_get_int32,
1020              size     => $self->_get_int16,
1021              modifier => $self->_get_int32,
1022          };
1023      }
1024      return DBD::PgPP::RowDescription->new(\@description);
1025  }
1026  
1027  sub _each_ascii_row {
1028      my ($self) = @_;
1029      return DBD::PgPP::AsciiRow->new($self);
1030  }
1031  
1032  sub _each_completed_response {
1033      my ($self) = @_;
1034      my $tag = $self->_get_c_string;
1035      return DBD::PgPP::CompletedResponse->new($tag);
1036  }
1037  
1038  sub _each_empty_query_response {
1039      my ($self) = @_;
1040      my $unused = $self->_get_c_string;
1041      return DBD::PgPP::EmptyQueryResponse->new($unused);
1042  }
1043  
1044  sub _get_byte {
1045      my ($self, $length) = @_;
1046      $length = 1 if !defined $length;
1047  
1048      $self->_if_short_then_add_buffer($length);
1049      return substr $self->{buffer}, 0, $length, '';
1050  }
1051  
1052  sub _get_int32 {
1053      my ($self) = @_;
1054      $self->_if_short_then_add_buffer(4);
1055      return unpack 'N', substr $self->{buffer}, 0, 4, '';
1056  }
1057  
1058  sub _get_int16 {
1059      my ($self) = @_;
1060      $self->_if_short_then_add_buffer(2);
1061      return unpack 'n', substr $self->{buffer}, 0, 2, '';
1062  }
1063  
1064  sub _get_c_string {
1065      my ($self) = @_;
1066  
1067      my $null_pos;
1068      while (1) {
1069          $null_pos = index $self->{buffer}, "\0";
1070          last if $null_pos >= 0;
1071          $self->_if_short_then_add_buffer(1 + length $self->{buffer});
1072      }
1073      my $result = substr $self->{buffer}, 0, $null_pos, '';
1074      substr $self->{buffer}, 0, 1, ''; # remove trailing \0
1075      return $result;
1076  }
1077  
1078  # This method means "I'm about to read *this* many bytes from the buffer, so
1079  # make sure there are enough bytes available".  That is, on exit, you are
1080  # guaranteed that $length bytes are available.
1081  sub _if_short_then_add_buffer {
1082      my ($self, $length) = @_;
1083      $length ||= 0;
1084  
1085      my $handle = $self->{handle};
1086      while (length($self->{buffer}) < $length) {
1087          my $packet = '';
1088          $handle->recv($packet, $BUFFER_LEN, 0);
1089          DBD::PgPP::Protocol::_dump_packet($packet);
1090          $self->{buffer} .= $packet;
1091      }
1092  }
1093  
1094  
1095  package DBD::PgPP::Response;
1096  
1097  sub new {
1098      my ($class) = @_;
1099      bless {}, $class;
1100  }
1101  
1102  sub compute            { return }
1103  sub is_empty           { undef }
1104  sub is_error           { undef }
1105  sub is_end_of_response { undef }
1106  sub get_result         { undef }
1107  sub is_cursor_response { undef }
1108  sub is_notice_response { undef }
1109  
1110  
1111  package DBD::PgPP::AuthenticationOk;
1112  use base qw<DBD::PgPP::Response>;
1113  
1114  
1115  package DBD::PgPP::AuthenticationKerberosV4;
1116  use base qw<DBD::PgPP::Response>;
1117  
1118  sub compute { Carp::croak("authentication type 'Kerberos V4' not supported.\n") }
1119  
1120  
1121  package DBD::PgPP::AuthenticationKerberosV5;
1122  use base qw<DBD::PgPP::Response>;
1123  
1124  sub compute { Carp::croak("authentication type 'Kerberos V5' not supported.\n") }
1125  
1126  
1127  package DBD::PgPP::AuthenticationCleartextPassword;
1128  use base qw<DBD::PgPP::Response>;
1129  
1130  sub compute {
1131      my ($self, $pgsql) = @_;
1132      my $handle = $pgsql->get_handle;
1133      my $password = $pgsql->{password};
1134  
1135      my $packet = pack('N', length($password) + 4 + 1). $password. "\0";
1136      print " ==> PasswordPacket (cleartext)\n" if $DEBUG;
1137      DBD::PgPP::Protocol::_dump_packet($packet);
1138      $handle->send($packet, 0);
1139  }
1140  
1141  
1142  package DBD::PgPP::AuthenticationCryptPassword;
1143  use base qw<DBD::PgPP::Response>;
1144  
1145  sub new {
1146      my ($class, $salt) = @_;
1147      my $self = $class->SUPER::new;
1148      $self->{salt} = $salt;
1149      $self;
1150  }
1151  
1152  sub get_salt { $_[0]{salt} }
1153  
1154  sub compute {
1155      my ($self, $pgsql) = @_;
1156      my $handle = $pgsql->get_handle;
1157      my $password = $pgsql->{password} || '';
1158  
1159      $password = _encode_crypt($password, $self->{salt});
1160      my $packet = pack('N', length($password) + 4 + 1). $password. "\0";
1161      print " ==> PasswordPacket (crypt)\n" if $DEBUG;
1162      DBD::PgPP::Protocol::_dump_packet($packet);
1163      $handle->send($packet, 0);
1164  }
1165  
1166  sub _encode_crypt {
1167      my ($password, $salt) = @_;
1168  
1169      my $crypted = '';
1170      eval {
1171          $crypted = crypt($password, $salt);
1172          die "is MD5 crypt()" if _is_md5_crypt($crypted, $salt);
1173      };
1174      Carp::croak("authentication type 'crypt' not supported on your platform. please use  'trust' or 'md5' or 'ident' authentication")
1175            if $@;
1176      return $crypted;
1177  }
1178  
1179  sub _is_md5_crypt {
1180      my ($crypted, $salt) = @_;
1181      $crypted =~ /^\$1\$\Q$salt\E\$/;
1182  }
1183  
1184  
1185  package DBD::PgPP::AuthenticationMD5Password;
1186  use base qw<DBD::PgPP::AuthenticationCryptPassword>;
1187  
1188  sub new {
1189      my ($class, $salt) = @_;
1190      my $self = $class->SUPER::new;
1191      $self->{salt} = $salt;
1192      return $self;
1193  }
1194  
1195  sub compute {
1196      my ($self, $pgsql) = @_;
1197      my $handle = $pgsql->get_handle;
1198      my $password = $pgsql->{password} || '';
1199  
1200      my $md5ed_password = _encode_md5($pgsql->{user}, $password, $self->{salt});
1201      my $packet = pack('N', 1 + 4 + length $md5ed_password). "$md5ed_password\0";
1202      print " ==> PasswordPacket (md5)\n" if $DEBUG;
1203      DBD::PgPP::Protocol::_dump_packet($packet);
1204      $handle->send($packet, 0);
1205  }
1206  
1207  sub _encode_md5 {
1208      my ($user, $password, $salt) = @_;
1209  
1210      my $md5 = DBD::PgPP::EncodeMD5->create;
1211      $md5->add($password);
1212      $md5->add($user);
1213  
1214      my $tmp_digest = $md5->hexdigest;
1215      $md5->add($tmp_digest);
1216      $md5->add($salt);
1217  
1218      return 'md5' . $md5->hexdigest;
1219  }
1220  
1221  
1222  package DBD::PgPP::AuthenticationSCMCredential;
1223  use base qw<DBD::PgPP::Response>;
1224  
1225  sub compute { Carp::croak("authentication type 'SCM Credential' not supported.\n") }
1226  
1227  
1228  package DBD::PgPP::BackendKeyData;
1229  use base qw<DBD::PgPP::Response>;
1230  
1231  sub new {
1232      my ($class, $process_id, $secret_key) = @_;
1233      my $self = $class->SUPER::new;
1234      $self->{process_id} = $process_id;
1235      $self->{secret_key} = $secret_key;
1236      return $self;
1237  }
1238  
1239  sub get_process_id { $_[0]{process_id} }
1240  sub get_secret_key { $_[0]{secret_key} }
1241  
1242  sub compute {
1243      my ($self, $postgres) = @_;;
1244  
1245      $postgres->{process_id} = $self->get_process_id;
1246      $postgres->{secret_key} = $self->get_secret_key;
1247  }
1248  
1249  
1250  package DBD::PgPP::ErrorResponse;
1251  use base qw<DBD::PgPP::Response>;
1252  
1253  sub new {
1254      my ($class, $message) = @_;
1255      my $self = $class->SUPER::new;
1256      $self->{message} = $message;
1257      return $self;
1258  }
1259  
1260  sub get_message { $_[0]{message} }
1261  sub is_error    { 1 }
1262  
1263  
1264  package DBD::PgPP::NoticeResponse;
1265  use base qw<DBD::PgPP::ErrorResponse>;
1266  
1267  sub is_error           { undef }
1268  sub is_notice_response { 1 }
1269  
1270  
1271  package DBD::PgPP::NotificationResponse;
1272  use base qw<DBD::PgPP::Response>;
1273  
1274  sub new {
1275      my ($class, $process_id, $condition) = @_;
1276      my $self = $class->SUPER::new;
1277      $self->{process_id} = $process_id;
1278      $self->{condition} = $condition;
1279      return $self;
1280  }
1281  
1282  sub get_process_id { $_[0]{process_id} }
1283  sub get_condition  { $_[0]{condition} }
1284  
1285  
1286  package DBD::PgPP::ReadyForQuery;
1287  use base qw<DBD::PgPP::Response>;
1288  
1289  sub is_end_of_response { 1 }
1290  
1291  
1292  package DBD::PgPP::CursorResponse;
1293  use base qw<DBD::PgPP::Response>;
1294  
1295  sub new {
1296      my ($class, $name) = @_;
1297      my $self = $class->SUPER::new;
1298      $self->{name} = $name;
1299      return $self;
1300  }
1301  
1302  sub get_name           { $_[0]{name} }
1303  sub is_cursor_response { 1 }
1304  
1305  sub compute {
1306      my ($self, $pgsql) = @_;
1307      $pgsql->{cursor_name} = $self->get_name;
1308  }
1309  
1310  
1311  package DBD::PgPP::RowDescription;
1312  use base qw<DBD::PgPP::Response>;
1313  
1314  sub new {
1315      my ($class, $row_description) = @_;
1316      my $self = $class->SUPER::new;
1317      $self->{row_description} = $row_description;
1318      return $self;
1319  }
1320  
1321  sub compute {
1322      my ($self, $pgsql_sth) = @_;
1323      $pgsql_sth->{row_description} = $self->{row_description};
1324  }
1325  
1326  
1327  package DBD::PgPP::AsciiRow;
1328  use base qw<DBD::PgPP::Response>;
1329  
1330  sub new {
1331      my ($class, $stream) = @_;
1332      my $self = $class->SUPER::new;
1333      $self->{stream} = $stream;
1334      return $self;
1335  }
1336  
1337  sub compute {
1338      my ($self, $pgsql_sth) = @_;
1339  
1340      my $stream = $self->{stream};
1341      my $fields_length = @{ $pgsql_sth->{row_description} };
1342      my $bitmap_length = $self->_get_length_of_null_bitmap($fields_length);
1343      my $non_null = unpack 'B*', $stream->_get_byte($bitmap_length);
1344  
1345      my @result;
1346      for my $i (0 .. $fields_length - 1) {
1347          my $value;
1348          if (substr $non_null, $i, 1) {
1349              my $length = $stream->_get_int32;
1350              $value = $stream->_get_byte($length - 4);
1351              my $type_oid = $pgsql_sth->{row_description}[$i]{type};
1352              if ($type_oid == 16) { # bool
1353                  $value = ($value eq 'f') ? 0 : 1;
1354              }
1355              elsif ($type_oid == 17) { # bytea
1356                  $value =~ s{\\(\\|[0-7]{3})}{$BYTEA_DEMANGLE{$1}}g;
1357              }
1358          }
1359          push @result, $value;
1360      }
1361  
1362      $self->{result} = \@result;
1363  }
1364  
1365  sub _get_length_of_null_bitmap {
1366      my ($self, $number) = @_;
1367      use integer;
1368      my $length = $number / 8;
1369      ++$length if $number % 8;
1370      return $length;
1371  }
1372  
1373  sub get_result         { $_[0]{result} }
1374  sub is_cursor_response { 1 }
1375  
1376  
1377  package DBD::PgPP::CompletedResponse;
1378  use base qw<DBD::PgPP::Response>;
1379  
1380  sub new {
1381      my ($class, $tag) = @_;
1382      my $self = $class->SUPER::new;
1383      $self->{tag} = $tag;
1384      return $self;
1385  }
1386  
1387  sub get_tag { $_[0]{tag} }
1388  
1389  sub compute {
1390      my ($self, $pgsql_sth) = @_;
1391      my $tag = $self->{tag};
1392  
1393      if ($tag =~ /^INSERT (\d+) (\d+)/) {
1394          $pgsql_sth->{affected_oid}  = $1;
1395          $pgsql_sth->{affected_rows} = $2;
1396      }
1397      elsif ($tag =~ /^DELETE (\d+)/) {
1398          $pgsql_sth->{affected_rows} = $1;
1399      }
1400      elsif ($tag =~ /^UPDATE (\d+)/) {
1401          $pgsql_sth->{affected_rows} = $1;
1402      }
1403  }
1404  
1405  
1406  package DBD::PgPP::EmptyQueryResponse;
1407  use base qw<DBD::PgPP::Response>;
1408  
1409  sub is_empty { 1 }
1410  
1411  
1412  package DBD::PgPP::EncodeMD5;
1413  
1414  =pod
1415  
1416  =begin wish
1417  
1418  Please do not question closely about this source code ;-)
1419  
1420  =end wish
1421  
1422  =cut
1423  
1424  use vars qw<$a $b $c $d>;
1425  
1426  {
1427      my ($x, $n, $m, $l, $r, $z);
1428  
1429      sub create {
1430          my ($class) = @_;
1431          $class = 'Digest::MD5' if eval { require Digest::MD5; 1 };
1432          return $class->new;
1433      }
1434  
1435      sub new {
1436          my ($class) = @_;
1437          bless { source => '' }, $class;
1438      }
1439  
1440      sub add {
1441          my ($self, @data) = @_;
1442          $self->{source} .= join '', @data;
1443      }
1444  
1445      sub hexdigest {
1446          my ($self) = @_;
1447  
1448          my @A = unpack 'N4C24',
1449              unpack 'u', 'H9T4C`>_-JXF8NMS^$#)4=@<,$18%"0X4!`L0%P8*#Q4``04``04#!P``';
1450          my @K = map { int abs 2 ** 32 * sin $_ } 1 .. 64;
1451          my $p;
1452          my $position = 0;
1453          do {
1454              $_ = substr $self->{source}, $position, 64;
1455              $position += 64;
1456              $l += $r = length $_;
1457              $r++, $_ .= "\x80" if $r < 64 && !$p++;
1458              my @W = unpack 'V16', $_. "\0" x 7;
1459              $W[14] = $l * 8 if $r < 57;
1460              ($a, $b, $c, $d) = @A;
1461  
1462              for (0 .. 63) {
1463                  no warnings;
1464                  $a = _m($b + _l(
1465                      $A[4 + 4 * ($_ >> 4) + $_ % 4],
1466                      _m(&{(
1467                          sub { $b & $c | $d & ~ $b },
1468                          sub { $b & $d | $c & ~ $d },
1469                          sub { $b ^ $c ^ $d },
1470                          sub { $c ^ ($b | ~ $d) }
1471                      )[$z = $_ / 16]}
1472                             + $W[($A[20 + $z] + $A[24 + $z] * ($_ % 16)) % 16] + $K[$_] + $a)
1473                  ));
1474                  ($a, $b, $c, $d) = ($d, $a, $b, $c)
1475              }
1476  
1477              my $i = $A[0];
1478              $A[0] = _m($A[0] + $a);
1479              $A[1] = _m($A[1] + $b);
1480              $A[2] = _m($A[2] + $c);
1481              $A[3] = _m($A[3] + $d);
1482  
1483          } while $r > 56;
1484  
1485          ($x, $n, $m, $l, $r, $z) = ();
1486          $self->{source} = '';
1487  
1488          return unpack 'H32', pack 'V4', @A;
1489      }
1490  
1491      sub _l { ($x = pop @_) << ($n = pop) | 2 ** $n - 1 & $x >> 32 - $n }
1492      sub _m { ($x = pop @_) - ($m = 1 + ~ 0) * int($x / $m) }
1493  }
1494  
1495  
1496  1;
1497  __END__
1498  
1499  =head1 DESCRIPTION
1500  
1501  DBD::PgPP is a pure-Perl client interface for the PostgreSQL database.  This
1502  module implements the network protocol that allows a client to communicate
1503  with a PostgreSQL server, so you don't need an external PostgreSQL client
1504  library like B<libpq> for it to work.  That means this module enables you to
1505  connect to PostgreSQL server from platforms where there's no PostgreSQL
1506  port, or where installing PostgreSQL is prohibitively hard.
1507  
1508  =head1 MODULE DOCUMENTATION
1509  
1510  This documentation describes driver specific behavior and restrictions; it
1511  does not attempt to describe everything you might need to use DBD::PgPP.  In
1512  particular, users are advised to be familiar with the DBI documentation.
1513  
1514  =head1 THE DBI CLASS
1515  
1516  =head2 DBI Class Methods
1517  
1518  =over 4
1519  
1520  =item B<connect>
1521  
1522  At a minimum, you need to use code like this to connect to the database:
1523  
1524    $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', '');
1525  
1526  This connects to the database $dbname on localhost without any user
1527  authentication.  This may well be sufficient for some PostgreSQL
1528  installations.
1529  
1530  The following connect statement shows all possible parameters:
1531  
1532    $dbh = DBI->connect("dbi:PgPP:dbname=$dbname", $username, $password);
1533  
1534    $dbh = DBI->connect("dbi:PgPP:dbname=$dbname;host=$host;port=$port",
1535                        $username, $password);
1536  
1537    $dbh = DBI->connect("dbi:PgPP:dbname=$dbname;path=$path;port=$port",
1538                        $username, $password);
1539  
1540        parameter | hard coded default
1541        ----------+-------------------
1542        dbname    | current userid
1543        host      | localhost
1544        port      | 5432
1545        path      | /tmp
1546        debug     | undef
1547  
1548  If a host is specified, the postmaster on this host needs to be started with
1549  the C<-i> option (TCP/IP socket).
1550  
1551  For authentication with username and password appropriate entries have to be
1552  made in pg_hba.conf.  Please refer to the PostgreSQL documentation for
1553  pg_hba.conf and pg_passwd for the various types of authentication.
1554  
1555  =back
1556  
1557  =head1 DATABASE-HANDLE METHODS
1558  
1559  =over 4
1560  
1561  =item C<last_insert_id>
1562  
1563      $rv = $dbh->last_insert_id($catalog, $schema, $table, $field);
1564      $rv = $dbh->last_insert_id($catalog, $schema, $table, $field, \%attr);
1565  
1566  Attempts to return the id of the last value to be inserted into a table.
1567  Since PostgreSQL uses the C<sequence> type to implement such things, this
1568  method finds a sequence's value using the C<CURRVAL()> PostgreSQL function.
1569  This will fail if the sequence has not yet been used in the current database
1570  connection.
1571  
1572  DBD::PgPP ignores the $catalog and $field arguments are ignored in all
1573  cases, but they're required by DBI itself.
1574  
1575  If you don't know the name of the applicable sequence for the table, you can
1576  simply provide a table name (optionally qualified by a schema name), and
1577  DBD::PgPP will attempt to work out which sequence will contain the correct
1578  value:
1579  
1580      $dbh->do(q{CREATE TABLE t (id serial primary key, s text not null)});
1581      my $sth = $dbh->prepare('INSERT INTO t (s) VALUES (?)');
1582      for my $value (@values) {
1583          $sth->execute($value);
1584          my $id = $dbh->last_insert_id(undef, undef, 't', undef);
1585          print "Inserted $id: $value\n";
1586      }
1587  
1588  In most situations, that is the simplest approach.  However, it requires the
1589  table to have at least one column which is non-null and unique, and uses a
1590  sequence as its default value.  (If there is more than one such column, the
1591  primary key is used.)
1592  
1593  If those requirements aren't met in your situation, you can alternatively
1594  specify the sequence name directly:
1595  
1596      $dbh->do(q{CREATE SEQUENCE t_id_seq START 1});
1597      $dbh->do(q{CREATE TABLE t (
1598        id int not null unique DEFAULT nextval('t_id_seq'),
1599        s text not null)});
1600      my $sth = $dbh->prepare('INSERT INTO t (s) VALUES (?)');
1601      for my $value (@values) {
1602          $sth->execute($value);
1603          my $id = $dbh->last_insert_id(undef, undef, undef, undef, {
1604              sequence => 't_id_seq',
1605          });
1606          print "Inserted $id: $value\n";
1607      }
1608  
1609  If you adopt the simpler approach, note that DBD::PgPP will have to issue
1610  some queries to look things up in the system tables.  DBD::PgPP will then
1611  cache the appropriate sequence name for subsequent calls.  Should you need
1612  to disable this caching for some reason, you can supply a true value for the
1613  attribute C<pgpp_cache>:
1614  
1615      my $id = $dbh->last_insert_id(undef, undef, $table, undef, {
1616          pgpp_cache => 0,
1617      });
1618  
1619  Please keep in mind that C<last_insert_id> is far from foolproof, so make
1620  your program uses it carefully. Specifically, C<last_insert_id> should be
1621  used only immediately after an insert to the table in question, and that
1622  insert must not specify a value for the applicable column.
1623  
1624  =back
1625  
1626  =head1 OTHER FUNCTIONS
1627  
1628  As of DBD::PgPP 0.06, you can use the following functions to determine the
1629  version of the server to which a database handle is connected.  Note the
1630  unusual calling convention; it may be changed in the future.
1631  
1632  =over 4
1633  
1634  =item C<DBD::PgPP::pgpp_server_identification($dbh)>
1635  
1636  The server's version identification string, as returned by the standard
1637  C<version()> function available in PostgreSQL 7.2 and above.  If the server
1638  doesn't support that function, returns an empty string.
1639  
1640  =item C<DBD::PgPP::pgpp_server_version($dbh)>
1641  
1642  The server's version string, as parsed out of the return value of the
1643  standard C<version()> function available in PostgreSQL 7.2 and above.  For
1644  example, returns the string C<8.3.5> if the server is release 8.3.5.  If the
1645  server doesn't support C<version()>, returns the string C<0.0.0>.
1646  
1647  =item C<DBD::PgPP::pgpp_server_version_num($dbh)>
1648  
1649  A number representing the server's version number, as parsed out of the
1650  return value of the standard C<version()> function available in PostgreSQL
1651  7.2 and above.  For example, returns 80305 if the server is release 8.3.5.
1652  If the server doesn't support C<version()>, returns zero.
1653  
1654  =back
1655  
1656  =head1 BUGS, LIMITATIONS, AND TODO
1657  
1658  =over 4
1659  
1660  =item *
1661  
1662  The C<debug> DSN parameter is incorrectly global: if you enable it for one
1663  database handle, it gets enabled for all database handles in the current
1664  Perl interpreter.  It should probably be removed entirely in favour of DBI's
1665  built-in and powerful tracing mechanism, but that's too hard to do in the
1666  current architecture.
1667  
1668  =item *
1669  
1670  No support for Kerberos or SCM Credential authentication; and there's no
1671  support for crypt authentication on some platforms.
1672  
1673  =item *
1674  
1675  Can't use SSL for encrypted connections.
1676  
1677  =item *
1678  
1679  Using multiple semicolon-separated queries in a single statement will cause
1680  DBD::PgPP to fail in a way that requires you to reconnect to the server.
1681  
1682  =item *
1683  
1684  No support for COPY, or LISTEN notifications, or for cancelling in-progress
1685  queries.  (There's also no support for the "explicit function call" part of
1686  the protocol, but there's nothing you can do that way that isn't more easily
1687  achieved by writing SQL to call the function.)
1688  
1689  =item *
1690  
1691  There's currently no way to get informed about any warnings PostgreSQL may
1692  issue for your queries.
1693  
1694  =item *
1695  
1696  No support for BLOB data types or long objects.
1697  
1698  =item *
1699  
1700  Currently assumes that the Perl code and the database use the same encoding
1701  for text; probably also assumes that the encoding uses eight bits per
1702  character.  Future versions are expected to support UTF-8-encoded Unicode
1703  (in a way that's compatible with Perl's own string encodings).
1704  
1705  =item *
1706  
1707  You can't use any data type that (like bytea) requires C<< $dbh->quote >> to
1708  use any syntax other than standard string literals.  Using booleans and
1709  numbers works to the extent that PostgreSQL supports string-ish syntax for
1710  them, but that varies from one version to another.  The only reliable way to
1711  solve this and still support PostgreSQL 7.3 and below is to use the DBI
1712  C<bind_param> mechanism and say which type you want; but typed bind_param
1713  ignores the type at the moment.
1714  
1715  =back
1716  
1717  =head1 DEPENDENCIES
1718  
1719  This module requires these other modules and libraries:
1720  
1721  L<DBI>, L<IO::Socket>
1722  
1723  =head1 SEE ALSO
1724  
1725  L<DBI>, L<DBD::Pg>,
1726  L<http://developer.postgresql.org/docs/postgres/protocol.html>
1727  
1728  =head1 AUTHOR
1729  
1730  Hiroyuki OYAMA E<lt>oyama@module.jpE<gt>
1731  
1732  =head1 COPYRIGHT AND LICENCE
1733  
1734  Copyright (C) 2004 Hiroyuki OYAMA.  All rights reserved.
1735  Copyright (C) 2004, 2005, 2009 Aaron Crane.  All rights reserved.
1736  
1737  DBD::PgPP is free software; you can redistribute it and/or modify it under
1738  the terms of Perl itself, that is to say, under the terms of either:
1739  
1740  =over 4
1741  
1742  =item *
1743  
1744  The GNU General Public License as published by the Free Software Foundation;
1745  either version 2, or (at your option) any later version, or
1746  
1747  =item *
1748  
1749  The "Artistic License" which comes with Perl.
1750  
1751  =back
1752  
1753  =cut


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