home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / PgPP.pm < prev    next >
Encoding:
Perl POD Document  |  2002-07-26  |  35.8 KB  |  1,789 lines
  1.  
  2. =head1 NAME
  3.  
  4. DBD::PgPP - Pure Perl PostgreSQL driver for the DBI
  5.  
  6. =head1 SYNOPSIS
  7.  
  8.   use DBI;
  9.  
  10.   my $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', ''');
  11.  
  12.   # See the DBI module documentation for full details
  13.  
  14. =cut
  15.  
  16. package DBD::PgPP;
  17. use strict;
  18.  
  19. use DBI;
  20. use Carp;
  21. use vars qw($VERSION $err $errstr $state $drh);
  22.  
  23. $VERSION = '0.04';
  24. $err = 0;
  25. $errstr = '';
  26. $state = undef;
  27. $drh = undef;
  28.  
  29. sub driver
  30. {
  31.     return $drh if $drh;
  32.  
  33.     my $class = shift;
  34.     my $attr  = shift;
  35.     $class .= '::dr';
  36.  
  37.     $drh = DBI::_new_drh($class, {
  38.         Name        => 'PgPP',
  39.         Version     => $VERSION,
  40.         Err         => \$DBD::PgPP::err,
  41.         Errstr      => \$DBD::PgPP::errstr,
  42.         State       => \$DBD::PgPP::state,
  43.         Attribution => 'DBD::PgPP by Hiroyuki OYAMA',
  44.     }, {});
  45. }
  46.  
  47.  
  48. sub _parse_dsn
  49. {
  50.     my $class = shift;
  51.     my ($dsn, $args) = @_;
  52.     my($hash, $var, $val);
  53.     return if ! defined $dsn;
  54.  
  55.     while (length $dsn) {
  56.         if ($dsn =~ /([^:;]*)[:;](.*)/) {
  57.             $val = $1;
  58.             $dsn = $2;
  59.         }
  60.         else {
  61.             $val = $dsn;
  62.             $dsn = '';
  63.         }
  64.         if ($val =~ /([^=]*)=(.*)/) {
  65.             $var = $1;
  66.             $val = $2;
  67.             if ($var eq 'hostname' || $var eq 'host') {
  68.                 $hash->{'host'} = $val;
  69.             }
  70.             elsif ($var eq 'db' || $var eq 'dbname') {
  71.                 $hash->{'database'} = $val;
  72.             }
  73.             else {
  74.                 $hash->{$var} = $val;
  75.             }
  76.         }
  77.         else {
  78.             for $var (@$args) {
  79.                 if (!defined($hash->{$var})) {
  80.                     $hash->{$var} = $val;
  81.                     last;
  82.                 }
  83.             }
  84.         }
  85.     }
  86.     return $hash;
  87. }
  88.  
  89.  
  90. sub _parse_dsn_host
  91. {
  92.     my($class, $dsn) = @_;
  93.     my $hash = $class->_parse_dsn($dsn, ['host', 'port']);
  94.     ($hash->{'host'}, $hash->{'port'});
  95. }
  96.  
  97.  
  98.  
  99. package DBD::PgPP::dr;
  100.  
  101. $DBD::PgPP::dr::imp_data_size = 0;
  102.  
  103. use strict;
  104.  
  105.  
  106. sub connect
  107. {
  108.     my $drh = shift;
  109.     my ($dsn, $user, $password, $attrhash) = @_;
  110.  
  111.     my $data_source_info = DBD::PgPP->_parse_dsn(
  112.         $dsn, ['database', 'host', 'port'],
  113.     );
  114.     $user     ||= '';
  115.     $password ||= '';
  116.  
  117.  
  118.     my $dbh = DBI::_new_dbh($drh, {
  119.         Name         => $dsn,
  120.         USER         => $user,
  121.         CURRENT_USRE => $user,
  122.     }, {});
  123.     eval {
  124.         my $pgsql = DBD::PgPP::Protocol->new(
  125.             hostname => $data_source_info->{host},
  126.             port     => $data_source_info->{port},
  127.             database => $data_source_info->{database},
  128.             user     => $user,
  129.             password => $password,
  130.             debug    => $data_source_info->{debug},
  131.         );
  132.         $dbh->STORE(pgpp_connection => $pgsql);
  133. #        $dbh->STORE(thread_id => $mysql->{server_thread_id});
  134.  
  135.         if (! $attrhash->{AutoCommit}) {
  136.             my $pgsth = $pgsql->prepare('BEGIN');
  137.             $pgsth->execute();
  138.         }
  139.     };
  140.     if ($@) {
  141.         $dbh->DBI::set_err(1, $@);
  142.         return undef;
  143.     }
  144.     return $dbh;
  145. }
  146.  
  147.  
  148. sub data_sources
  149. {
  150.     return ("dbi:PgPP:");
  151. }
  152.  
  153.  
  154. sub disconnect_all {}
  155.  
  156.  
  157.  
  158. package DBD::PgPP::db;
  159.  
  160. $DBD::PgPP::db::imp_data_size = 0;
  161. use strict;
  162.  
  163.  
  164. sub prepare
  165. {
  166.     my $dbh = shift;
  167.     my ($statement, @attribs) = @_;
  168.  
  169.     my $sth = DBI::_new_sth($dbh, {
  170.         Statement => $statement,
  171.     });
  172.     $sth->STORE(pgpp_handle => $dbh->FETCH('pgpp_connection'));
  173.     $sth->STORE(pgpp_params => []);
  174.     $sth->STORE(NUM_OF_PARAMS => ($statement =~ tr/?//));
  175.     $sth;
  176. }
  177.  
  178.  
  179. sub commit
  180. {
  181.     my $dbh = shift;
  182.     my $pgsql = $dbh->FETCH('pgpp_connection');
  183.     eval {
  184.         my $pgsth = $pgsql->prepare('COMMIT');
  185.         $pgsth->execute();
  186.     };
  187.     if ($@) {
  188.         $dbh->DBI::set_err(
  189.             1, $@ #$pgsql->get_error_message
  190.         );
  191.         return undef;
  192.     }
  193.     return 1;
  194. }
  195.  
  196.  
  197. sub rollback
  198. {
  199.     my $dbh = shift;
  200.     my $pgsql = $dbh->FETCH('pgpp_connection');
  201.     eval {
  202.         my $pgsth = $pgsql->prepare('ROLLBACK');
  203.         $pgsth->execute();
  204.     };
  205.     if ($@) {
  206.         $dbh->DBI::set_err(
  207.             1, $@ #$pgsql->get_error_message
  208.         );
  209.         return undef;
  210.     }
  211.     return 1;
  212. }
  213.  
  214.  
  215.  
  216. sub disconnect
  217. {
  218.     return 1;
  219. }
  220.  
  221.  
  222. sub FETCH
  223. {
  224.     my $dbh = shift;
  225.     my $key = shift;
  226.  
  227.     return $dbh->{$key} if $key =~ /^(?:pgpp_.*)$/;
  228.     return $dbh->{AutoCommit} if $key =~ /^AutoCommit$/;
  229.  
  230.     return $dbh->SUPER::FETCH($key);
  231. }
  232.  
  233.  
  234. sub STORE
  235. {
  236.     my $dbh = shift;
  237.     my ($key, $value) = @_;
  238.  
  239.     if ($key =~ /^(?:pgpp_.*|AutoCommit)$/) {
  240.         $dbh->{$key} = $value;
  241.         return 1;
  242.     }
  243.     return $dbh->SUPER::STORE($key, $value);
  244. }
  245.  
  246.  
  247. sub DESTROY
  248. {
  249.     my $dbh = shift;
  250.     my $pgsql = $dbh->FETCH('pgpp_connection');
  251.     $pgsql->close if defined $pgsql;
  252. }
  253.  
  254.  
  255. package DBD::PgPP::st;
  256.  
  257. $DBD::PgPP::st::imp_data_size = 0;
  258. use strict;
  259.  
  260.  
  261. sub bind_param
  262. {
  263.     my $sth = shift;
  264.     my ($index, $value, $attr) = @_;
  265.     my $type = (ref $attr) ? $attr->{TYPE} : $attr;
  266.     if ($type) {
  267.         my $dbh = $sth->{Database};
  268.         $value = $dbh->quote($sth, $type);
  269.     }
  270.     my $params = $sth->FETCH('pgpp_param');
  271.     $params->[$index - 1] = $value;
  272. }
  273.  
  274.  
  275. sub execute
  276. {
  277.     my $sth = shift;
  278.     my @bind_values = @_;
  279.     my $params = (@bind_values) ?
  280.         \@bind_values : $sth->FETCH('pgpp_params');
  281.     my $num_param = $sth->FETCH('NUM_OF_PARAMS');
  282.     if (@$params != $num_param) {
  283.         # ...
  284.     }
  285.     my $statement = $sth->{Statement};
  286.     for (my $i = 0; $i < $num_param; $i++) {
  287.         my $dbh = $sth->{Database};
  288.         my $quoted_param = $dbh->quote($params->[$i]);
  289.         $statement =~ s/\?/$quoted_param/e;
  290.     }
  291.     my $pgsql = $sth->FETCH('pgpp_handle');
  292.     my $result;
  293.     eval {
  294.         $sth->{pgpp_record_iterator} = undef;
  295.         my $pgsql_sth = $pgsql->prepare($statement);
  296.         $pgsql_sth->execute();
  297.         $sth->{pgpp_record_iterator} = $pgsql_sth;
  298.         my $dbh = $sth->{Database};
  299.  
  300.         if (defined $pgsql->{affected_rows}) {
  301.             $sth->{pgpp_rows} = $pgsql->{affected_rows};
  302.             $result = $pgsql->{affected_rows};
  303.         }
  304.         else {
  305.             $sth->{pgpp_rows} = 0;
  306.             $result = $pgsql->{affected_rows};
  307.         }
  308.         if ($pgsql->{row_description}) {
  309.             $sth->STORE(NUM_OF_FIELDS => scalar @{$pgsql->{row_description}});
  310.             $sth->STORE(NAME => [ map {$_->{name}} @{$pgsql->{row_description}} ]);
  311.         }
  312. #        $pgsql->get_affected_rows_length;
  313.     };
  314.     if ($@) {
  315.         $sth->DBI::set_err(1, $@);
  316.         return undef;
  317.     }
  318.  
  319.     return $pgsql->has_error
  320.         ? undef : $result
  321.             ? $result : '0E0';
  322. }
  323.  
  324.  
  325. sub fetch
  326. {
  327.     my $sth = shift;
  328.  
  329.     my $iterator = $sth->FETCH('pgpp_record_iterator');
  330.     my $row = $iterator->fetch();
  331.     return undef unless $row;
  332.  
  333.     if ($sth->FETCH('ChopBlanks')) {
  334.         map {s/\s+$//} @$row;
  335.     }
  336.     return $sth->_set_fbav($row);
  337. }
  338. *fetchrow_arrayref = \&fetch;
  339.  
  340.  
  341. sub rows
  342. {
  343.     my $sth = shift;
  344.     return defined $sth->{pgpp_rows}
  345.         ? $sth->{pgpp_rows}
  346.         : 0;
  347. }
  348.  
  349.  
  350. sub FETCH
  351. {
  352.     my $dbh = shift;
  353.     my $key = shift;
  354.  
  355. #    return $dbh->{AutoCommit} if $key eq 'AutoCommit';
  356.     return $dbh->{NAME} if $key eq 'NAME';
  357.     return $dbh->{$key} if $key =~ /^pgpp_/;
  358.     return $dbh->SUPER::FETCH($key);
  359. }
  360.  
  361.  
  362. sub STORE
  363. {
  364.     my $dbh = shift;
  365.     my ($key, $value) = @_;
  366.  
  367.     if ($key eq 'NAME') {
  368.         $dbh->{NAME} = $value;
  369.         return 1;
  370.     }
  371.     elsif ($key =~ /^pgpp_/) {
  372.         $dbh->{$key} = $value;
  373.         return 1;
  374.     }
  375.     return $dbh->SUPER::STORE($key, $value);
  376. }
  377.  
  378.  
  379. sub DESTROY
  380. {
  381.     my $dbh = shift;
  382.  
  383. }
  384.  
  385.  
  386. package DBD::PgPP::Protocol;
  387.  
  388. use 5.004;
  389. use IO::Socket;
  390. use Carp;
  391. use vars qw($VERSION $DEBUG);
  392. use strict;
  393. $VERSION = '0.04';
  394.  
  395. use constant DEFAULT_UNIX_SOCKET => '/tmp';
  396. use constant DEFAULT_PORT_NUMBER => 5432;
  397. use constant DEFAULT_TIMEOUT     => 60;
  398. use constant BUFFER_LENGTH       => 1500;
  399.  
  400. use constant AUTH_OK                 => 0;
  401. use constant AUTH_KERBEROS_V4        => 1;
  402. use constant AUTH_KERBEROS_V5        => 2;
  403. use constant AUTH_CLEARTEXT_PASSWORD => 3;
  404. use constant AUTH_CRYPT_PASSWORD     => 4;
  405. use constant AUTH_MD5_PASSWORD       => 5;
  406. use constant AUTH_SCM_CREDENTIAL     => 6;
  407.  
  408.  
  409. sub new {
  410.     my $class = shift;
  411.     my %args = @_;
  412.  
  413.     my $self = bless {
  414.         hostname    => $args{hostname},
  415.         path        => $args{path}     || DEFAULT_UNIX_SOCKET,
  416.         port        => $args{port}     || DEFAULT_PORT_NUMBER,
  417.         database    => $args{database} || $ENV{USER} || '',
  418.         user        => $args{user}     || $ENV{USER} || '',
  419.         password    => $args{password} || '',
  420.         args        => $args{args}     || '',
  421.         tty         => $args{tty}      || '',
  422.         timeout     => $args{timeout}  || DEFAULT_TIMEOUT,
  423.         'socket'    => undef,
  424.         backend_pid => '',
  425.         secret_key  => '',
  426.         selected_record => undef,
  427.         error_message => '',
  428.         affected_rows => undef,
  429.         last_oid      => undef,
  430.     }, $class;
  431.     $DEBUG = 1 if $args{debug};
  432.     $self->_initialize();
  433.     $self;
  434. }
  435.  
  436.  
  437. sub close {
  438.     my $self = shift;
  439.     my $socket = $self->{'socket'};
  440.     return unless $socket;
  441.     return unless fileno $socket;
  442.  
  443.     my $terminate_packet = 'X'. "\0";
  444.     _dump_packet($terminate_packet);
  445.     $socket->send($terminate_packet, 0);
  446.     $socket->close();
  447. }
  448.  
  449.  
  450. sub DESTROY {
  451.     my $self = shift;
  452.     $self->close if $self;
  453. }
  454.  
  455.  
  456. sub _initialize {
  457.     my $self = shift;
  458.     $self->_connect();
  459.     $self->_do_startup();
  460. }
  461.  
  462.  
  463. sub _connect {
  464.     my $self = shift;
  465.  
  466.     my $pgsql;
  467.     if ($self->{hostname}) {
  468.         $pgsql = IO::Socket::INET->new(
  469.             PeerAddr => $self->{hostname},
  470.             PeerPort => $self->{port},
  471.             Proto    => 'tcp',
  472.             Timeout  => $self->{timeout},
  473.         ) or croak "Couldn't connect to $self->{hostname}:$self->{port}/tcp: $@";
  474.     } else {
  475.         $self->{path} =~ s{/$}{};
  476.         my $path = sprintf '%s/.s.PGSQL.%d',
  477.             $self->{path}, $self->{port};
  478.         $pgsql = IO::Socket::UNIX->new(
  479.             Type => SOCK_STREAM,
  480.             Peer => $path,
  481.         ) or croak "Couldn't connect to $self->{path}/.s.PGSQL.$self->{port}: $@";    
  482.     }
  483.     $pgsql->autoflush(1);
  484.     $self->{'socket'} = $pgsql;
  485. }
  486.  
  487.  
  488. sub get_handle {
  489.     my $self = shift;
  490.     $self->{'socket'};
  491. }
  492.  
  493.  
  494. sub _do_startup {
  495.     my $self = shift;
  496.     my $server = $self->{'socket'};
  497.  
  498.     # create message body
  499.     my $packet = pack('nna64a32a64a64a64',
  500.         2,                 # Protocol major version - Int16bit
  501.         0,                 # Protocol minor version - Int16bit
  502.         $self->{database}, # Database naem          - LimString64
  503.         $self->{user},     # User name              - LimString32
  504.         $self->{args},     # Command line args      - LimString64
  505.         '',                # Unused                 - LimString64
  506.         $self->{tty}       # Debugging msg tty      - LimString64
  507.     );
  508.     # add packet length
  509.     $packet = pack('N', length($packet) + 4). $packet;
  510.     _dump_packet($packet);
  511.     $server->send($packet, 0);
  512.  
  513.     $self->_do_authentication();
  514. }
  515.  
  516.  
  517. sub _dump_packet {
  518.     return unless $DBD::PgPP::Protocol::DEBUG;
  519.     my $packet = shift;
  520.  
  521.     printf "%s()\n", (caller 1)[3];
  522.     while ($packet =~ m/(.{1,16})/g) {
  523.         my $chunk = $1;
  524.         print join ' ', map {sprintf '%02X', ord $_} split //, $chunk;
  525.         print '   ' x (16 - length $chunk);
  526.         print '  ';
  527.         print join '', map {
  528.             sprintf '%s', (/[\w\d\*\,\?\%\=\'\;\(\)\.-]/) ? $_ : '.'
  529.         } split //, $chunk;
  530.         print "\n";
  531.     }
  532. }
  533.  
  534.  
  535. sub get_stream {
  536.     my $self = shift;
  537.     return $self->{stream} if defined $self->{stream};
  538.     $self->{stream} = DBD::PgPP::PacketStream->new($self->{'socket'});
  539.     return $self->{stream};
  540. }
  541.  
  542.  
  543. sub _do_authentication {
  544.     my $self = shift;
  545.     my $stream = $self->get_stream();
  546.     while (1) {
  547.         my $packet = $stream->each();
  548.         printf "Recieve %s\n", ref($packet) if $DEBUG;
  549.         last if $packet->is_end_of_response;
  550.         croak $packet->get_message() if $packet->is_error;
  551.         $packet->compute($self);
  552.     }
  553. }
  554.  
  555.  
  556. sub prepare {
  557.     my $self = shift;
  558.     my $sql = shift;
  559.  
  560.     $self->{error_message} = '';
  561.     return DBD::PgPP::ProtocolStatement->new($self, $sql);
  562. }
  563.  
  564.  
  565. sub has_error {
  566.     my $self = shift;
  567.     return 1 if $self->{error_message};
  568. }
  569.  
  570.  
  571. sub get_error_message {
  572.     my $self = shift;
  573.     return $self->{error_message};
  574. }
  575.  
  576.  
  577.  
  578. package DBD::PgPP::ProtocolStatement;
  579. use strict;
  580. use Carp;
  581.  
  582. sub new {
  583.     my $class = shift;
  584.     my $pgsql = shift;
  585.     my $statement = shift;
  586.     bless {
  587.         postgres  => $pgsql,
  588.         statement => $statement,
  589.         stream    => undef,
  590.         finish    => undef,
  591.     }, $class;
  592. }
  593.  
  594.  
  595. sub execute {
  596.     my $self = shift;
  597.     my $pgsql = $self->{postgres};
  598.     my $handle = $pgsql->get_handle();
  599.  
  600.     my $query_packet = 'Q'. $self->{statement}. "\0";
  601.     DBD::PgPP::Protocol::_dump_packet($query_packet);
  602.     $handle->send($query_packet, 0);
  603.     $self->{finisy}        = undef;
  604.     $self->{affected_rows} = 0;
  605.     $self->{last_oid}      = undef;
  606.  
  607.     my $stream = $pgsql->get_stream();
  608.     my $packet = $stream->each();
  609.     printf "Recieve %s\n", ref($packet) if $DBD::PgPP::Protocol::DEBUG;
  610.     if ($packet->is_error()) {
  611.         $self->_to_end_of_response($stream);
  612.         die $packet->get_message();
  613.     }
  614.     elsif ($packet->is_end_of_response()) {
  615.         $self->{finish} = 1;
  616.         return;
  617.     }
  618.     if ($packet->is_empty) {
  619.         $self->{finish} = 1;
  620.         $self->_to_end_of_response($stream);
  621.         return;
  622.     }
  623.     if ($packet->is_cursor_response) {
  624.         $packet->compute($pgsql);
  625.         my $row_info = $stream->each();
  626.         if ($row_info->is_error()) {
  627.             $self->_to_end_of_response($stream);
  628.             croak $packet->get_message();
  629.         }
  630.         $row_info->compute($pgsql);
  631.         $self->{stream} = DBD::PgPP::ReadOnlyPacketStream->new($handle);
  632.         $self->{stream}->set_buffer($stream->get_buffer);
  633.         while (1) {
  634.             my $tmp_packet = $self->{stream}->each();
  635.             printf "-Recieve %s\n", ref($tmp_packet) if $DBD::PgPP::Protocol::DEBUG;
  636.             if ($tmp_packet->is_error()) {
  637.                 $self->_to_end_of_response($stream);
  638.                 croak $packet->get_message();
  639.             }
  640.             $tmp_packet->compute($pgsql);
  641.             last if $tmp_packet->is_end_of_response;
  642.         }
  643.         $self->{stream}->rewind();
  644.         $stream->set_buffer('');
  645.         return;
  646.     }
  647.     else {
  648.         $packet->compute($pgsql);
  649.         $self->{finish} = 1;
  650.         while (1) {
  651.             my $end = $stream->each();
  652.             printf "-Recieve %s\n", ref($end) if $DBD::PgPP::Protocol::DEBUG;
  653.             if ($end->is_error()) {
  654.                 $self->_to_end_of_response($stream);
  655.                 croak $end->get_message();
  656.             }
  657.             last if $end->is_end_of_response();
  658.         }
  659.         return;
  660.     }
  661. }
  662.  
  663.  
  664. sub _to_end_of_response {
  665.     my $self = shift;
  666.     my $stream = shift;
  667.  
  668.     while (1) {
  669.         my $packet = $stream->each();
  670.         $packet->compute($self);
  671.         last if $packet->is_end_of_response();
  672.     }
  673. }
  674.  
  675.  
  676. sub fetch
  677. {
  678.     my $self = shift;
  679.     my $pgsql = $self->{postgres};
  680.     my $stream = $self->{stream};
  681.  
  682.     return undef if $self->{finish};
  683.  
  684.     while (1) {
  685.         my $packet = $stream->each();
  686.         printf "%s\n", ref $packet if $DBD::PgPP::Protocol::DEBUG;
  687.         warn $packet->get_message() if $packet->is_error;
  688.         return undef if $packet->is_end_of_response;
  689.         $packet->compute($pgsql);
  690.         my $result =  $packet->get_result();
  691.         return $result if $result;
  692.     }
  693. }
  694.  
  695.  
  696.  
  697. package DBD::PgPP::PacketStream;
  698.  
  699. use Carp;
  700. use strict;
  701.  
  702. # Message Identifies
  703. use constant ASCII_ROW             => 'D';
  704. use constant AUTHENTICATION        => 'R';
  705. use constant BACKEND_KEY_DATA      => 'K';
  706. use constant BINARY_ROW            => 'B';
  707. use constant COMPLETED_RESPONSE    => 'C';
  708. use constant COPY_IN_RESPONSE      => 'G';
  709. use constant COPY_OUT_RESPONSE     => 'H';
  710. use constant CURSOR_RESPONSE       => 'P';
  711. use constant EMPTY_QUERY_RESPONSE  => 'I';
  712. use constant ERROR_RESPONSE        => 'E';
  713. use constant FUNCTION_RESPONSE     => 'V';
  714. use constant NOTICE_RESPONSE       => 'N';
  715. use constant NOTIFICATION_RESPONSE => 'A';
  716. use constant READY_FOR_QUERY       => 'Z';
  717. use constant ROW_DESCRIPTION       => 'T';
  718.  
  719. # Authentication Message Specifies
  720. use constant AUTHENTICATION_OK                 => 0;
  721. use constant AUTHENTICATION_KERBEROS_V4        => 1;
  722. use constant AUTHENTICATION_KERBEROS_V5        => 2;
  723. use constant AUTHENTICATION_CLEARTEXT_PASSWORD => 3;
  724. use constant AUTHENTICATION_CRYPT_PASSWORD     => 4;
  725. use constant AUTHENTICATION_MD5_PASSWORD       => 5;
  726. use constant AUTHENTICATION_SCM_CREDENTIAL     => 6;
  727.  
  728.  
  729. sub new {
  730.     my $class = shift;
  731.     my $handle = shift;
  732.     bless {
  733.         handle   => $handle,
  734.         buffer   => '',
  735.     }, $class;
  736. }
  737.  
  738.  
  739. sub set_buffer {
  740.     my $self = shift;
  741.     $self->{buffer} = shift;
  742. }
  743.  
  744.  
  745. sub get_buffer {
  746.     my $self = shift;
  747.     $self->{buffer};
  748. }
  749.  
  750.  
  751. sub each {
  752.     my $self = shift;
  753.     my $type = $self->_get_byte();
  754.  
  755.     if ($type eq ASCII_ROW) {
  756.         return $self->_each_ascii_row();
  757.     }
  758.     elsif ($type eq AUTHENTICATION) {
  759.         return $self->_each_authentication();
  760.     }
  761.     elsif ($type eq BACKEND_KEY_DATA) {
  762.         return $self->_each_backend_key_data();
  763.     }
  764.     elsif ($type eq BINARY_ROW) {
  765.         return $self->_each_binary_row();
  766.     }
  767.     elsif ($type eq COMPLETED_RESPONSE) {
  768.         return $self->_each_completed_response();
  769.     }
  770.     elsif ($type eq COPY_IN_RESPONSE) {
  771.         return $self->_each_copy_in_response();
  772.     }
  773.     elsif ($type eq COPY_OUT_RESPONSE) {
  774.         return $self->_each_copy_out_response();
  775.     }
  776.     elsif ($type eq CURSOR_RESPONSE) {
  777.         return $self->_each_cursor_response();
  778.     }
  779.     elsif ($type eq EMPTY_QUERY_RESPONSE) {
  780.         return $self->_each_empty_query_response();
  781.     }
  782.     elsif ($type eq ERROR_RESPONSE) {
  783.         return $self->_each_error_response();
  784.     }
  785.     elsif ($type eq FUNCTION_RESPONSE) {
  786.         return $self->_each_function_response();
  787.     }
  788.     elsif ($type eq NOTICE_RESPONSE) {
  789.         return $self->_each_notice_response();
  790.     }
  791.     elsif ($type eq NOTIFICATION_RESPONSE) {
  792.         return $self->_each_notification_response();
  793.     }
  794.     elsif ($type eq READY_FOR_QUERY) {
  795.         return $self->_each_ready_for_query();
  796.     }
  797.     elsif ($type eq ROW_DESCRIPTION) {
  798.         return $self->_each_row_description();
  799.     }
  800.     else {
  801.         croak "Unknown message type: '$type'";
  802.     }
  803. }
  804.  
  805.  
  806. sub _each_authentication {
  807.     my $self = shift;
  808.  
  809.     my $code = $self->_get_int32();
  810.     if ($code == AUTHENTICATION_OK) {
  811.         return DBD::PgPP::AuthenticationOk->new();
  812.     }
  813.     elsif ($code == AUTHENTICATION_KERBEROS_V4) {
  814.         return DBD::PgPP::AuthenticationKerberosV4->new();
  815.     }
  816.     elsif ($code == AUTHENTICATION_KERBEROS_V5) {
  817.         return DBD::PgPP::AuthenticationKerberosV5->new();
  818.     }
  819.     elsif ($code == AUTHENTICATION_CLEARTEXT_PASSWORD) {
  820.         return DBD::PgPP::AuthenticationCleartextPassword->new();
  821.     }
  822.     elsif ($code == AUTHENTICATION_CRYPT_PASSWORD) {
  823.         my $salt = $self->_get_byte(2);
  824.         return DBD::PgPP::AuthenticationCryptPassword->new($salt);
  825.     }
  826.     elsif ($code == AUTHENTICATION_MD5_PASSWORD) {
  827.         my $salt = $self->_get_byte(4);
  828.         return DBD::PgPP::AuthenticationMD5Password->new($salt);
  829.     }
  830.     elsif ($code == AUTHENTICATION_SCM_CREDENTIAL) {
  831.         return DBD::PgPP::AuthenticationSCMCredential->new();
  832.     }
  833.     else {
  834.         croak "Unknown authentication type: $code";
  835.     }
  836. }
  837.  
  838.  
  839. sub _each_backend_key_data {
  840.     my $self = shift;
  841.     my $process_id = $self->_get_int32();
  842.     my $secret_key = $self->_get_int32();
  843.     return DBD::PgPP::BackendKeyData->new($process_id, $secret_key);
  844. }
  845.  
  846.  
  847. sub _each_error_response {
  848.     my $self = shift;
  849.     my $error_message = $self->_get_c_string();
  850.     return DBD::PgPP::ErrorResponse->new($error_message);
  851. }
  852.  
  853.  
  854. sub _each_notice_response {
  855.     my $self = shift;
  856.     my $notice_message = $self->_get_c_string();
  857.     return DBD::PgPP::NoticeResponse->new($notice_message);
  858. }
  859.  
  860. sub _each_notification_response {
  861.     my $self = shift;
  862.     my $process_id = $self->_get_int32();
  863.     my $condition = $self->_get_c_string();
  864.     return DBD::PgPP::NotificationResponse->new($process_id, $condition);
  865. }
  866.  
  867.  
  868. sub _each_ready_for_query {
  869.     my $self = shift;
  870.     return DBD::PgPP::ReadyForQuery->new();
  871. }
  872.  
  873.  
  874. sub _each_cursor_response {
  875.     my $self = shift;
  876.     my $name = $self->_get_c_string();
  877.     return DBD::PgPP::CursorResponse->new($name);
  878. }
  879.  
  880.  
  881. sub _each_row_description {
  882.     my $self = shift;
  883.     my $row_number = $self->_get_int16();
  884.     my @description;
  885.     for my $i (1..$row_number) {
  886.         push @description, {
  887.             name     => $self->_get_c_string(),
  888.             type     => $self->_get_int32(),
  889.             size     => $self->_get_int16(),
  890.             modifier => $self->_get_int32(),
  891.         };
  892.     }
  893.     return DBD::PgPP::RowDescription->new(\@description);
  894. }
  895.  
  896.  
  897. sub _each_ascii_row {
  898.     my $self = shift;
  899.     return DBD::PgPP::AsciiRow->new($self);
  900. }
  901.  
  902.  
  903. sub _each_completed_response {
  904.     my $self = shift;
  905.     my $tag = $self->_get_c_string();
  906.     return DBD::PgPP::CompletedResponse->new($tag);
  907. }
  908.  
  909.  
  910. sub _each_empty_query_response {
  911.     my $self = shift;
  912.     my $unused = $self->_get_c_string();
  913.     return DBD::PgPP::EmptyQueryResponse->new($unused);
  914. }
  915.  
  916.  
  917. sub _get_byte {
  918.     my $self = shift;
  919.     my $length = shift || 1;
  920.  
  921.     $self->_if_short_then_add_buffer($length);
  922.     my $result = substr $self->{buffer}, 0, $length;
  923.     $self->{buffer} = substr $self->{buffer}, $length;
  924.     return $result;
  925. }
  926.  
  927.  
  928. sub _get_int32 {
  929.     my $self = shift;
  930.     $self->_if_short_then_add_buffer(4);
  931.     my $result = unpack 'N', substr $self->{buffer}, 0, 4;
  932.     $self->{buffer} = substr $self->{buffer}, 4;
  933.     return $result;
  934. }
  935.  
  936.  
  937. sub _get_int16 {
  938.     my $self = shift;
  939.     $self->_if_short_then_add_buffer(2);
  940.     my $result = unpack 'n', substr $self->{buffer}, 0, 2;
  941.     $self->{buffer} = substr $self->{buffer}, 2;
  942.     return $result;
  943. }
  944.  
  945.  
  946. sub _get_c_string {
  947.     my $self = shift;
  948.  
  949.     my $length = 0;
  950.     while (1) {
  951.         $length = index $self->{buffer}, "\0";
  952.         last if $length >= 0;
  953.         $self->_if_short_then_add_buffer(1);
  954.     }
  955.     my $result = substr $self->{buffer}, 0, $length;
  956.     $self->{buffer} = substr $self->{buffer}, $length + 1;
  957.     return $result;
  958. }
  959.  
  960.  
  961. sub _if_short_then_add_buffer {
  962.     my $self = shift;
  963.     my $length = shift || 0;
  964.     return if length($self->{buffer}) >= $length;
  965.  
  966.     my $handle = $self->{handle};
  967.     my $packet = '';
  968.     $handle->recv($packet, 1500, 0);
  969.     DBD::PgPP::Protocol::_dump_packet($packet);
  970.     $self->{buffer} .= $packet;
  971.     return length $packet;
  972. }
  973.  
  974.  
  975.  
  976. package DBD::PgPP::ReadOnlyPacketStream;
  977. use base 'DBD::PgPP::PacketStream';
  978. use strict;
  979. use Carp;
  980.  
  981. # Message Identifies
  982. use constant ASCII_ROW             => 'D';
  983. use constant AUTHENTICATION        => 'R';
  984. use constant BACKEND_KEY_DATA      => 'K';
  985. use constant BINARY_ROW            => 'B';
  986. use constant COMPLETED_RESPONSE    => 'C';
  987. use constant COPY_IN_RESPONSE      => 'G';
  988. use constant COPY_OUT_RESPONSE     => 'H';
  989. use constant CURSOR_RESPONSE       => 'P';
  990. use constant EMPTY_QUERY_RESPONSE  => 'I';
  991. use constant ERROR_RESPONSE        => 'E';
  992. use constant FUNCTION_RESPONSE     => 'V';
  993. use constant NOTICE_RESPONSE       => 'N';
  994. use constant NOTIFICATION_RESPONSE => 'A';
  995. use constant READY_FOR_QUERY       => 'Z';
  996. use constant ROW_DESCRIPTION       => 'T';
  997.  
  998. # Authentication Message Specifies
  999. use constant AUTHENTICATION_OK                 => 0;
  1000. use constant AUTHENTICATION_KERBEROS_V4        => 1;
  1001. use constant AUTHENTICATION_KERBEROS_V5        => 2;
  1002. use constant AUTHENTICATION_CLEARTEXT_PASSWORD => 3;
  1003. use constant AUTHENTICATION_CRYPT_PASSWORD     => 4;
  1004. use constant AUTHENTICATION_MD5_PASSWORD       => 5;
  1005. use constant AUTHENTICATION_SCM_CREDENTIAL     => 6;
  1006.  
  1007. sub new {
  1008.     my $class = shift;
  1009.     my $handle = shift;
  1010.     bless {
  1011.         handle   => $handle,
  1012.         buffer   => '',
  1013.         position => 0,
  1014.     }, $class;
  1015. }
  1016.  
  1017.  
  1018. sub rewind {
  1019.     my $self = shift;
  1020.     $self->{position} = 0;
  1021. }
  1022.  
  1023.  
  1024. sub _get_byte {
  1025.     my $self = shift;
  1026.     my $length = shift || 1;
  1027.  
  1028.     $self->_if_short_then_add_buffer($length);
  1029.     my $result = substr $self->{buffer}, $self->{position}, $length;
  1030.     $self->{position} += $length;
  1031.     return $result;
  1032. }
  1033.  
  1034.  
  1035. sub _get_int32 {
  1036.     my $self = shift;
  1037.     $self->_if_short_then_add_buffer(4);
  1038.     my $result = unpack 'N', substr $self->{buffer}, $self->{position}, 4;
  1039.     $self->{position} += 4;
  1040.     return $result;
  1041. }
  1042.  
  1043.  
  1044. sub _get_int16 {
  1045.     my $self = shift;
  1046.     $self->_if_short_then_add_buffer(2);
  1047.     my $result = unpack 'n', substr $self->{buffer}, $self->{position}, 2;
  1048.     $self->{buffer} += 2;
  1049.     return $result;
  1050. }
  1051.  
  1052.  
  1053. sub _get_c_string {
  1054.     my $self = shift;
  1055.     my $length = 0;
  1056.     while (1) {
  1057.         $length = index($self->{buffer}, "\0", $self->{position}) - $self->{position};
  1058.         last if $length >= 0;
  1059.         $self->_if_short_then_add_buffer(1);
  1060.     }
  1061.     my $result = substr $self->{buffer}, $self->{position}, $length;
  1062.     $self->{position} += $length + 1;
  1063.     return $result;
  1064. }
  1065.  
  1066.  
  1067. sub _if_short_then_add_buffer {
  1068.     my $self = shift;
  1069.     my $length = shift || 0;
  1070.  
  1071.     return if (length($self->{buffer}) - $self->{position}) >= $length;
  1072.  
  1073.     my $handle = $self->{handle};
  1074.     my $packet = '';
  1075.     $handle->recv($packet, 1500, 0);
  1076.     DBD::PgPP::Protocol::_dump_packet($packet);
  1077.     $self->{buffer} .= $packet;
  1078.     return length $packet;
  1079. }
  1080.  
  1081.  
  1082.  
  1083. package DBD::PgPP::Response;
  1084. use strict;
  1085.  
  1086. sub new {
  1087.     my $class = shift;
  1088.     bless {
  1089.     }, $class; 
  1090. }
  1091.  
  1092.  
  1093. sub compute {
  1094.     my $self = shift;
  1095.     my $postgres = shift;
  1096. }
  1097.  
  1098.  
  1099. sub is_empty { undef }
  1100. sub is_error { undef }
  1101. sub is_end_of_response { undef }
  1102. sub get_result { undef }
  1103. sub is_cursor_response { undef }
  1104.  
  1105.  
  1106. package DBD::PgPP::AuthenticationOk;
  1107. use base 'DBD::PgPP::Response';
  1108.  
  1109.  
  1110.  
  1111. package DBD::PgPP::AuthenticationKerberosV4;
  1112. use base 'DBD::PgPP::Response'; 
  1113. use Carp;
  1114. use strict;
  1115.  
  1116. sub compute {
  1117.     croak "authentication type 'Kerberos V4' not supported.\n"
  1118. }
  1119.  
  1120.  
  1121.  
  1122. package DBD::PgPP::AuthenticationKerberosV5;
  1123. use base 'DBD::PgPP::Response'; 
  1124. use Carp;
  1125. use strict;
  1126.  
  1127. sub compute {
  1128.     croak "authentication type 'Kerberos V5' not supported.\n"
  1129. }
  1130.  
  1131.  
  1132. package DBD::PgPP::AuthenticationCleartextPassword;
  1133. use base 'DBD::PgPP::Response'; 
  1134.  
  1135. sub compute {
  1136.     my $self = shift;
  1137.     my $pgsql = shift;
  1138.     my $handle = $pgsql->get_handle;
  1139.     my $password = $pgsql->{password};
  1140.  
  1141.     my $packet = pack('N', length($password) + 4 + 1). $password. "\0";
  1142.     DBD::PgPP::Protocol::_dump_packet($packet);
  1143.     $handle->send($packet, 0);
  1144. }
  1145.  
  1146.  
  1147. package DBD::PgPP::AuthenticationCryptPassword;
  1148. use base 'DBD::PgPP::Response'; 
  1149. use Carp;
  1150.  
  1151. sub new {
  1152.     my $class = shift;
  1153.     my $self = $class->SUPER::new();
  1154.     $self->{salt} = shift;    
  1155.     $self;
  1156. }
  1157.  
  1158.  
  1159. sub get_salt {
  1160.     my $self = shift;
  1161.     $self->{salt};
  1162. }
  1163.  
  1164.  
  1165. sub compute {
  1166.     my $self = shift;
  1167.     my $pgsql = shift;
  1168.     my $handle = $pgsql->get_handle();
  1169.     my $password = $pgsql->{password} || '';
  1170.  
  1171.     $password = _encode_crypt($password, $self->{salt});
  1172.     my $packet = pack('N', length($password) + 4 + 1). $password. "\0";
  1173.     DBD::PgPP::Protocol::_dump_packet($packet);
  1174.     $handle->send($packet, 0);
  1175. }
  1176.  
  1177.  
  1178. sub _encode_crypt
  1179. {
  1180.     my $password = shift;
  1181.     my $salt = shift;
  1182.  
  1183.     my $crypted = '';
  1184.     eval {
  1185.         $crypted = crypt($password, $salt);
  1186.         die "is MD5 crypt()" if _is_md5_crypt($crypted, $salt);
  1187.     };
  1188.     if ($@) {
  1189.         croak "authentication type 'crypt' not supported on your platform. please use  'trust' or 'md5' or 'ident' authentication";
  1190.     }
  1191.     return $crypted;
  1192. }
  1193.  
  1194.  
  1195. sub _is_md5_crypt {
  1196.     my $crypted = shift;
  1197.     my $salt = shift;
  1198.  
  1199.     $crypted =~ /^\$1\$$salt\$/;
  1200. }
  1201.  
  1202.  
  1203.  
  1204. package DBD::PgPP::AuthenticationMD5Password;
  1205. use base 'DBD::PgPP::AuthenticationCryptPassword';
  1206. use Carp;
  1207.  
  1208. sub new {
  1209.     my $class = shift;
  1210.     my $self = $class->SUPER::new();
  1211.     $self->{salt} = shift;
  1212.     $self;
  1213. }
  1214.  
  1215.  
  1216. sub compute {
  1217.     my $self = shift;
  1218.     my $pgsql = shift;
  1219.     my $handle = $pgsql->get_handle();
  1220.     my $password = $pgsql->{password} || '';
  1221.  
  1222.     my $encoded_password = _encode_md5(
  1223.         $pgsql->{user},
  1224.         $password, $self->{salt}
  1225.     );
  1226.     my $packet = pack('N', length($encoded_password) + 4 + 1). $encoded_password. "\0";
  1227.     DBD::PgPP::Protocol::_dump_packet($packet);
  1228.     $handle->send($packet, 0);
  1229. }
  1230.  
  1231.  
  1232. sub _encode_md5 {
  1233.     my $user = shift;
  1234.     my $password = shift;
  1235.     my $salt = shift;
  1236.  
  1237.     my $md5 = DBD::PgPP::EncodeMD5->create();
  1238.     $md5->add($password);
  1239.     $md5->add($user);
  1240.     my $tmp_digest = $md5->hexdigest;
  1241.     $md5->add($tmp_digest);
  1242.     $md5->add($salt);
  1243.     my $md5_digest = 'md5'. $md5->hexdigest;
  1244.  
  1245.     return $md5_digest;
  1246. }
  1247.  
  1248.  
  1249.  
  1250. package DBD::PgPP::AuthenticationSCMCredential;
  1251. use base 'DBD::PgPP::Response';
  1252. use Carp;
  1253.  
  1254. sub compute {
  1255.     croak "authentication type 'SCM Credential' not supported.\n"
  1256. }
  1257.  
  1258.  
  1259.  
  1260. package DBD::PgPP::BackendKeyData;
  1261. use base 'DBD::PgPP::Response';
  1262.  
  1263. sub new {
  1264.     my $class = shift;
  1265.     my $self = $class->SUPER::new();
  1266.     $self->{process_id} = shift;
  1267.     $self->{secret_key} = shift;
  1268.     $self;
  1269. }
  1270.  
  1271.  
  1272. sub get_process_id {
  1273.     my $self = shift;
  1274.     $self->{process_id};
  1275. }
  1276.  
  1277.  
  1278. sub get_secret_key {
  1279.     my $self = shift;
  1280.     $self->{secret_key};
  1281. }
  1282.  
  1283.  
  1284. sub compute {
  1285.     my $self = shift;
  1286.     my $postgres = shift;
  1287.  
  1288.     $postgres->{process_id} = $self->get_process_id;
  1289.     $postgres->{secret_key} = $self->get_secret_key;
  1290. }
  1291.  
  1292.  
  1293.  
  1294. package DBD::PgPP::ErrorResponse;
  1295. use base 'DBD::PgPP::Response';
  1296.  
  1297. sub new {
  1298.     my $class = shift;
  1299.     my $self = $class->SUPER::new();
  1300.     $self->{message} = shift;
  1301.     $self;
  1302. }
  1303.  
  1304.  
  1305. sub get_message {
  1306.     my $self = shift;
  1307.     $self->{message};
  1308. }
  1309.  
  1310.  
  1311. sub is_error { 1 }
  1312.  
  1313.  
  1314.  
  1315. package DBD::PgPP::NoticeResponse;
  1316. use base 'DBD::PgPP::ErrorResponse';
  1317.  
  1318. sub is_error { undef }
  1319.  
  1320.  
  1321.  
  1322. package DBD::PgPP::NotificationResponse;
  1323. use base 'DBD::PgPP::Response';
  1324.  
  1325. sub new {
  1326.     my $class = shift;
  1327.     my $self = $class->SUPER::new();
  1328.     $self->{process_id} = shift;
  1329.     $self->{condition} = shift;
  1330.     $self;
  1331. }
  1332.  
  1333.  
  1334. sub get_process_id {
  1335.     my $self = shift;
  1336.     $self->{process_id};
  1337. }
  1338.  
  1339.  
  1340. sub get_condition {
  1341.     my $self = shift;
  1342.     $self->{condition};
  1343. }
  1344.  
  1345.  
  1346.  
  1347. package DBD::PgPP::ReadyForQuery;
  1348. use base 'DBD::PgPP::Response';
  1349.  
  1350. sub is_end_of_response { 1 }
  1351.  
  1352.  
  1353.  
  1354. package DBD::PgPP::CursorResponse;
  1355. use base 'DBD::PgPP::Response';
  1356. use strict;
  1357.  
  1358. sub new {
  1359.     my $class = shift;
  1360.     my $self = $class->SUPER::new();
  1361.     $self->{name} = shift;
  1362.     $self;
  1363. }
  1364.  
  1365.  
  1366. sub get_name
  1367. {
  1368.     my $self = shift;
  1369.     $self->{name};
  1370. }
  1371.  
  1372.  
  1373. sub compute {
  1374.     my $self = shift;
  1375.     my $pgsql = shift;
  1376.  
  1377.     $pgsql->{cursor_name} = $self->get_name();
  1378. }
  1379.  
  1380.  
  1381. sub is_cursor_response { 1 }
  1382.  
  1383.  
  1384. package DBD::PgPP::RowDescription;
  1385. use base 'DBD::PgPP::Response';
  1386. use strict;
  1387.  
  1388. sub new {
  1389.     my $class = shift;
  1390.     my $self = $class->SUPER::new();
  1391.     $self->{row_description} = shift;
  1392.     $self;
  1393. }
  1394.  
  1395.  
  1396. sub compute
  1397. {
  1398.     my $self = shift;
  1399.     my $pgsql = shift;
  1400.  
  1401.     $pgsql->{row_description} = $self->{row_description};
  1402. }
  1403.  
  1404.  
  1405. sub is_cursor_response { 1 }
  1406.  
  1407.  
  1408.  
  1409. package DBD::PgPP::AsciiRow;
  1410. use base 'DBD::PgPP::Response';
  1411. use strict;
  1412.  
  1413. sub new {
  1414.     my $class = shift;
  1415.     my $self = $class->SUPER::new();
  1416.     $self->{stream} = shift;
  1417.     $self;
  1418. }
  1419.  
  1420.  
  1421. sub compute
  1422. {
  1423.     my $self = shift;
  1424.     my $pgsql = shift;
  1425.     my $stream = $self->{stream};
  1426.  
  1427.     my $fields_length = scalar @{$pgsql->{row_description}};
  1428.  
  1429.     my $bitmap_length = $self->_get_length_of_null_bitmap($fields_length);
  1430.     my $bitmap = unpack 'C*', $stream->_get_byte($bitmap_length);
  1431.     my @result;
  1432.     my $shift = 1;
  1433.     for my $i (1..$fields_length) {
  1434.         if ($self->_is_not_null($bitmap, $bitmap_length, $i)) {
  1435.             my $length = $stream->_get_int32();
  1436.             my $value = $stream->_get_byte($length - 4);
  1437.             push @result, $value;
  1438.             next;
  1439.         }
  1440.         push @result, undef;
  1441.         next;
  1442.     }
  1443.     $self->{result} = \@result;
  1444. }
  1445.  
  1446.  
  1447. sub _get_length_of_null_bitmap {
  1448.     my $self = shift;
  1449.     my $number = shift;
  1450.     use integer;
  1451.     my $length = $number / 8;
  1452.     ++$length if $number % 8;
  1453.     return $length;
  1454. }
  1455.  
  1456.  
  1457. sub _is_not_null {
  1458.     my $self = shift;
  1459.     my $bitmap = shift || 0;
  1460.     my $length = shift || 0;
  1461.     my $index = shift || 0;
  1462.  
  1463.     ($bitmap >> (($length * 8) - $index)) & 0x01;
  1464. }
  1465.  
  1466.  
  1467. sub get_result
  1468. {
  1469.     my $self = shift;
  1470.     $self->{result};
  1471. }
  1472.  
  1473.  
  1474. sub is_cursor_response { 1 }
  1475.  
  1476.  
  1477.  
  1478. package DBD::PgPP::CompletedResponse;
  1479. use base 'DBD::PgPP::Response';
  1480. use strict;
  1481. use Carp;
  1482.  
  1483. sub new
  1484. {
  1485.     my $class = shift;
  1486.     my $self = $class->SUPER::new();
  1487.     $self->{tag} = shift;
  1488.     $self;
  1489. }
  1490.  
  1491.  
  1492. sub get_tag {
  1493.     my $self = shift;
  1494.     $self->{tag};
  1495. }
  1496.  
  1497.  
  1498. sub compute
  1499. {
  1500.     my $self = shift;
  1501.     my $pgsql = shift;
  1502.     my $tag = $self->{tag};
  1503.  
  1504.     if ($tag =~ /^INSERT (\d+) (\d+)/) {
  1505.         $pgsql->{affected_oid}  = $1;
  1506.         $pgsql->{affected_rows} = $2;
  1507.     }
  1508.     elsif ($tag =~ /^DELETE (\d+)/) {
  1509.         $pgsql->{affected_rows} = $1;
  1510.     }
  1511.     elsif ($tag =~ /^UPDATE (\d+)/) {
  1512.         $pgsql->{affected_rows} = $1;
  1513.     }
  1514. }
  1515.  
  1516.  
  1517.  
  1518. package DBD::PgPP::EmptyQueryResponse;
  1519. use base 'DBD::PgPP::Response';
  1520. use strict;
  1521.  
  1522. sub is_empty { 1 }
  1523.  
  1524.  
  1525.  
  1526. package DBD::PgPP::EncodeMD5;
  1527.  
  1528. =pod
  1529.  
  1530. =begin wish
  1531.  
  1532. Please do not question closely about this source code ;-)
  1533.  
  1534. =end wish
  1535.  
  1536. =cut
  1537.  
  1538. use strict;
  1539. use vars qw($a $b $c $d);
  1540. my ($x, $n, $m, $l, $r, $z);
  1541.  
  1542.  
  1543. sub create {
  1544.     my $class = shift;
  1545.     my $md5;
  1546.  
  1547.     eval {
  1548.         require Digest::MD5;
  1549.         $md5 = Digest::MD5->new;
  1550.     };
  1551.     if ($@) {
  1552.         $md5 = $class->new();
  1553.     }
  1554.     return $md5;
  1555. }
  1556.  
  1557.  
  1558. sub new {
  1559.     my $class = shift;
  1560.     bless {
  1561.         source => '',
  1562.     }, $class;
  1563. }
  1564.  
  1565.  
  1566. sub add {
  1567.     my $self = shift;
  1568.     $self->{source} .= join '', @_;
  1569. }
  1570.  
  1571.  
  1572.  
  1573. sub hexdigest {
  1574.     my $self = shift;
  1575.  
  1576.     my @A = unpack(
  1577.         'N4C24',
  1578.         unpack 'u', 'H9T4C`>_-JXF8NMS^$#)4=@<,$18%"0X4!`L0%P8*#Q4``04``04#!P``'
  1579.     );
  1580.     my @K = map { int abs 2 ** 32 * sin $_ } 1..64;
  1581.     my ($p);
  1582.  
  1583.  
  1584.     my $position = 0;
  1585.     do {
  1586.         $_ = substr $self->{source}, $position, 64;
  1587.         $position += 64;
  1588.         $l += $r = length $_;
  1589.         $r++, $_ .= "\x80" if $r < 64 && !$p++;
  1590.         my @W = unpack 'V16', $_. "\0" x 7;
  1591.         $W[14] = $l * 8 if $r < 57;
  1592.         ($a, $b, $c, $d) = @A;
  1593.  
  1594.         for (0..63) {
  1595.             #no warnings;
  1596.             local($^W) = 0;
  1597.             $a = _m($b + 
  1598.                 _l($A[4 + 4 * ($_ >> 4) + $_ % 4],
  1599.                     _m(&{(
  1600.                         sub {
  1601.                             $b & $c | $d & ~ $b;
  1602.                         },
  1603.                         sub {
  1604.                             $b & $d | $c & ~ $d;
  1605.                         },
  1606.                         sub {
  1607.                             $b ^ $c ^ $d;
  1608.                         },
  1609.                         sub {
  1610.                             $c ^ ($b | ~ $d);
  1611.                         }
  1612.                         )[$z = $_ / 16]}
  1613.                     + $W[($A[20 + $z] + $A[24 + $z] * ($_ % 16)) % 16] + $K[$_] + $a)
  1614.                 )
  1615.             );
  1616.             ($a, $b, $c, $d) = ($d, $a, $b, $c)
  1617.         }
  1618.  
  1619.         my $i = $A[0];
  1620.         $A[0] = _m($A[0] + $a);
  1621.         $A[1] = _m($A[1] + $b);
  1622.         $A[2] = _m($A[2] + $c);
  1623.         $A[3] = _m($A[3] + $d);
  1624.  
  1625.     } while ($r > 56);
  1626.  
  1627.     ($x, $n, $m, $l, $r, $z) = ();
  1628.     $self->{source} = '';
  1629.  
  1630.     return unpack 'H32', pack 'V4', @A;
  1631. }
  1632.  
  1633.  
  1634. sub _l {
  1635.     ($x = pop @_) << ($n=pop) | 2 ** $n - 1 & $x >> 32 - $n;
  1636. }
  1637.  
  1638. sub _m {
  1639.     ($x = pop @_) - ($m = 1 + ~ 0) * int($x / $m);
  1640. }
  1641.  
  1642.  
  1643. 1;
  1644. __END__
  1645.  
  1646.  
  1647. =head1 DESCRIPTION
  1648.  
  1649. DBD::PgPP is a Pure Perl client interface for the PostgreSQL database. This module implements network protocol between server and client of PostgreSQL, thus you don't need external PostgreSQL client library like B<libpq> for this module to work. It means this module enables you to connect to PostgreSQL server from some operation systems which PostgreSQL is not ported. How nifty!
  1650.  
  1651.  
  1652. =head1 MODULE DOCUMENTATION
  1653.  
  1654. This documentation describes driver specific behavior and restrictions. It is not supposed to be used as the only refference of the user. In any case consult the DBI documentation first !
  1655.  
  1656. =head1 THE DBI CLASS
  1657.  
  1658. =head2 DBI Class Methods
  1659.  
  1660. =over 4
  1661.  
  1662. =item B<connect>
  1663.  
  1664. To connecto to a database with a minimum of parameters, use the following syntax:
  1665.   $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', '');
  1666.  
  1667. This connects to the database $dbname at localhost without any user authentication. This is sufficient for the defaults of PostgreSQL.
  1668.  
  1669. The following connect statement shows all possible parameters:
  1670.  
  1671.   $dbh = DBI->connect(
  1672.       "dbi:PgPP:dbname=$dbname",
  1673.       $username, $password
  1674.   );
  1675.  
  1676.   $dbh = DBI->connect(
  1677.       "dbi:PgPP:dbname=$dbname;host=$host;port=$port",
  1678.       $username, $password
  1679.   );
  1680.  
  1681.   $dbh = DBI->connect(
  1682.       "dbi:PgPP:dbname=$dbname;path=$path;port=$port",
  1683.       $username, $password
  1684.   );
  1685.  
  1686.       parameter | hard coded default
  1687.       ----------+-------------------
  1688.       dbname    | current userid
  1689.       host      | localhost
  1690.       port      | 5432
  1691.       path      | /tmp
  1692.       debug     | undef
  1693.  
  1694. If a host is specified, the postmaster on this host needs to be started with the C<-i> option (TCP/IP socket).
  1695.  
  1696.  
  1697. For authentication with username and password appropriate entries have to be made in pg_hba.conf. Please refer to the L<pg_hba.conf> and the L<pg_passwd> for the different types of authentication.
  1698.  
  1699. =back
  1700.  
  1701. =head1 SUPPORT OPERATING SYSTEM
  1702.  
  1703. This module has been tested on these OSes.
  1704.  
  1705. =over 4
  1706.  
  1707. =item * Mac OS 9
  1708.  
  1709. with MacPerl5.6.1r1 built for PowerPC
  1710.  
  1711. =item * Mac OS X
  1712.  
  1713. with perl v5.6.0 built for darwin
  1714.  
  1715. =item * Windows2000
  1716.  
  1717. with ActivePerl5.6.1 build631.
  1718.  
  1719. =item * FreeBSD 4.6
  1720.  
  1721. with perl v5.6.1 built for i386-freebsd
  1722.  
  1723. =item * FreeBSD 3.4
  1724.  
  1725. with perl v5.6.1 built for i386-freebsd
  1726.  
  1727. with perl v5.005_03 built for i386-freebsd
  1728.  
  1729. =item * Linux
  1730.  
  1731. with perl v5.005_03 built for ppc-linux
  1732.  
  1733. =item * Solaris 2.6 (SPARC)
  1734.  
  1735. with perl5.6.1 built for sun4-solaris.
  1736.  
  1737. with perl5.004_04 built for sun4-solaris.
  1738.  
  1739. Can use on Solaris2.6 with perl5.004_04, although I<make test> is failure.
  1740.  
  1741. =back
  1742.  
  1743.  
  1744. =head1 LIMITATION
  1745.  
  1746. =over 4
  1747.  
  1748. =item * Can't use 'crypt' authentication in a part of FreeBSD.
  1749.  
  1750. =item * Can't use the 'Kerberos v4/5' authentication.
  1751.  
  1752. =item * Can't use the SSL Connection.
  1753.  
  1754. =item * Can't use BLOB data.
  1755.  
  1756. =back
  1757.  
  1758.  
  1759. =head1 DEPENDENCIES
  1760.  
  1761. This module requires these other modules and libraries:
  1762.  
  1763.   L<DBI>, L<IO::Socket>
  1764.  
  1765.  
  1766. =head1 TODO
  1767.  
  1768. =over 4
  1769.  
  1770. =item * Add the original crypt (pure perl) method.
  1771.  
  1772. =back
  1773.  
  1774. =head1 SEE ALSO
  1775.  
  1776. L<DBI>, L<http://developer.postgresql.org/docs/postgres/protocol.html>
  1777.  
  1778. =head1 AUTHOR
  1779.  
  1780. Hiroyuki OYAMA E<lt>oyama@crayfish.co.jpE<gt>
  1781.  
  1782. =head1 COPYRIGHT AND LICENCE
  1783.  
  1784. Copyright (C) 2002 Hiroyuki OYAMA. Japan. All rights reserved.
  1785.  
  1786. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
  1787.  
  1788. =cut
  1789.