#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

use strict;
require Exporter;
require AutoLoader;

use DBI;
use W3C::Util::Properties;
use POSIX qw(mktime);

$W3C::XML::DBIInterface::REVISION = '$Id: DBIInterface.pm,v 1.49 2004/11/26 09:06:09 eric Exp $ ';

package W3C::Database::DBIInterface;
use W3C::Util::Exception;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @TODO);
@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 1.0;
$DSLI = 'adpO';
@TODO = ();

package W3C::Database::DBIInterface::ConnectException;
@W3C::Database::DBIInterface::ConnectException::ISA = qw(W3C::Util::IOException);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-host') if (!exists $self->{-host});
    $self->missingParm('-port') if (!exists $self->{-port});
    $self->missingParm('-user') if (!exists $self->{-user});
    $self->missingParm('-password') if (!exists $self->{-password});
    $self->missingParm('-connectString') if (!exists $self->{-connectString});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {
    return 'Cannot connect as "'.$_[0]->getUser.'" to '.$_[0]->getHost.':'.$_[0]->getPort.' with "'.$_[0]->getConnectString.'"';
}
sub getHost {return $_[0]->{-host};}
sub getPort {return $_[0]->{-port};}
sub getUser {return $_[0]->{-user};}
sub getPassword {return $_[0]->{-password};}
sub getConnectString {return $_[0]->{-connectString};}

package W3C::Database::DBIInterface::ExecutionException;
@W3C::Database::DBIInterface::ExecutionException::ISA = qw(W3C::Util::IOException);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-connection') if (!$self->{-connection});
    $self->missingParm('-query') if (!exists $self->{-query});
    $self->{-error} = $self->{-connection}->errstr if (!$self->{-error});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'DBI Connection '.$_[0]->{-connection}.
			    ' failed to execute "'.$_[0]->{-query}.'": '.$_[0]->{-error};}
sub getConnection {return $_[0]->{-connection};}
sub getQuery {return $_[0]->{-query};}
sub getError {return $_[0]->{-error}}

package W3C::Database::DBIInterface::DuplicateKeyException;
@W3C::Database::DBIInterface::DuplicateKeyException::ISA = qw(W3C::Database::DBIInterface::ExecutionException);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-keyNumber') if (!$self->{-keyNumber});
    $self->missingParm('-keyValue') if (!defined $self->{-keyValue});
    $self->{-error} = $self->{-connection}->errstr if (!$self->{-error});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'DBI Connection '.$_[0]->{-connection}.
			    ' found duplicate key['.$_[0]->getKeyNumber.'] "'.$_[0]->getKeyValue.'": '.$_[0]->getQuery;}
sub getKeyNumber {return $_[0]->{-keyNumber};}
sub getKeyValue {return $_[0]->{-keyValue};}

package W3C::Database::DBIInterface::UnknownFieldException;
@W3C::Database::DBIInterface::UnknownFieldException::ISA = qw(W3C::Database::DBIInterface::ExecutionException);
sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->missingParm('-field') if (!$self->{-field});
    $self->{-error} = $self->{-connection}->errstr if (!$self->{-error});
    $self->fillInStackTrace;
    return $self;
}
sub getSpecificMessage {return 'DBI Connection '.$_[0]->{-connection}.
			    ' unknown key "'.$_[0]->getField.'" : '.$_[0]->getQuery;}
sub getField {return $_[0]->{-field};}

package W3C::Database::DBIInterface::UnknownExceptionException;
@W3C::Database::DBIInterface::UnknownExceptionException::ISA = qw(W3C::Database::DBIInterface::ExecutionException);
sub getSpecificMessage {return 'DBI Connection '.$_[0]->{-connection}.
			    ' failed to execute "'.$_[0]->{-query}.'"  unknown exception: '.$_[0]->{-error};}

package W3C::Database::DBIInterface::SingleQueryException;
@W3C::Database::DBIInterface::SingleQueryException::ISA = qw(W3C::Util::IOException);
#@W3C::Database::DBIInterface::SingleQueryException::ISA = qw(W3C::Database::DBIInterface::UnknownExceptionException);
sub getSpecificMessage {return "expected 1 result, got $_[0]->{-results} from \"$_[0]->{-query}\""}

package W3C::Database::DBIInterface;
use W3C::Util::Exception;
#####
# per-class data

my $Debugging = 0;	# whether to show debugging stuff
my $Outstanding = 0;	# count of outstanding connections

#####
# per-object data
# CONNECTION	- a DBI conection to our SQL server
# ERRSTR	-  error string from last SQL update
# DEBUG		- per-object control of debugging info

#####
# new - prepare a W3C::Database::DBIInterface with a new connection

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);
    my $properties = shift;
    if (ref $properties) {
	$self->{DATABASE} = $properties->getI('database');
	$self->{USER} = $properties->getI('user');
	$self->{PASSWORD} = $properties->getI('password');
	$self->{QUERY_HOST} = $properties->getI('queryHost');
	if ($self->{QUERY_HOST} eq '') {
	    $self->{QUERY_HOST} = 'localhost';
	}
	$self->addUpdateHost($self->{QUERY_HOST});
	$self->addUpdateHost(($properties->getI('replicatedHost'))); # get array of replication hosts
    } else {
	$self->{DATABASE} = $properties;
	$self->{USER} = shift;
	$self->{PASSWORD} = shift;
	$self->{QUERY_HOST} = shift;
	$self->addUpdateHost($self->{QUERY_HOST});
	foreach my $updateHost (@_) {
	    $self->addUpdateHost($updateHost);
	}
    }
    $self->{CONNECTIONS} = {};
    $self->{QUERY_CONNECTION} = $self->connect($self->{QUERY_HOST});
    $self->{DEBUG} = 0;
    # "private" data
    $self->{"_OUTSTANDING"} = \$Outstanding;

    ++ ${ $self->{"_OUTSTANDING"} };
    return $self;
}

sub show {
    my ($self, $flags) = @_;
    my $queryString = $self->{QUERY_HOST}.'('.(ref $self->{QUERY_CONNECTION}).')';
    my $updateString = '('.join (',', map {$_} @{$self->{UPDATE_HOSTS}}).')';
    return $self->{USER}.':xxxxx:'.$self->{DATABASE}.':<-'.$queryString.' ->'.$updateString;
}

sub connect {
    my ($self, $hostPort) = @_;
    my ($host, $port) = split(':', $hostPort);
    $port = 3306 if (!defined $port);
    my $connectString = 'DBI:mysql:'.$self->{DATABASE}.':'.$host.':'.$port;
    my $connection = DBI->connect($connectString, $self->{USER}, $self->{PASSWORD}, {'RaiseError' => 0, 'PrintError' => 0}) || 
	&throw(new W3C::Database::DBIInterface::ConnectException(-host => $host, -port => $port, -user => $self->{USER}, 
								  -password => $self->{PASSWORD} ? 'yes' : 'no', 
								  -connectString => $connectString));
    $self->{CONNECTIONS}{$hostPort} = $connection;
    return $connection;
}

#####
# addUpdateHost - add a(n array of) update host(s)

sub addUpdateHost {
    my ($self) = (shift);
    push(@{$self->{UPDATE_HOSTS}}, @_) if (defined $_[0]); # why do I need this?
}

#####
# prepareUpdateConnections - prepare connections for database updates.
#			     This is used to make sure that replicated databases
#			     are kept in sync.

sub prepareUpdateConnections {
    my ($self) = @_;
    foreach my $host (@{$self->{UPDATE_HOSTS}}) {
	if (!defined $self->{CONNECTIONS}{$host}) {
	    $self->connect($host);
	}
    }
#    return if ($#{$self->{CONNECTIONS}} >= $[);
#    my $connectionCount = $self->{REPLICATED} ? $#ServerList : 0;
#    for (my $serverNo = 0; $serverNo <= $connectionCount; $serverNo++) {
#	my $connection;
#	if ($serverNo == 0 && defined $self->{QUERY_CONNECTION}) {
#	    $connection = $self->{QUERY_CONNECTION};
#	} else {
#	    $connection->connect($ServerList[$serverNo]);
#	}
#	push(@{$self->{CONNECTIONS}}, $connection);
#    }
}

#####
# pass-through methods

#####
# escape

sub escape {
    my ($self, $str) = @_;
    return undef if (!defined $str);
    return $self->{QUERY_CONNECTION}->quote($str);
}

sub escapeWithNULL {
    my ($self, $str) = @_;
    return $self->{QUERY_CONNECTION}->quote($str);
}

#####
# unescape

sub unescape {
    my ($self, $str) = @_;
    return undef if (!defined $str);
    return $self->{QUERY_CONNECTION}->unquote($str);
}

#####
# disconnect - disconnect DBI CONNECTION

sub disconnect {
    my ($self) = @_;
    foreach my $host (keys %{$self->{CONNECTIONS}}) {
	$self->{CONNECTIONS}{$host}->disconnect;
	delete $self->{CONNECTIONS}{$host};
    }
}

#####
# executeQuery - execute SQL call that expects returned data
#		 This is analogous to the java.sql.Statement.executeQuery

sub executeQuery {
    my $self = shift;
    my $argCount = (ref $_[0]) ? $#_ : shift;
    my (@ret);
    for (my $i = 0; $i < $argCount; $i++) { # @@@ try @_[$[ , $argCount]
	push (@ret, shift);
    }
    my $qs = shift;
    my $sth = $self->{QUERY_CONNECTION}->prepare($qs); # @@@ try CONENCTION->do
    if (!$sth->execute) {
	$self->{ERRSTR} = $sth->errstr;
	&throw(new W3C::Database::DBIInterface::ExecutionException(-connection => $self->{QUERY_CONNECTION}, -query => $qs));
    }
    my $numRows = $sth->rows;
    for (my $i = 0; $i < $numRows; $i++) {
	my @line = $sth->fetchrow_array;
	my $idx = $line[0];
	foreach my $ret (@ret) {
	    push(@$ret, shift @line) if (ref($ret) eq 'ARRAY');
	    $$ret{$idx} = shift @line if (ref($ret) eq 'HASH');
	}
    }
    $sth->finish;
    return $numRows;
}

#####
# executeArrayQuery - executeQuery but put results in @ret[selected columns][table rows]

sub executeArrayQuery {
    my ($self, $ret, $qs) = @_;
    my $sth = $self->{QUERY_CONNECTION}->prepare($qs); # @@@ try CONENCTION->do
    if (!$sth->execute) {
	$self->{ERRSTR} = $sth->errstr;
	&throw(new W3C::Database::DBIInterface::ExecutionException(-connection => $self->{QUERY_CONNECTION}, -query => $qs));
    }
    my $numRows = $sth->rows;
    for (my $i = 0; $i < $numRows; $i++) {
	my @line = $sth->fetchrow_array;
	push(@$ret, \@line);
    }
    $sth->finish;
    return $numRows;
}

#####
# executeHashArrayQuery - executeQuery but put results in $ret{col1}[all col2...coln values]
# a 1 2
# a 3 4
# b 1 5
# ---
# $ret{'a'} = [1,2,3,4], $ret{'b'} = [1,5]

sub executeHashArrayQuery {
    my ($self, $ret, $qs) = @_;
    my $sth = $self->{QUERY_CONNECTION}->prepare($qs); # @@@ try CONENCTION->do
    if (!$sth->execute) {
	$self->{ERRSTR} = $sth->errstr;
	&throw(new W3C::Database::DBIInterface::ExecutionException(-connection => $self->{QUERY_CONNECTION}, -query => $qs));
    }
    my $numRows = $sth->rows;
    for (my $i = 0; $i < $numRows; $i++) {
	my @line = $sth->fetchrow_array;
	push(@{$$ret{$line[0]}}, @line[1..$#line]);
    }
    $sth->finish;
    return $numRows;
}

#####
# executeHashArrayArrayQuery - executeHashArrayQuery but put results in $ret{col1}[all col2...coln values]
# a 1 2
# a 3 4
# b 1 5
# ---
# $ret{'a'} = [[1,2],[3,4]], $ret{'b'} = [[1,5]]

sub executeHashArrayArrayQuery {
    my ($self, $ret, $qs) = @_;
    my $sth = $self->{QUERY_CONNECTION}->prepare($qs); # @@@ try CONENCTION->do
    if (!$sth->execute) {
	$self->{ERRSTR} = $sth->errstr;
	&throw(new W3C::Database::DBIInterface::ExecutionException(-connection => $self->{QUERY_CONNECTION}, -query => $qs));
    }
    my $numRows = $sth->rows;
    for (my $i = 0; $i < $numRows; $i++) {
	my @line = $sth->fetchrow_array;
	my $key = shift @line;
	push (@{$ret->{$key}}, [@line]);
    }
    $sth->finish;
    return $numRows;
}

#####
# executeWideQuery - like executeQuery except that all data goes into horizontal array
#

sub executeWideQuery {
    my ($self, $putHere, $qs) = @_;
    my $sth = $self->{QUERY_CONNECTION}->prepare($qs);
    $sth->execute;
    my $numRows = $sth->rows;
    @$putHere = $sth->fetchrow_array if ($numRows >= 1);
    return $numRows;
}

#####
# executeDerefWideQuery - like executeWideQuery except that all data goes 
# into the array of pointers
#

sub executeDerefedWideQuery {
    my ($self, $putHere, $qs) = (shift, shift, shift);
    my $sth = $self->{QUERY_CONNECTION}->prepare($qs);
    $sth->execute;
    my $numRows = $sth->rows;
    return $numRows if ($numRows != 1);
    my @results = $sth->fetchrow_array;
    foreach my $ptr (@$putHere) {
	$$ptr = shift @results;
    }
    return 1;
}

#####
# executeSingleQuery - common executeQuery macro to fetch X matching Y

sub executeSingleQuery {
    my ($self, $qs) = @_;
    my (@id, $rows);
    (($rows = $self->executeQuery(1, \@id, $qs)) == 1) && (return $id[0]);
    &throw(new W3C::Database::DBIInterface::SingleQueryException(-results => scalar $rows, -query => $qs));
}

sub getIdNUKE { # deprecated
    my $self = shift;
    $self->executeSingleQuery(shift);
}

#####
# count - common executeQuery macro to find count of some pattern

sub count {
    my ($self, $table, $where) = @_;
    my @count;
    $self->executeQuery(1, \@count, 'select count(*) from '.$table.' where '.$where);
    return $count[0];
}

#####
# executeUpdate1 - execute SQL call that expects returned data
#		   internal call that provides exception handling

sub executeUpdate1 {
    my ($self, $cmd, $flags) = @_;
    my ($ret, $newId);
    $self->prepareUpdateConnections;
    foreach my $host (@{$self->{UPDATE_HOSTS}}) {
	($self->{_DEBUG} || $Debugging) && (print $cmd."\n") && (next);
	my $connection = $self->{CONNECTIONS}{$host};
	my $sth = $connection->prepare($cmd);
	$ret = $sth->execute;
	$newId = $sth->{'mysql_insertid'};
	$newId = $sth->{'insertid'} if (!defined $newId);
	my $errstr = $self->{ERRSTR} = $sth->errstr;
	$self->{ROWS} = $sth->rows;
	$sth->finish;
	if ($self->{ERRSTR}) {
	    if ($errstr =~ m/\ADuplicate entry \'([^\']+)\' for key (\d+)\Z/) {
		if ($flags->{-ignoreDuplicateKeys}) {
		} else {
		    &throw(new W3C::Database::DBIInterface::DuplicateKeyException(-connection => $connection, 
										  -query => $cmd, -keyNumber => $2, 
										  -keyValue => $1, -error => $errstr));
		}
	    } elsif ($errstr =~ m/\AUnknown column \'([^\']+)\' in \'([^\']+)\'\Z/ && $2 eq 'field list') {
		&throw(new W3C::Database::DBIInterface::UnknownFieldException(-connection => $connection, -query => $cmd, 
									      -field => $1, -error => $errstr));
	    } else {
		&throw(new W3C::Database::DBIInterface::UnknownExceptionException(-connection => $connection, -query => $cmd, 
										  -errorStr => $errstr, -error => $errstr));
	    }
	} elsif (!$ret) {
	    &throw(new W3C::Database::DBIInterface::ExecutionException(-connection => $connection, 
								       -query => $cmd, -error => $errstr));
	}
    }
    return ($ret, $newId);
}

#####
# showCaller - handy tool to display function name and location of caller

sub showCaller {
    my ($backTrace) = @_;
    return @{[caller($backTrace + 1)]}[3].' ('.join(':',@{[caller($backTrace)]}[1,2]).')';
}

#####
# executeUpdate - execute SQL call that expects returned data
#		  This is analogous to the java.sql.Statement.executeUpdate
# @@@ - return id

sub executeUpdate {
    my ($self, $us, $flags) = @_;
    return $self->executeUpdate1($us, $flags);
}

sub executeUpdateWithID {
    my ($self, $us, $flags) = @_;
    my ($ret, $id) = $self->executeUpdate1($us, $flags);
    return $id;
}

#####
# createTable - create an SQL table

sub createTable {
    my ($self, $name, $tableDesc) = @_;
    return $self->executeUpdate1('create table '.$name.' ('.$tableDesc.')');
}

#####
# clearTable - empty an SQL table

sub clearTable {
    my ($self, $name) = @_;
    return $self->executeUpdate1('delete from '.$name);
}

#####
# dropTable - drop an SQL table

sub dropTable {
    my ($self, $name) = @_;
    return $self->executeUpdate1('drop table '.$name);
}

#####
# tableExists1 - deprecated

sub tableExists1 {
    my ($self, $name) = @_;
    my $sth = $self->{QUERY_CONNECTION}->prepare("select count(*) from $name");
    return $sth->execute;
}

#####
# tableExists

sub tableExists {
    my ($self, $name) = @_;
    my @tableList = $self->{QUERY_CONNECTION}->func( "_ListTables" );
    map {return $name if ($name eq $_);} @tableList;
    return 0;
}

#####
# Format Conversions

#####
# gmtimeToDateTime - convert result of call to gmtime to mysql datetime

sub gmtimeToDatetime {
    my ($self, @t) = @_;
    return $t[5].'-'.($t[4]+1).'-'.$t[3].' '.$t[2].':'.$t[1].':'.$t[0];
}

#####
# monthToStr

sub monthToStr {
    my ($self, $month) = @_;
    my %month = ('01' => 'Jan', 
		 '02' => 'Feb', 
		 '03' => 'Mar', 
		 '04' => 'Apr', 
		 '05' => 'May', 
		 '06' => 'Jun', 
		 '07' => 'Jul', 
		 '08' => 'Aug', 
		 '09' => 'Sep', 
		 '10' => 'Oct', 
		 '11' => 'Nov', 
		 '12' => 'Dec'
		 );
    return $month{$month};
}

sub dateToStr {
    my ($self, $t) = @_;
    my ($year, $month, $date) = split('-', $t);
    return $self->monthToStr($month).' '.$date.', '.$year;
}

#####
# dateToGmtime - converts a date to a gmtime
#               Only stores the year, month, and day

sub dateToGmtime {
    my ($self, $t) = @_;
    my ($year, $month, $date) = split('-', $t);
    my @gmtime;
    for (my $i=0;$i<9;$i++) {
	$gmtime[$i]=0;
    }
    $gmtime[5] = $year - 1900;
    $gmtime[4] = $month - 1;
    $gmtime[3] = $date;
    return \@gmtime;
}

#####
# mysqltimeToGmtime - converts a date to a gmtime
#               Only stores the year, month, and day

sub mysqltimeToGmtime {
    my ($self, $t) = @_;
    my ($year, $month, $date) = split('-', $t);
    my @gmtime;
    ($gmtime[5],$gmtime[4],$gmtime[3],$gmtime[2],$gmtime[1],$gmtime[0]) = unpack('A4A2A2A2A2A2', $t);
    $gmtime[5] -= 1900;
    $gmtime[4] -= 1;
    for (my $i=6;$i<9;$i++) {
	$gmtime[$i]=0;
    }
    return \@gmtime;
}

sub mysqlTimeToUnixTime {
    my ($self, $t) = @_;
    my @gmtime;
    ($gmtime[5],$gmtime[4],$gmtime[3],$gmtime[2],$gmtime[1],$gmtime[0]) = unpack('A4A2A2A2A2A2', $t);
    $gmtime[5] -= 1900;
    $gmtime[4] -= 1;
    for (my $i=6;$i<9;$i++) {
	$gmtime[$i]=0;
    }
    return POSIX::mktime($gmtime[0],$gmtime[1],$gmtime[2],$gmtime[3],$gmtime[4],$gmtime[5]) ;
}

sub dateTimeToStr {
    my ($self, $dateTime) = @_;
    my ($y, $m, $d, $h, $n, $s) = $dateTime =~ /\A(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)\Z/;
    return join(' ', $self->monthToStr($m), $d, $y, join(':', $h, $n, $s));
}

#sub strToDate {
#    my ($self, $dateTime) = @_;
#    my ($y, $m, $d, $h, $n, $s) = $dateTime =~ /\A(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)\Z/;
#    return join(' ', $self->monthToStr($m), $d, $y, join(':', $h, $n, $s));
#}

#####
# gmtimeCompare - compares two gmtimes, t1 and t2
#                returns 1 if t1>t2, 0 if t1=t2, and -1 if t1<t2

sub gmtimeCompare {
    my ($self, $t1, $t2) = @_;
    my $i = 5;
    my @gmT1 = @$t1;
    my @gmT2 = @$t2;
    while ($gmT1[$i] == $gmT2[$i] && $i>0) { $i--; }
    return ($gmT1[$i] <=> $gmT2[$i]);
}

#####
# getTypeName - get the mySQL name for a type and a maxlength

sub getTypeName {
    my ($self, $test, $maxlength) = @_;
    my $ret;

    if ($test =~ /^select$/) {
	$ret = $maxlength ? "char($maxlength)" : 'varchar(20)';
    } elsif ($test =~ /^boolean$/) {
	$ret = "char(1)";
    } else { # default everything to text
	$ret = $maxlength ? "varchar($maxlength)" : 'varchar(40)';
    }
}

#####
# direct access methods

#####
# connection - set/get the current connection

sub connection {
    my $self = shift;
    if (@_) { $self->{QUERY_CONNECTION} = shift }
    return $self->{QUERY_CONNECTION};
}

#####
# errstr - get/set errstr

sub errstr {
    my $self = shift;
    if (@_) { $self->{ERRSTR} = shift }
    return $self->{ERRSTR};
}

#####
# debug - cannonical debugging stuff from
# http://www.perl.com/CPAN-local/doc/manual/html/pod/perltoot/Debuging_Methods.html

sub debug {
    my $self = shift;
    warn "usage: thing->debug(level)"    unless @_ == 1;
    my $level = shift;
    if (ref($self))  {
	$self->{"_DEBUG"} = $level;         # just myself
    } else {
	$Debugging        = $level;         # whole class
    }
}

#####
# DESTROY - hook to display debugging info

sub DESTROY {
    my ($self) = @_;
    if ($Debugging || $self->{"_DEBUG"}) {
	print STDERR "Destroying $self " . $self->name;
    }
    -- ${ $self->{"_OUTSTANDING"} };
}

#####
# END - hook to display debugging info

sub END {
    if ($Debugging) {
	print "All DBIInterfaces are going away now.\n";
    }
}

# DBIRef - Convenience package to allow multiple objects to use the same 
# DBIInterface. The first one create the DBIInterface and the next ones
# just point to the first one.

package W3C::Database::DBIRef;
use W3C::Util::Exception;

sub new {
    my ($proto, $ref) = @_;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);
    if ($ref->isa(qw(W3C::Util::Properties))) {
	$self->{DB} = new W3C::Database::DBIInterface($ref);
    } elsif ($ref->isa(qw(W3C::Database::DBIRef))) {
	$self->{DB} = $ref->{DB};
    } else {
	&throw(new W3C::Util::Exception(-message => 'bad constructor argument type :"'.$ref.'"'));
    }
    return $self;
} 

# these functions were written with a simple emacs macro:
#sub new {my $self = shift; return $self->{DB}->new(@_);}
sub connect {my $self = shift; return $self->{DB}->connect(@_);}
sub addUpdateHost {my $self = shift; return $self->{DB}->addUpdateHost(@_);}
sub prepareUpdateConnections {my $self = shift; return $self->{DB}->prepareUpdateConnections(@_);}
sub escape {my $self = shift; return $self->{DB}->escape(@_);}
sub escapeWithNULL {my $self = shift; return $self->{DB}->escapeWithNULL(@_);}
sub unescape {my $self = shift; return $self->{DB}->unescape(@_);}
sub disconnect {my $self = shift; return $self->{DB}->disconnect(@_);}
sub executeQuery {my $self = shift; return $self->{DB}->executeQuery(@_);}
sub executeArrayQuery {my $self = shift; return $self->{DB}->executeArrayQuery(@_);}
sub executeHashArrayQuery {my $self = shift; return $self->{DB}->executeHashArrayQuery(@_);}
sub executeWideQuery {my $self = shift; return $self->{DB}->executeWideQuery(@_);}
sub executeDerefedWideQuery {my $self = shift; return $self->{DB}->executeDerefedWideQuery(@_);}
sub executeSingleQuery {my $self = shift; return $self->{DB}->executeSingleQuery(@_);}
sub getIdNUKE {my $self = shift; return $self->{DB}->getIdNUKE(@_);}
sub count {my $self = shift; return $self->{DB}->count(@_);}
sub executeUpdate1 {my $self = shift; return $self->{DB}->executeUpdate1(@_);}
sub showCaller {my $self = shift; return $self->{DB}->showCaller(@_);}
sub executeUpdate {my $self = shift; return $self->{DB}->executeUpdate(@_);}
sub executeUpdateWithID {my $self = shift; return $self->{DB}->executeUpdateWithID(@_);}
sub createTable {my $self = shift; return $self->{DB}->createTable(@_);}
sub clearTable {my $self = shift; return $self->{DB}->clearTable(@_);}
sub dropTable {my $self = shift; return $self->{DB}->dropTable(@_);}
sub tableExists1 {my $self = shift; return $self->{DB}->tableExists1(@_);}
sub tableExists {my $self = shift; return $self->{DB}->tableExists(@_);}
sub gmtimeToDatetime {my $self = shift; return $self->{DB}->gmtimeToDatetime(@_);}
sub monthToStr {my $self = shift; return $self->{DB}->monthToStr(@_);}
sub dateToStr {my $self = shift; return $self->{DB}->dateToStr(@_);}
sub dateToGmtime {my $self = shift; return $self->{DB}->dateToGmtime(@_);}
sub mysqltimeToGmtime {my $self = shift; return $self->{DB}->mysqltimeToGmtime(@_);}
sub dateTimeToStr {my $self = shift; return $self->{DB}->dateTimeToStr(@_);}
sub gmtimeCompare {my $self = shift; return $self->{DB}->gmtimeCompare(@_);}
sub getTypeName {my $self = shift; return $self->{DB}->getTypeName(@_);}
sub connection {my $self = shift; return $self->{DB}->connection(@_);}
sub errstr {my $self = shift; return $self->{DB}->errstr(@_);}

package W3C::Database::DBIHandle;
@W3C::Database::DBIHandle::ISA = ('W3C::Database::DBStreamHandle');
sub new {
    my ($proto, $connectStr, $user, $passwd) = @_;
    my $class = ref($proto) || $proto;
    my $self  = $class->SUPER::new(@_[4,$#_]);
    bless ($self, $class);
    my ($driver, $db, $host, $port, $qs) = split(':', $connectStr, 5);
    my $props = new W3C::Util::Properties({'user'=>$user, 'password'=>$passwd, 'database'=>$db, 'queryHost'=>$host});
    $self->{DB} = new W3C::Database::DBIInterface($props);
    $self->{QS} = $qs;
    $self->{DATA} = [];
    return $self;
}

sub forEach {
    my ($self, $sink) = @_;
    $self->getColumns($self->{QS});
    $self->{DB}->executeArrayQuery($self->{DATA}, $self->{QS});
    $self->{DB}->disconnect;
    foreach my $row (@{$self->{DATA}}) {
#	$sink->put($row->[0], @{$row}[1..$#$row]);
	$self->{SINK}->put(@$row);
    }
}

sub getColumns {
    my ($self, $qs) = @_;
    $qs =~ m/ \G select \s+ (.*)? \s+ from /gcxsi || return &parseError($$qs);
    $self->{FIELDS} = [split('\s*,\s*', $1)];
}

sub parseError {
    my ($pStr) = @_;
    return 'Could not parse "'.substr($$pStr, pos $$pStr, 40).'"';
}

package W3C::Database::DBIInterface;

1;

__END__

=head1 NAME

W3C::Database::DBIInterface - DBStreamHandle to talk to perls DBI interface

=head1 SYNOPSIS

see ddb.pl

=head1 DESCRIPTION

This module is part of the W3C::Database CPAN module.

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut
