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