#!/usr/bin/perl -w
# dbiserver.pl

use strict;

use DBI;
use IO::File;
use IO::Socket;
use IO::Select;

# ------------------------------------------------------------------------------
# Arguments
my $table_name = shift || 'food';

# ------------------------------------------------------------------------------
# Constants
# server socket pathname
my $dbiserver_socket_pathname = "/tmp/dbiserver.sock";

# types
my $TYPE1_GENERAL = 0;
my $TYPE_CONNECT = 0x0000;

my $TYPE1_DATABASE = 1;
my $TYPE_DB_DISCONNECT = 0x0100;
my $TYPE_DB_TABLES = 0x0101;
my $TYPE_DB_TEST_TABLE = 0x0102;
my $TYPE_DB_PREPARE = 0x0103;
my $TYPE_DB_DO = 0x0104;
my $TYPE_DB_SELECTROW = 0x0105;
my $TYPE_DB_SELECTALL = 0x0106;
my $TYPE_DB_SELECTCOL = 0x0107;

my $TYPE1_STATEMENT = 2;
my $TYPE_ST_EXECUTE = 0x0200;
my $TYPE_ST_FETCHROW = 0x0201;
my $TYPE_ST_FINISH = 0x0202;
my $TYPE_ST_FETCHALL = 0x0203;

# error codes - 0 is OKAY
my $ERROR_UNKNOWN_TYPE = 1;
my $ERROR_DBI_FAIL = 2;
my $ERROR_INVALID_HANDLE = 3;
my $ERROR_TOO_MANY_HANDLES = 4;
my $ERROR_SYNTAX = 5;


# ------------------------------------------------------------------------------
# Connect to the server
my $dbiserver_socket = IO::Socket::UNIX->new(Peer => $dbiserver_socket_pathname)
    || die "Can't connect to $dbiserver_socket_pathname";

# ------------------------------------------------------------------------------
# Connect to the server

my ($status, $reply);

for (1..100) {
    &test_features;
    &test_speed;
}

sub test_features {

my $db = &connect('Pg:dbname=test');

db_do($db, "DROP TABLE $table_name") if db_test_table($db, $table_name);

db_do($db, "CREATE TABLE $table_name (name varchar(10), cost int)");

my $tables = db_tables($db);
print 'Tables: ' . pretty_list($tables);

  my $st = db_prepare($db, "SELECT * FROM $table_name");
  my ($n_rows, $fields) = st_execute($st);

    my $st1 = db_prepare($db, "INSERT INTO $table_name VALUES (?, ?)");

  print "SELECT * FROM $table_name : $n_rows\n";
  print "fields: ", pretty_list($fields);
  while (my $row = st_fetchrow($st)) {
      print pretty_list($row);
  }

    st_execute($st1, 'asdf', 11);
    st_execute($st1, 'cow', 12);
    st_finish($st1);

db_do($db, "ALTER TABLE $table_name ADD (weight int)");

db_do($db, "INSERT INTO $table_name VALUES (?, ?, ?)", 'worms', undef, 10);

  ($n_rows, $fields) = st_execute($st);
  print "SELECT * FROM $table_name : $n_rows\n";
  print "fields: ", pretty_list($fields);
  my $rows = st_fetchall($st);
  for my $row (@$rows) {
      print pretty_list($row);
  }

  print "Testing 'selectrow'\n";
  my $row = db_selectrow($db, "SELECT * FROM $table_name WHERE name='asdf'");
  print pretty_list($row);

  print "Testing 'selectcol'\n";
  $row = db_selectcol($db, "SELECT cost FROM $table_name");
  print pretty_list($row);

  print "Testing 'selectall'\n";
  $rows = db_selectall($db, "SELECT * FROM $table_name");
  for my $row (@$rows) {
      print pretty_list($row);
  }

db_disconnect($db);

}

sub test_speed {

$| = 1; # so dots come at once!

for my $i (1..20) {
    print ".";

    my $db = &connect('Pg:dbname=test');

    my $st = db_prepare($db, "SELECT * FROM $table_name");
    my ($n_rows, $fields) = st_execute($st);
    my $rows = st_fetchall($st);
#    print "$#$rows";

    db_disconnect($db);
}

print "\n";

}

$dbiserver_socket->close;


sub pretty_list {
    my $list = ref $_[0] ? shift : \@_;
    return "(" . (join ',', map { defined $_ ? $_ : 'NULL' } @$list) . ")\n";
}

sub connect {
    return unpack("n", request($TYPE_CONNECT, shift));
}

sub db_disconnect {
    handle_request($TYPE_DB_DISCONNECT, shift);
}

sub db_tables {
    return unpack_list(handle_request($TYPE_DB_TABLES, shift));
}

sub db_test_table {
    return handle_request($TYPE_DB_TEST_TABLE, shift, shift) eq "\1";
}

sub db_prepare {
    return unpack("n", handle_request($TYPE_DB_PREPARE, shift, shift));
}

sub db_do {
    my $db = shift;
    my $sql = shift;
    my $bind = @_ ? pack_list([@_]) : '';
    handle_request($TYPE_DB_DO, $db, pack_string($sql) . $bind);
}

sub db_selectrow {
    my $db = shift;
    my $sql = shift;
    my $bind = @_ ? pack_list([@_]) : '';
    my $row = unpack_list(handle_request($TYPE_DB_SELECTROW, $db, pack_string($sql) . $bind));
    return @$row ? wantarray ? @$row : $row : ();
}

sub db_selectall {
    my $db = shift;
    my $sql = shift;
    my $bind = @_ ? pack_list([@_]) : '';
    my @rows = map {scalar(unpack_list($_))} @{unpack_list(handle_request($TYPE_DB_SELECTALL, $db, pack_string($sql) . $bind))};
    return wantarray ? @rows : \@rows;
}

sub db_selectcol {
    my $db = shift;
    my $sql = shift;
    my $bind = @_ ? pack_list([@_]) : '';
    my $row = unpack_list(handle_request($TYPE_DB_SELECTCOL, $db, pack_string($sql) . $bind));
    return @$row ? wantarray ? @$row : $row : ();
}

sub st_execute {
    my $reply = handle_request($TYPE_ST_EXECUTE, shift, pack_list([@_]));
    return (unpack 'N', substr $reply, 0, 4, ''), unpack_list($reply);
}

sub st_fetchrow {
    my $row = unpack_list(handle_request($TYPE_ST_FETCHROW, shift));
    return @$row ? wantarray ? @$row : $row : ();
}

sub st_finish {
    handle_request($TYPE_ST_FINISH, shift);
}

sub st_fetchall {
    my @rows = map {scalar(unpack_list($_))} @{unpack_list(handle_request($TYPE_ST_FETCHALL, shift))};
    return wantarray ? @rows : \@rows;
}

# this makes a request with a handle, it does not handle a request!!
sub handle_request {
    my ($type, $handle, $request) = @_;
    $request = pack('n', $handle) . ($request || '');
    return request($type, $request);
}

# a simple, non-pipelined request
sub request {
    my ($type, $request, $client_ref) = @_;
    $request ||= ''; $client_ref ||= 0;
    $request = pack("Nnn", 8 + length($request), $type, $client_ref) . $request;
    print $dbiserver_socket $request;

    # get reply
    my $reply = '';
    my $read_len = 0;

    my ($length, $status);

    until (defined $length and $read_len == $length) {
	$read_len += sysread $dbiserver_socket, $reply, 63*1024, length $reply;

	if (not defined $length and $read_len >= 10) {
	    ($length, $type, $client_ref, $status) = unpack("Nnnn", substr($reply, 0, 10, ''));
	    if (defined $length) {
		die 'server closed connection' if $length == 0;
		die 'read too much' if $read_len > $length;
	    }
	}
#    print "$read_len / $length\n";
    }
    die "error from dbiserver: $status $reply" if $status;

    return $reply;
}

# pack a 'binary protocol list'
sub pack_list {
    my $packed = pack 'N', scalar @{$_[0]};

    for my $item (@{$_[0]}) {
	$packed .= defined $item ?
	    (pack 'N', length $item) . $item :
	    pack 'N', 0xFFFFFFFF;
    }

    return $packed;
}

# unpack a 'binary protocol' list
# this will return undef if there is a protocol error
sub unpack_list {
    my $packed = shift;
    my $n = unpack 'N', substr $packed, 0, 4, '';
#    return unless defined $n;
    my @list = ();
    while ($packed) {
	my $len = unpack 'N', substr $packed, 0, 4, '';
#	return unless defined $len and $len <= length($packed);
	push @list, ($len == 0xFFFFFFFF) ?
	    undef :
	    substr $packed, 0, $len, '';
    }
#    return unless $n == @list;
    return \@list;#wantarray ? @list : \@list;
}

sub pack_string {
    return (pack 'n', length($_[0])) . $_[0];
}