=head1 NAME

DBD::PgPP - Pure Perl PostgreSQL driver for the DBI

=head1 SYNOPSIS

  use DBI;

  my $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', ''');

  # See the DBI module documentation for full details

=cut


#######################################          DBD::PgPP
package DBD::PgPP;
use strict;

use DBI;
use Carp;
use vars qw($VERSION $err $errstr $state $drh);
use Data::Dumper;
our $DEBUG= 0;


$VERSION = '0.05';
$err = 0;
$errstr = '';
$state = undef;
$drh = undef;

sub driver {
  return $drh if $drh;

  my $class = shift;
  my $attr  = shift;
  $class .= '::dr';

  $drh = DBI::_new_drh(
      $class
      ,{
          Name        => 'PgPP',
          ,Version     => $VERSION
          ,Attribution => 'DBD::PgPP by Eugen Konkov'
          }
      ,{}
      );
  }


sub _parse_dsn
{
 my $class = shift;
 my ($dsn, $args) = @_;
 my($hash, $var, $val);
 return if ! defined $dsn;

 while (length $dsn) {
  if ($dsn =~ /([^:;]*)[:;](.*)/) {
   $val = $1;
   $dsn = $2;
  }
  else {
   $val = $dsn;
   $dsn = '';
  }
  if ($val =~ /([^=]*)=(.*)/) {
   $var = $1;
   $val = $2;
   if ($var eq 'hostname' || $var eq 'host') {
    $hash->{'host'} = $val;
   }
   elsif ($var eq 'db' || $var eq 'dbname') {
    $hash->{'database'} = $val;
   }
   else {
    $hash->{$var} = $val;
   }
  }
  else {
   for $var (@$args) {
    if (!defined($hash->{$var})) {
     $hash->{$var} = $val;
     last;
    }
   }
  }
 }
 return $hash;
}


sub _parse_dsn_host
{
 my($class, $dsn) = @_;
 my $hash = $class->_parse_dsn($dsn, ['host', 'port']);
 ($hash->{'host'}, $hash->{'port'});
}


#######################################          DBD::PgPP::dr
package DBD::PgPP::dr;

$DBD::PgPP::dr::imp_data_size = 0;

use strict;


sub connect {
  my( $drh, $dsn, $user, $password, $attrhash )= @_;
  $user     ||= '';
  $password ||= '';

  #parse DSN
  my $data_source_info = DBD::PgPP->_parse_dsn( $dsn, ['database', 'host', 'port'] );

  #create handle
  my( $odbh, $idbh )= DBI::_new_dbh(
      $drh
      ,{
        Name => $dsn
        }
      ,{}
      );

  # connect
  my $connection;
  $connection= DBD::PgPP::Dialogue->new(
      hostname => $data_source_info->{host},
      port     => $data_source_info->{port},
      database => $data_source_info->{database},
      user     => $user,
      password => $password,
      debug    => $data_source_info->{debug},
      );

  # save info
  $idbh->STORE('Active', 1 );
  $idbh->{pgpp_dbh} = $connection;

  print "CONNECT\n"   if $DBD::PgPP::DEBUG;
  print "d: $idbh  D: $odbh\n"   if $DBD::PgPP::DEBUG;
  print Data::Dumper->Dump([ $idbh, $odbh ])   if $DBD::PgPP::DEBUG;

  warn "\nCONNECTED"   if $DBD::PgPP::DEBUG;
  return $odbh;
  }



#######################################          DBD::PgPP::db
package DBD::PgPP::db;

$DBD::PgPP::db::imp_data_size = 0;
use strict;



#------------------
sub prepare {
  my ($dbh, $statement, @attribs) = @_;

  # create a 'blank' sth
  my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement });

  print "PREPARE\n"   if $DBD::PgPP::DEBUG;
  print "s: $sth  S: $outer\n"   if $DBD::PgPP::DEBUG;

  $dbh->{pgpp_dbh}->prepare( $sth );

  print Data::Dumper->Dump([ $sth, $outer ])   if $DBD::PgPP::DEBUG;

  warn "\nPREPARED"   if $DBD::PgPP::DEBUG;
  return $outer;
  }




#------------------
sub commit {#+
  my ($dbh) = @_;
  if ($dbh->FETCH('Warn')) {
    warn("Commit ineffective while AutoCommit is on");
    }

  0;
  }


#------------------
sub rollback {#+
  my ($dbh) = @_;

  if ($dbh->FETCH('Warn')) {
    warn("Rollback ineffective while AutoCommit is on");
    }

  0;
  }


#sub commit
#{
# my $dbh = shift;
# my $pgsql = $dbh->FETCH('pgpp_connection');
# eval {
#  my $pgsth = $pgsql->prepare('COMMIT');
#  $pgsth->execute();
# };
# if ($@) {
#  $dbh->DBI::set_err(
#   1, $@ #$pgsql->get_error_message
#  );
#  return undef;
# }
# return 1;
#}
#
#
#sub rollback
#{
# my $dbh = shift;
# my $pgsql = $dbh->FETCH('pgpp_connection');
# eval {
#  my $pgsth = $pgsql->prepare('ROLLBACK');
#  $pgsth->execute();
# };
# if ($@) {
#  $dbh->DBI::set_err(
#   1, $@ #$pgsql->get_error_message
#  );
#  return undef;
# }
# return 1;
#}



sub FETCH { #+
  my ($dbh, $attr) = @_;

  if ($attr eq 'AutoCommit') { return 1; }
  if ($attr =~ m/^pgpp_/) {
    # Handle only our private attributes here
    # Note that we could trigger arbitrary actions.
    return $dbh->{$attr}; # Yes, we are allowed to do this,
                          # but only for our private attributes
    }

  # Else pass up to DBI to handle
  $dbh->SUPER::FETCH($attr);
  }



sub STORE { #+
  my ($dbh, $attr, $val) = @_;

  if ($attr eq 'AutoCommit') {
    # AutoCommit is currently the only standard attribute we have
    # to consider.
    if (!$val) { die "Can't disable AutoCommit"; }
    return 1;
    }

  if ($attr =~ m/^pgpp_/) {
    # Handle only our private attributes here
    # Note that we could trigger arbitrary actions.
    # Ideally we should warn about unknown attributes.
    $dbh->{$attr} = $val; # Yes, we are allowed to do this,
    return 1;             # but only for our private attributes
    }

  # Else pass up to DBI to handle for us
  $dbh->SUPER::STORE($attr, $val);
  }



#######################################          DBD::PgPP::st
package DBD::PgPP::st;

$DBD::PgPP::st::imp_data_size = 0;
use strict;


#------------------
sub bind_param {#+
  my ($sth, $pNum, $val, $attr) = @_;
  my $type = (ref $attr) ? $attr->{TYPE} : $attr;
  if ($type) {
    my $dbh = $sth->{Database};
    $val = $dbh->quote($sth, $type);
    }

  my $params = $sth->{pgpp_params};
  $params->[$pNum-1] = $val;
  1;
  }


#------------------
sub execute {
  my ($sth, @bind_values) = @_;

  # start of by finishing any previous execution if still active
  $sth->finish   if $sth->FETCH('Active');

  my $params = (@bind_values) ? \@bind_values : $sth->{pgpp_Params};
  my $numParam = $sth->FETCH('NUM_OF_PARAMS');

  return $sth->set_err($DBI::stderr, "Wrong number of parameters")   if @$params != $numParam;
  my $statement = $sth->{Statement};

#  for (my $i = 0;  $i < $numParam;  $i++) {
#   $statement =~ s/\?/$params->[$i]/; # XXX doesn't deal with quoting etc!
#   }

  print "EXECUTED\n"      if $DBD::PgPP::DEBUG;
  print "$sth->{Database}\n$sth->{Statement}\n"      if $DBD::PgPP::DEBUG;
  print Data::Dumper->Dump([ $sth ])      if $DBD::PgPP::DEBUG;

  # Do anything ... we assume that an array ref of rows is
  # created and store it:

  $sth->{Database}{pgpp_dbh}->execute( $sth, $params );
  $sth->{'pgpp_data'} = [];

  $sth->{Active} = 1;
  return '0E0';
#  @$data || '0E0';

#  $sth->{'drv_data'} = $data;
#  $sth->{'drv_rows'} = @$data; # number of rows
#  $sth->STORE('NUM_OF_FIELDS') = $numFields;
#  $sth->{Active} = 1;
#  @$data || '0E0';
  }


#------------------
sub fetchrow_arrayref {
  my( $sth )= @_;

  if( (scalar @{ $sth->{pgpp_data} }) == 0 ) {
    $sth->{Database}{pgpp_dbh}->fetch( $sth );
    }

  my $row= shift @{ $sth->{pgpp_data} };

  if( !$row ) {
    $sth->STORE(Active => 0); # mark as no longer active
    return undef;
    }

  if( $sth->FETCH('ChopBlanks') ) {
    map { $_ =~ s/\s+$//; } @$row;
    }

  return $sth->_set_fbav($row);
  }


#------------------
*fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref


#------------------
sub FETCH { #+
  my ($dbh, $attr) = @_;

  if( $attr eq 'AutoCommit' ) { return 1; }
  if( $attr eq 'NAME' ) { return $dbh->{$attr}; }
  if( $attr =~ m/^pgpp_/ ) {
    # Handle only our private attributes here
    # Note that we could trigger arbitrary actions.
    return $dbh->{$attr}; # Yes, we are allowed to do this,
                          # but only for our private attributes
    }

  # Else pass up to DBI to handle
  $dbh->SUPER::FETCH($attr);
  }

#sub FETCH  #-
#{
# my $dbh = shift;
# my $key = shift;
#
## return $dbh->{AutoCommit} if $key eq 'AutoCommit';
# return $dbh->{NAME} if $key eq 'NAME';
# return $dbh->{$key} if $key =~ /^pgpp_/;
# return $dbh->SUPER::FETCH($key);
#}


sub STORE { #+
  my ($dbh, $attr, $val) = @_;

  if( $attr eq 'NAME' ) {
    $dbh->{NAME} = $val;
    return 1;
    }

  if ($attr eq 'AutoCommit') {
    # AutoCommit is currently the only standard attribute we have
    # to consider.
    if (!$val) { die "Can't disable AutoCommit"; }
    return 1;
    }

  if ($attr =~ m/^pgpp_/) {
    # Handle only our private attributes here
    # Note that we could trigger arbitrary actions.
    # Ideally we should warn about unknown attributes.
    $dbh->{$attr} = $val; # Yes, we are allowed to do this,
    return 1;             # but only for our private attributes
    }

#  warn "\n\n>>>$attr = $val\n\n";
#  warn "@{[ caller ]}";

  # Else pass up to DBI to handle for us
  $dbh->SUPER::STORE($attr, $val);
  }

#sub STORE #-
#{
# my $dbh = shift;
# my ($key, $value) = @_;
#
# if ($key eq 'NAME') {
#  $dbh->{NAME} = $value;
#  return 1;
# }
# elsif ($key =~ /^pgpp_/) {
#  $dbh->{$key} = $value;
#  return 1;
# }
# elsif ($key eq 'NUM_OF_FIELDS') {
#  # Don't set this twice; DBI doesn't seem to like it.
#  # XXX: why not?
#  my $curr = $dbh->FETCH($key);
#  return 1 if $curr && $curr == $value;
# }
# return $dbh->SUPER::STORE($key, $value);
#}


#sub DESTROY {
#  my $sth = shift;
#
#  $sth->finish   if $sth->FETCH('Active');
#  }


package DBD::PgPP::Dialogue;

our $DEBUG= $DBD::PgPP::DEBUG;

use Digest::MD5 qw( md5_hex );
use Data::Dumper;


#################################################          MESSAGE
#package DBD::PgPP::Message;

#references to function which convert received binary data to internal data: 00 00 00 05 => 5, 73 7A 00 => 'sz' and so on
my %oidHandler= (
  16     => undef #define BOOLOID   16
  ,17    => undef #define BYTEAOID  17
  ,18    => undef #define CHAROID   18
  ,19    => undef #define NAMEOID   19
  ,20    => undef #define INT8OID   20
  ,21    => undef #define INT2OID   21
  ,22    => undef #define INT2VECTOROID 22
  ,23    => sub { !defined $_[0] ? return 'INT4' : return sign32( unpack 'N', $_[0] ) } #define INT4OID   23
  ,24    => undef #define REGPROCOID  24
  ,25    => undef #define TEXTOID   25
  ,26    => undef #define OIDOID   26
  ,27    => undef #define TIDOID  27
  ,28    => undef #define XIDOID 28
  ,29    => undef #define CIDOID 29
  ,30    => undef #define OIDVECTOROID 30
  ,71    => undef #define PG_TYPE_RELTYPE_OID 71
  ,75    => undef #define PG_ATTRIBUTE_RELTYPE_OID 75
  ,81    => undef #define PG_PROC_RELTYPE_OID 81
  ,83    => undef #define PG_CLASS_RELTYPE_OID 83
  ,705   => undef #define UNKNOWNOID  705
  ,1043  => undef #define VARCHAROID  1043
  );


# Message Identifies
my %messageHandler= (
  1 => \&ParseComplete
  ,2 => \&BindComplete
  ,3 => \&CloseComplete
  ,A => \&NotificationResponse
  ,C => \&CommandComplete
  ,D => \&DataRow
  ,E => \&ErrorResponse
  ,I => \&EmptyQueryResponse
  ,K => \&BackendKeyData
  ,N => \&NoticeResponse
  ,n => \&NoData
  ,T => \&RowDescription
  ,t => \&ParameterDescription
  ,R => \&Authentication
  ,S => \&ParameterStatus
  ,s => \&PortalSuspended
  ,Z => \&ReadyForQuery
  );

#FronEndMessages
#   => CancelRequest
#   => StartupMessage
#   => SSLRequest
# B => Bind
# C => Close
# c => ?CopyDone
# D => Describe
# d => ?CopyData
# E => Execute
# F => ?FunctionCall
# f => ?CopyFail
# H => Flush
# P => Parse
# p => PasswordMessage
# Q => Query
# S => Sync
# X => Terminate

my %errorHandler= (
  );

my @authHandler= (
  \&AuthenticationOk                        #0
  ,undef                                    #1
  ,\&AuthenticationKerberosV5               #2
  ,\&AuthenticationCleartextPassword        #3
  ,\&AuthenticationCryptPassword            #4
  ,\&AuthenticationMD5Password              #5
  ,\&AuthenticationSCMCredential            #6
  ,\&AuthenticationGSS                      #7
  ,\&AuthenticationGSSContinue              #8
  ,\&AuthenticationSSPI                     #9
  );


#------------------
sub sign16 {
  my $negative= 2**16;
  my $positive= 2**15;
  for( @_ ) {
   $_-= $negative   if $_ >= $positive;
   }

  return @_;
  }

sub sign32 {
  my $negative= 2**32;
  my $positive= 2**31;
  for( @_ ) {
   $_-= $negative   if $_ >= $positive;
   }

  return @_;
  }

#------------------
sub Authentication { #(B)...
  my( $self, $message )= @_;

  my( $type, $message )= unpack 'Na*', $message;

  return ($type, $authHandler[ $type ]->( $self, $message )); #type, message
  }


#------------------
sub ErrorResponse { #(B)
  my( $self, $message )= @_;
  chop( $message );
  my %errors= unpack '(aZ*)*', $message;

  $self->{Error}= Data::Dumper->Dump([ \%errors ]);
  #$self->set_err( 1, Data::Dumper->Dump([ \%errors ]) );
  die 'DIED'. Data::Dumper->Dump([ $self ]);

  return 1;
  }


#--------------------------------------               AUTHENTICATION
#------------------
sub AuthenticationOk { #(B)
  my( $self, $message )= @_;

  my $authStatus= unpack 'N', $message;
  $self->waitResponse( { S => undef, K => 1, Z => 1 } );

  return 1;
  }


#------------------
sub AuthenticationMD5Password { #(B)
  my( $self, $message )= @_;

  my $salt= unpack 'a*', $message;

  #auth response
  my $password= 'md5'. md5_hex( md5_hex( $self->{password}, $self->{user} ), $salt );
  $self->sendMessage( PasswordMessage( $password ) );

  return 1;
  }

#--------------------------------------               COMMON
#------------------
sub BackendKeyData { #(B)
  my( $self, $message )= @_;

  ( $self->{processID}, $self->{secretKey} )= unpack 'NN', $message;

  return 0;
  }

#------------------
sub Bind { #(F)
  my( $portalName, $statementName, $paramsFormatCodes, $paramsValues, $resultColumnFormatCodes )= @_;

  my $format= 'Z*Z*';
  my $message= pack $format, $portalName, $statementName;

  #params format
  $format= 'nn*';
  $message.= pack $format, scalar @$paramsFormatCodes, @$paramsFormatCodes;

  #params values
  $format= 'n';
  $message.= pack $format, scalar @$paramsValues;
  $format= 'Na*';
  for my $value ( @$paramsValues ) {
   if( defined $value ) {
     $message.= pack $format, length $value, $value;
     }
    else {
     $message.= pack 'N', -1;
     }
   }

  #result type
  $format= 'nn*';
  $message.= pack $format, scalar @$resultColumnFormatCodes, @$resultColumnFormatCodes;

  return ('B', $message, { 2 => 1 } );
  }

#------------------
sub BindComplete { #(B)
  my( $self, $message )= @_;

  $self->{bindComplete}= 1; #Need I this?

  return 1;
  }

#------------------
#TODO! Must be sent via new connection
sub CancelRequest { #(F)
  my( $processID, $secretKey )= @_;

  return ('', (pack 'NNN', 80877102, $processID, $secretKey), undef);
  }

#------------------
sub Close { #(F)
  my( $type, $name )= @_;

  my $format= 'aZ*';
  return ('C', (pack $format, $type, $name), { 3 => 1 } );
  }

#------------------
sub CloseComplete { #(B)
  my( $self, $message )= @_;

  #TODO: handle close message

  return 1;
  }

#------------------
sub CommandComplete { #(B)
  my( $self, $message )= @_;

  $_= $message;
  COMMAND: {
    /^SELECT/ && do {
     return 1;
     last COMMAND;};

    die "Can not handle '$message'";
    }
  }

#------------------
sub DataRow { #(B)
  my( $self, $message )= @_;

  my $cntFields= unpack 'n', substr $message, 0, 2, '';

  my @row= ();
  for( 1 .. $cntFields ) {
   my $dataSize= unpack 'N', $message; substr $message, 0, 4, '';
   sign32( $dataSize );
   my $data= undef;
   $data= substr $message, 0, $dataSize, ''   if $dataSize >= 0;
   print "LEN: $dataSize\tDATA: >>$data<<\n"   if $DEBUG;
   push @row, $data;
   }

  push @{ $self->{DataRow} }, \@row;
  return 0;
  }

#------------------
# $type= (S|P)
# $name= name of statement/portal
sub Describe { #(F)
  my( $type, $name )= @_;

  my $expectResponse= { T => undef, n => undef }   if $type eq 'P';
  my $expectResponse= { t => 1, T => undef, n => undef }   if $type eq 'S';

  my $format= 'aZ*';
  return ('D', (pack $format, $type, $name), $expectResponse );
  }

#------------------
sub EmptyQueryResponse { #(B)
  my( $self, $message )= @_;

  $self->{EmptyQuery}= 1; #TODO: Need I this?

  return 1;
  }

#------------------
sub Execute { #(F)
  my( $portalName, $maxRows )= @_;

  return ('E', (pack 'Z*N', $portalName, $maxRows), { s => undef, C => undef, I => undef, D => $maxRows } );
  }

#------------------
sub Flush { #(F)
  return ('H', '', undef, 1);
  }

#------------------
sub NoData { #(B)
  my( $self, $message )= @_;

  $self->{NoData}= 1; #TODO: Need I this?

  return 1;
  }

#------------------
sub NoticeResponse { #(B)
  my( $self, $message )= @_;
  chop( $message );
  my %notices= unpack '(aZ*)*', $message;

  #$self->{Notice}= Data::Dumper->Dump([ \%notices ]);
  warn Data::Dumper->Dump([ \%notices ]);

  return 1;
  }

#------------------
sub NotificationResponse { #(B)
  my( $self, $message )= @_;

  my( $processID, $notifyCond, $info )= unpack 'NZ*Z*', $message;

  die "NOTIFY($processID): $notifyCond. $info";

  return 1;
  }

#------------------
sub ParameterDescription { #(B)
  my( $self, $message )= @_;

  my $cntParams= unpack 'n', substr $message, 0, 2, '';
  print "Parameters count: $cntParams\n"      if $DEBUG;

  $self->{ParamsCount}= $cntParams;
  $self->{Params}= [];
  for( 1 .. $cntParams ) {
   (my( $typeOID ), $message)= unpack 'Na*', $message;
   sign32( $typeOID );

   #print 'TYPE: '. $oidHandler{$typeOID}. "\n";
   print "TYPE: $typeOID\n"      if $DEBUG;
   push @{ $self->{Params} }, $typeOID;
   }

  return 0;
  }

#------------------
sub ParameterStatus { #(B)
  my( $self, $message )= @_;

  my( $name, $value )= unpack 'Z*Z*', $message;
  $self->{ParameterStatus}{$name}= $value;

  return 0;
  }

#------------------
sub Parse { #(F)
  my( $queryName, $queryStr )= @_;

  my $format= 'Z*Z*n'; #TODO: params
  return ('P', (pack $format, $queryName, $queryStr, 0), { 1 => 1 } );
  }

#------------------
sub ParseComplete { #(B)
  my( $self, $message )= @_;

  $self->{parseComplete}= 1; #Need I this?

  return 1;
  }

#------------------
sub PasswordMessage { #(F)
  my( $password )= @_;

  my $format= 'Z*';
  return ('p', (pack $format, $password), { R => 1 }, 1);
  }

#------------------
sub PortalSuspended { #(B)
  my( $self, $message )= @_;

  $self->{portalSuspend}= 1; #Need I this?

  return 1;
  }

#------------------
sub Query { #(F)
  my( $queryStr )= @_;

  my $format= 'Z*';
  return ('Q', (pack $format, $queryStr));
  }

#------------------
sub ReadyForQuery { #(B)
  my( $self, $message )= @_;

  $self->{tranStatus}= unpack 'a', $message;

  return 1;
  }

#------------------
sub RowDescription { #(B)
  my( $self, $message )= @_;

  my $cntFields= unpack 'n', substr $message, 0, 2, '';
  print "Fields count: $cntFields\n"      if $DEBUG;


  $self->{FieldsCount}= $cntFields;
  $self->{Fields}= [];
  for( 1 .. $cntFields ) {
   (my( $name, $tableOID, $columnNum, $typeOID, $dataSize, $typeModifier, $format ), $message)= unpack 'Z*NnNnNna*', $message;
   sign32( $tableOID, $typeOID, $typeModifier ); sign16( $columnNum, $dataSize, $format );
   #substr $message, 0, (length $name) +1 +4 +2 +4 +2 +4 +2, ''; #optimized by 'a*'

   print "COLUMN: $columnNum; FIELD: $name; TYPE: $typeOID; SIZE: $dataSize; FORMAT: $format\n"      if $DEBUG;
   push @{ $self->{Fields} }, { name => $name, tableOID => $tableOID, columnNum => $columnNum, typeOID => $typeOID, dataSize => $dataSize, typeModifier => $typeModifier, format => $format };
   }

  return 1;
  }

sub SSLRequest { #(F)

  die "NOT IMPLEMENTED";
  return ('', (pack 'N', 80877103) );
  }

#------------------
sub StartupMessage { #(F)
  my( $protoMajor, $protoMinor, %options )= @_;

  my $format= 'nn'. 'Z*' x ((keys %options)*2). 'c';
  return ( '', (pack $format, $protoMajor, $protoMinor, %options, 0), { R => 1 }, 1 );
  }


#------------------
sub Sync { #(F)
  return ('S', '', { Z => 1 }, 1);
  }


#------------------
sub ErrSync { #(F)
  return ('S', '', { Z => 1 }, 1);
  }


#------------------
sub Terminate { #(F)
  return ('X', '', undef);
  }


#------------------------------------------------          MESSAGES HANDLING LOGIC
#------------------
sub processMessage {
  my( $self, $type, $message )= @_;

  #OPTIMIZED: we do not queue empty responses by 'waitResponse'
  ##skip empty queued responses
  #while( scalar $self->{responseExpect}[0] > 0  &&  !defined $self->{responseExpect}[0] ) {
  # shift @{ $self->{responseExpect} };
  # }

  print "Get response: $type => $self->{responseExpect}[0]{$type}\n"   if $DEBUG;
  die "Can not handle message of type '$type'"   if !defined $messageHandler{ $type };
  my $errorMessage;
  if( $type eq 'E' ) {
    $errorMessage= 1;
    }
  elsif( $type eq 'N' ) {
    print "Notice response:\n"      if $DEBUG;
    }
  elsif( $type eq 'A' ) {
    print "Notification response:\n"      if $DEBUG;
    }
  elsif( $DEBUG ) {
    if( !exists $self->{responseExpect}[0]{$type} ) { #warn about unexpected message types
      warn "Unexpected message type '$type'";
      }
    elsif( !defined $self->{responseExpect}[0]{$type} ) { #nothing to do with messages which expected count is unlimited
      }
    elsif( $self->{responseExpect}[0]{$type} > 0 ) { #received expected so decrease count of expected messages
      $self->{responseExpect}[0]{$type}--;
      }
    elsif( $self->{responseExpect}[0]{$type} == 0 ) { #warn about messages which expected count has exceed
      warn "Expected message type '$type' count has exceed";
      }
     else {
      die "SOMETHING WRONG: >>$self->{responseExpect}[0]{$type}<<";
      }
    }

  my $lastMessage= $messageHandler{$type}->( $self, $message );

  if( $DEBUG ) {
    #check if there are messages expected to read
    my $waitNext= 0;
    while( my( $key, $value )= each %{ $self->{responseExpect}[0] } ) {
     $waitNext= "$key => $value"   if $value;
     }

    warn "We get last response of type '$type' but we still expect more '$waitNext'\n"   if $lastMessage && $waitNext;
    #print "LAST: $lastMessage\n";
    }

  if( $errorMessage ) {
    my $authMessage= defined $self->{responseExpect}[0]{R};
    $self->{responseExpect}= [];

    #If error message is received at authentication phase connection is closed by backend and we need nothing to do
    #otherwise we must read and discard until ReadyForQuery
    if( !$authMessage ) {
      $self->sendMessage( ErrSync() );
      }
    print "Error response:\n". Data::Dumper->Dump([ $self->{responseExpect} ], [ 'responseExpect' ])      if $DEBUG;
    }
  elsif( $lastMessage ) {
    shift @{ $self->{responseExpect} };
    print Data::Dumper->Dump([ $self->{responseExpect} ], [ 'responseExpect' ])   if $DEBUG;
    }


  return scalar @{ $self->{responseExpect} }; #return count of expected responses
  }

#------------------
sub readMessage {
  my( $self )= @_;

  recv $self->{'socket'}, my $buf, 5, 0;
  die "READ LENGTH MISSMATCH. Expected 5, readed ". length $buf   if length $buf != 5;
  #TODO: check length $buf;
  my( $type, $length )= unpack 'aN', $buf;

  $length-= 4; #do not count length marker
  my $message;
  recv $self->{'socket'}, $message, $length, 0   if $length > 0; #if cond is BUG WORKAROUND: recv block if you try to read 0 bytes from empty socket
  die "READ LENGTH MISSMATCH. Expected $length, readed ". length $message   if length $message != $length;
  _dump_packet( $buf. $message, "READ", 3 )   if $DEBUG > 1;

  return $self->processMessage( $type, $message );
  }


#------------------
#NOTICE! one response can expect many messages

sub waitResponse {
  my( $self, $responseExpect )= @_;
  push @{ $self->{responseExpect} }, $responseExpect   if defined $responseExpect;
  print "Wait response:\n". Data::Dumper->Dump([ $self->{responseExpect} ], [ 'responseExpect' ])   if $DEBUG;
  }


#------------------
sub sendMessage {
  my( $self, $type, $message, $responseExpect )= @_;

  #write message to socket
  my $typeLength= length $type;
  die "Type must be one character length"   if $typeLength > 1;

  my $msgLength= 4+ length $message;            #Length of message contents in bytes, including self.
  $message= $type. pack 'Na*', $msgLength, $message;

  my $sendLength= send $self->{'socket'}, $message, 0;
  if( $sendLength != $typeLength + $msgLength ) {
    die "Fail to send message '$type': >>$message<<";
    }

  _dump_packet( $message, "SEND", 3 )   if $DEBUG > 1;
  $self->waitResponse( $responseExpect );

  return $message;
  }


#------------------
# @_ is message where:
# $_[0]  -- message type
# $_[1]  -- message body
# ...
# $_[-1] -- do not read after message send   if !defined
#

sub talk {
  my( $self, $type, $message, $responseExpect, $sync )= @_;

  warn "Nothing to talk", return   if !$type && !$message;
  $self->sendMessage( $type, $message, $responseExpect );

  #read all queuee responses
  if( $sync ) {
    if( scalar @{ $self->{responseExpect} } != 0 ) {
      while(1) {
       last   if !$self->readMessage;
       };
      }
     else {
      warn "You ask to read response but do not provide messages you are expect";
      }
    }

  return;
  }



#################################################          PROTOCOL
use IO::Socket;
use strict;
use warnings;
our $VERSION = '1.00';

use constant DEFAULT_PORT_NUMBER => 5432;
use constant DEFAULT_TIMEOUT     => 60;
use constant BUFFER_LENGTH       => 1500;

#------------------
sub new {
  my $class = shift;
  my %args = @_;

  my $self = bless {
      hostname    => $args{hostname},
      port        => $args{port}     || DEFAULT_PORT_NUMBER,
      database    => $args{database} || $ENV{USER} || '',
      user        => $args{user}     || $ENV{USER} || '',
      password    => $args{password} || '',
      timeout     => $args{timeout}  || DEFAULT_TIMEOUT,
      'socket'    => undef,
      }
      ,$class;

  $DEBUG = 1 if $args{debug};

  $self->{'socket'}= $self->_connect();

  $self->talk( StartupMessage( 3, 0, user => $self->{user}, database => $self->{database} ) );

  return $self;
  }


#------------------
sub _connect {
  my $self = shift;

  my $socket;
  if ($self->{hostname}) {
    $socket = IO::Socket::INET->new(
        PeerAddr => $self->{hostname},
        PeerPort => $self->{port},
        Proto    => 'tcp',
        Timeout  => $self->{timeout},
        ) or die "Couldn't connect to $self->{hostname}:$self->{port}/tcp: $@";
    }
   else {
    $self->{path} =~ s{/$}{}; #???
    my $path = sprintf '%s/.s.PGSQL.%d', $self->{path}, $self->{port};
    $socket = IO::Socket::UNIX->new(
        Type => SOCK_STREAM,
        Peer => $path,
        ) or die "Couldn't connect to $self->{path}/.s.PGSQL.$self->{port}: $@";
    }

  $socket->autoflush(1);
  return $socket;
  }


#------------------
sub prepare {
  my( $self, $sth )= @_;

  #$self->talk( Query( $sth->{Statement} ));
  #$self->talk( Query( 'select * from pg_locks' ));
  #die "<<<!!";

  $sth->{name}= ''. rand;
  $self->talk( Parse( $sth->{name}, $sth->{Statement} ) );
  $self->talk( Describe( 'S', $sth->{name} ) );
  $self->talk( Flush() );

  $sth->{pgpp_Params}= [];
  $sth->{pgpp_ParamsType}= $self->{Params};
  $sth->STORE( 'NUM_OF_PARAMS', $self->{ParamsCount});

  $sth->STORE( 'NUM_OF_FIELDS', $self->{FieldsCount} );
  $sth->STORE( 'NAME', [ map {$_->{name}} @{ $self->{Fields} } ] );
  }


#------------------
sub execute {
  my( $self, $sth, $bindValues )= @_;

  $sth->{portal}= ''. rand;
  $self->talk( Bind( $sth->{portal}, $sth->{name}, [], $bindValues, [] ) );
  }


#------------------
sub fetch {
  my( $self, $sth )= @_;

  $self->talk( Execute( $sth->{portal}, 1 ) );
  $self->talk( Flush() );

  $sth->{pgpp_data}= $self->{DataRow};
  $self->{DataRow}= undef;
  }


#------------------
sub _dump_packet {
  return unless $DBD::PgPP::Dialogue::DEBUG;
  my( $packet, $info, $traceLevel )= @_;
  $traceLevel||= 1;

  print "\n\n$info\n"   if $info;
  printf " by %s()\n", (caller $traceLevel)[3];
  while( $packet =~ m/(.{1,16})/sg ) { #BUG: what will be happened if \n is inside message?
   my $chunk= $1;
   print join ' ', map {sprintf '%02X', ord $_} split //, $chunk;
   print '   ' x (16 - length $chunk);
   print '  ';
   print join '', map { sprintf '%s', /[\x00\x07\x09\x0A\xFF ]/ ? '.' : $_ } split //, $chunk;
   print "\n";
   }
  }


#------------------
sub close {
  my( $self )= @_;

  if( $self->{'socket'} ) {
    sendMessage( $self->{'socket'}, Terminate );
    $self->{'socket'}->close();
    }
  }


#------------------
sub DESTROY {
  my $self = shift;

  $self->close;
  }


#sub readByteN {
#  my( $socket, $length, $value )= @_;
#
#  my $result;
#  recv $socket, $result, $length, 0;
#
#  if( defined $value  &&  $result ne $value ) {
#    warn "Actual byte stream '$result' is differ from expected '$value'";
#    }
#
#  return $result;
#  }
#
#sub readInt16 {
#  my( $socket, $value )= @_;
#
#  my $result;
#  recv $socket, $result, 2, 0;
#  $result= unpack 'n', $result;
#
#  if( defined $value  &&  $result != $value ) {
#    warn "Actual Int16 '$result' is differ from expected '$value'";
#    }
#
#  return $result;
#  }
#
#sub readInt32 {
#  my( $socket, $value )= @_;
#
#  my $result;
#  recv $socket, $result, 4, 0;
#  $result= unpack 'N', $result;
#
#  if( defined $value  &&  $result != $value ) {
#    warn "Actual Int32 '$result' is differ from expected '$value'";
#    }
#
#  return $result;
#  }
#
#sub readString {
#  my( $socket, $value )= @_;
#
#  my $char;
#  my $result= ' ' x 100; $result= '';
#  while( ord ($char= readByteN( $socket, 1 )) ) {
#   $result.= $char;
#   }
#
#  if( defined $value  &&  $result != $value ) {
#    warn "Actual string '$result' is differ from expected '$value'";
#    }
#
#  return $result;
#  }


1;
__END__


=head1 DESCRIPTION

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!


=head1 MODULE DOCUMENTATION

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 !

=head1 THE DBI CLASS

=head2 DBI Class Methods

=over 4

=item B<connect>

To connecto to a database with a minimum of parameters, use the following syntax:
  $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', '');

This connects to the database $dbname at localhost without any user authentication. This is sufficient for the defaults of PostgreSQL.

The following connect statement shows all possible parameters:

  $dbh = DBI->connect(
      "dbi:PgPP:dbname=$dbname",
      $username, $password
  );

  $dbh = DBI->connect(
      "dbi:PgPP:dbname=$dbname;host=$host;port=$port",
      $username, $password
  );

  $dbh = DBI->connect(
      "dbi:PgPP:dbname=$dbname;path=$path;port=$port",
      $username, $password
  );

      parameter | hard coded default
      ----------+-------------------
      dbname    | current userid
      host      | localhost
      port      | 5432
      path      | /tmp
      debug     | undef

If a host is specified, the postmaster on this host needs to be started with the C<-i> option (TCP/IP socket).


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.

=back

=head1 SUPPORT OPERATING SYSTEM

This module has been tested on these OSes.

=over 4

=item * Mac OS 9

with MacPerl5.6.1r1 built for PowerPC

=item * Mac OS X

with perl v5.6.0 built for darwin

=item * Windows2000

with ActivePerl5.6.1 build631.

=item * FreeBSD 4.6

with perl v5.6.1 built for i386-freebsd

=item * FreeBSD 3.4

with perl v5.6.1 built for i386-freebsd

with perl v5.005_03 built for i386-freebsd

=item * Linux

with perl v5.005_03 built for ppc-linux

=item * Solaris 2.6 (SPARC)

with perl5.6.1 built for sun4-solaris.

with perl5.004_04 built for sun4-solaris.

Can use on Solaris2.6 with perl5.004_04, although I<make test> is failure.

=back


=head1 LIMITATION

=over 4

=item * Can't use 'crypt' authentication in a part of FreeBSD.

=item * Can't use the 'Kerberos v4/5' authentication.

=item * Can't use the SSL Connection.

=item * Can't use BLOB data.

=back


=head1 DEPENDENCIES

This module requires these other modules and libraries:

  L<DBI>, L<IO::Socket>


=head1 TODO

=over 4

=item * Add the original crypt (pure perl) method.

=back

=head1 SEE ALSO

L<DBI>, L<http://developer.postgresql.org/docs/postgres/protocol.html>

=head1 AUTHOR

Hiroyuki OYAMA E<lt>oyama@module.jpE<gt>

=head1 COPYRIGHT AND LICENCE

Copyright (C) 2004 Hiroyuki OYAMA. Japan. All rights reserved.

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut