[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |