########################################################################
package DBI;
########################################################################
#
# Copyright (c) 2002  Tim Bunce  Ireland.
#
# See COPYRIGHT section in DBI.pm for usage and distribution rights.
#
########################################################################
#
# Please send patches and bug reports to
#
# Jeff Zucker <jeff@vpservices.com>  with cc to <dbi-dev@perl.org>
#
########################################################################
#
# Comments starting with '#z' are Jeff's (as are all mistakes :-)
#
########################################################################

use strict;
use Carp;

$DBI::PurePerl=1;
$DBI::PurePerl::VERSION = '0.0004';

my $trace = $ENV{"DBI_TRACE"} || 0;
*TFH = \*STDERR;

warn __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n";

use constant SQL_ALL_TYPES => 0;
use constant SQL_ARRAY => 50;
use constant SQL_ARRAY_LOCATOR => 51;
use constant SQL_BINARY => (-2);
use constant SQL_BIT => (-7);
use constant SQL_BLOB => 30;
use constant SQL_BLOB_LOCATOR => 31;
use constant SQL_BOOLEAN => 16;
use constant SQL_CHAR => 1;
use constant SQL_CLOB => 40;
use constant SQL_CLOB_LOCATOR => 41;
use constant SQL_DATE => 9;
use constant SQL_DATETIME => 9;
use constant SQL_DECIMAL => 3;
use constant SQL_DOUBLE => 8;
use constant SQL_FLOAT => 6;
use constant SQL_GUID => (-11);
use constant SQL_INTEGER => 4;
use constant SQL_INTERVAL => 10;
use constant SQL_INTERVAL_DAY => 103;
use constant SQL_INTERVAL_DAY_TO_HOUR => 108;
use constant SQL_INTERVAL_DAY_TO_MINUTE => 109;
use constant SQL_INTERVAL_DAY_TO_SECOND => 110;
use constant SQL_INTERVAL_HOUR => 104;
use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111;
use constant SQL_INTERVAL_HOUR_TO_SECOND => 112;
use constant SQL_INTERVAL_MINUTE => 105;
use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113;
use constant SQL_INTERVAL_MONTH => 102;
use constant SQL_INTERVAL_SECOND => 106;
use constant SQL_INTERVAL_YEAR => 101;
use constant SQL_INTERVAL_YEAR_TO_MONTH => 107;
use constant SQL_LONGVARBINARY => (-4);
use constant SQL_LONGVARCHAR => (-1);
use constant SQL_MULTISET => 55;
use constant SQL_MULTISET_LOCATOR => 56;
use constant SQL_NUMERIC => 2;
use constant SQL_REAL => 7;
use constant SQL_REF => 20;
use constant SQL_ROW => 19;
use constant SQL_SMALLINT => 5;
use constant SQL_TIME => 10;
use constant SQL_TIMESTAMP => 11;
use constant SQL_TINYINT => (-6);
use constant SQL_TYPE_DATE => 91;
use constant SQL_TYPE_TIME => 92;
use constant SQL_TYPE_TIMESTAMP => 93;
use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95;
use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94;
use constant SQL_UDT => 17;
use constant SQL_UDT_LOCATOR => 18;
use constant SQL_UNKNOWN_TYPE => 0;
use constant SQL_VARBINARY => (-3);
use constant SQL_VARCHAR => 12;
use constant SQL_WCHAR => (-8);
use constant SQL_WLONGVARCHAR => (-10);
use constant SQL_WVARCHAR => (-9);

use constant IMA_HAS_USAGE	=> 0x0001; #/* check parameter usage	*/
use constant IMA_FUNC_REDIRECT	=> 0x0002; #/* is $h->func(..., "method")*/
use constant IMA_KEEP_ERR	=> 0x0004; #/* don't reset err & errstr	*/
use constant IMA_spare		=> 0x0008; #/* */
use constant IMA_NO_TAINT_IN   	=> 0x0010; #/* don't check for tainted args*/
use constant IMA_NO_TAINT_OUT   => 0x0020; #/* don't taint results	*/
use constant IMA_COPY_STMT   	=> 0x0040; #/* copy sth Statement to dbh */
use constant IMA_END_WORK	=> 0x0080; #/* set on commit & rollback	*/
use constant IMA_STUB		=> 0x0100; #/* donothing eg $dbh->connected */

my %is_valid_attribute = map {$_ =>1 } qw(
    CompatMode  Warn  Active  InactiveDestroy  FetchHashKeyName  RootClass
    RowCacheSize  ChopBlanks  LongReadLen  LongTruncOk  RaiseError  PrintError
    HandleError  ShowErrorStatement  MultiThread  Taint  CachedKids  AutoCommit
    BegunWork  TraceLevel  NUM_OF_FIELDS  NUM_OF_PARAMS Attribution Version
    ImplementorClass Kids ActiveKids DebugDispatch Driver Statement Database
    Name
);

#z These are needed to allow drivers to set their private attributes
#  DBI/t/*.t tests missed the fact that it's needed
#
my %is_valid_driver_prefix = map {$_ =>1 } qw(
  ad  ado  best  csv  db2  f  file  ib  ing  ix  msql  mysql  odbc
  ora  pg  proxy  rdb  sapdb  solid  syb  tdat  tuber  uni  xbase
  sprite
);
sub valid_attribute {
    my $attr = shift;
    return 1 if $is_valid_attribute{$attr};
    $attr =~ /^([^_]+)_.*/;
    return 1 if $is_valid_driver_prefix{$1};
    return 0
}

sub  _install_method {
    my ( $caller, $method, $from, $param_hash ) = @_;
    my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/;
    my $bitmask = $param_hash->{'O'};
    my ( $keep_err, $is_destroy );
    no strict qw(refs);
    *$method = sub {
        my $h = $_[0];
        my $imp;
        eval { $imp = $h->{"ImplementorClass"} if $h; };
        return unless defined $imp;
        if ( $method_name eq 'STORE' and ($class eq 'db' or $class eq 'dr')) {
            my($h,$key,$value)=@_;
	    if ($key =~ /[A-X]/ and !valid_attribute($key)) {
	        croak sprintf
               "Can't set %s->{%s}: unrecognised attribute or invalid value%s",
                $key,$value;
            }
  	    if ( $key eq 'AutoCommit' ) {

              # catch the DBD's failure on AutoCommit=0
              # failure to do this was not caught by DBI/t*
              #
	      if ($value == 0 and my $tmp=$imp->can('STORE')) {
                    eval {
                        &$tmp($h,$key,$value);
                    };
                    croak $@ if $@;
                    $h->{$key}=0 if $h->{$key}==-900;
                    return $value;
	      }
              return $h->{$key}=$value;
	    }
        }
        if ( $method_name eq 'FETCH' and ($class eq 'db' or $class eq 'dr')) {
            my($h,$key)=@_;
  	    if ( $key =~ /errstr/ and $class eq 'db') {
                return $DBI::errstr;
	    }
	    if ($key =~ /[A-X]/ and !valid_attribute($key)) {
	        croak sprintf "Can't get %s: unrecognised attribute",$key;
            }
        }
        if ( $method_name eq 'begin_work') {
            $h->{'BegunWork'}=1;
            $h->{'AutoCommit'}=-900;
        }
        if ( $bitmask ) {
            if ( IMA_STUB & $bitmask ) {
                return;
            }
            if ( IMA_KEEP_ERR & $bitmask ) {
                $keep_err = 1;
            }
            if ( IMA_FUNC_REDIRECT & $bitmask ) {
                my $func = pop @_;
                $imp =~ s/^(.*)::[^:]+$/$1/;
                $method_name = $imp.'::db::'.$func;
	    }
            if ( IMA_COPY_STMT & $bitmask ) {
                $h->{'Database'}->STORE('Statement',$h->{'Statement'});
            }
            if ( IMA_END_WORK & $bitmask ) {
                $h->{'BegunWork'}=0;
                $h->{'AutoCommit'}=-900;
                if ( scalar(@_) > 1 ) {
	            croak sprintf
		        "DBI %s: invalid number of parameters: handle + %ld\n",
   		        $method_name, @_-1;
	        }
	    }
        }
        if ( !$keep_err ) {
            $h->{'err'}=0;
            $h->{'errstr'}='';
            $h->{'state'}='';
        }
        printf TFH "    > $method_name(@_)\n" if $trace;
        my $sub = $imp->can($method_name)
            or croak "Can't find $method_name method for $h";
	my @ret;

        #z HANDLE NESTED METHODS
        #  sort of what class_depth does in DBI.xs
        #
        $DBI::PurePerl::var->{'last_method'} = $method_name
             if $method_name !~ /^(FETCH|STORE|DESTROY|_set_fbav|set_err)$/;

        (wantarray) ? (@ret = &$sub(@_)) : (@ret = scalar &$sub(@_));
        if ($h->{'err'} and !$keep_err){
            my $mimp = "$method_name";

            # HANDLE NESTED METHOD FAILURES
            my $last = $DBI::PurePerl::var->{'last_method'};
            $mimp =~ s/STORE/$last/ if $last;

            my $estr = $h->{'errstr'}  || $DBI::errstr || 'No Message :-(';
            my $msg = sprintf "$imp $mimp failed: $estr\n";
            if ($h->{'Statement'} and $h->{'ShowErrorStatement'}) {
               $msg .= " for [\"".$h->{'Statement'}."\"]";
               $DBI::errstr=$msg;
	    }
            my $do_croak=1;
            if (my $subsub = $h->{'HandleError'}) {
                my @hret;
                my $first_val = $ret[0];
                (wantarray)
                ? (@hret = &$subsub($msg,$h,$first_val))
                : (@hret = scalar &$subsub($msg,$h,$first_val));
 	        if (@hret > 1 or $hret[0]) {
                    @ret = ($first_val);
                    $do_croak=0;
                }
            }
	    if ($do_croak) {
  	        carp  $msg if $h->{"PrintError"};
	        croak $msg if $h->{"RaiseError"};
	    }
	}
	return (wantarray) ? @ret : $ret[0];
    }
}

sub _setup_handle {
    my($h, $imp_class, $parent, $imp_data) = @_;

    #z SAVE DRIVER ATTRIBS FROM $drh
    if ( ref($h) =~ /^[^:]+::dr/ ) {
        for (qw(Name Version Attribution)) {
            $DBI::PurePerl::var->{Driver}->{$_} = $h->{$_} ;
        }
    }
    #z ADD DRIVER ATTRIBS TO $dbh
    if ( $DBI::PurePerl::var->{'Driver'} and ref($h) =~ /^[^:]+::db/ ){
        for (qw(Name Version Attribution)) {
            $h->{'Driver'}->{$_} = $DBI::PurePerl::var->{'Driver'}->{$_};
        }
        delete $DBI::PurePerl::var->{Driver};
    }
    $h->{"imp_data"} = $imp_data;
    $h->{"ImplementorClass"} = $imp_class;
    $h->{"Active"} = 1;
    $h->{"FetchHashKeyName"} ||= $parent->{"FetchHashKeyName"} if $parent;
    $h->{"FetchHashKeyName"} ||= 'NAME';
    $h->{"PrintError"}=1 unless defined $h->{"PrintError"};
    $h->{"Taint"}=1 unless defined $h->{"Taint"};
    $h->{"Warn"} = 1 unless defined $h->{"Warn"};
    $h->{"state"} = '' unless defined $h->{"state"};
    if ($parent and ref($parent) =~ /^[^:]+::db/ and ref($h) =~ /^[^:]+::st/){
        $h->STORE('RaiseError',$parent->{'RaiseError'});
        $h->STORE('PrintError',$parent->{'PrintError'});
        $h->STORE('HandleError',$parent->{'HandleError'});
        $h->STORE('Database',$parent);
        $parent->STORE('Statement',$h->{'Statement'}); #z but change on execute
    }
    #z
    #  THIS LINE DOES NOTHING EXCEPT KEEP THE HANDLE ALIVE.
    #  THERE IS NO OTHER REFERENCE TO frump  BUT IF YOU
    #  REMOVE IT examp.t ERRORS WILL NOT PROPOGATE TO $@
    #
    $DBI::PurePerl::frump = $h;
}
sub constant {
    warn "constant @_"; return;
}
sub trace {
    my ($h,$level, $file) = @_;
    my $old_level = $level;
    if (defined $level) {
	$trace = $level;
	print TFH "    DBI $DBI::VERSION (PurePerl) "
                . "dispatch trace level set to $level\n";
        if ($level==0 and fileno(TFH)) {
  	    close(TFH);
	    *TFH = \*STDERR;
	    return 1;
        }
    }
    _set_trace_file($file);# if defined $file;
    return $old_level;
}
sub _set_trace_file {
    my ($file) = @_;
    return unless defined $file;
    unless ($file) {
	close(TFH) if fileno(TFH) != fileno(STDERR);
	*TFH = \*STDERR;
	return 1;
    }
    open TFH, ">>$file";
    select((select(TFH), $| = 1)[0]);
    return 1;
}
sub _get_imp_data {  shift->{"imp_data"}; }
sub _handles      {  my $h = shift;   return ($h,$h); }  #z :-)
sub _svdump       { }
sub dump_handle   { my $h = shift; warn join "\n", %$h; }

#z Patch from John Tobey
#
sub hash {
    my ($key, $type) = @_;
    my ($hash);

    if ($type == 0) {
        $hash = 0;
        # XXX The C version uses the "char" type, which could be either
        # signed or unsigned.  I use signed because so do the two
        # compilers on my system.
        for my $char (unpack ("c*", $key)) {
            $hash = $hash * 33 + $char;
        }
        $hash &= 0x7FFFFFFF;    # limit to 31 bits
        $hash |= 0x40000000;    # set bit 31
        return -$hash;          # return negative int
    }
    elsif ($type == 1) {        # Fowler/Noll/Vo hash
        # see http://www.isthe.com/chongo/tech/comp/fnv/
        require Math::BigInt;   # feel free to reimplement w/o BigInt
        $hash = Math::BigInt->new(0x811c9dc5);
        for my $uchar (unpack ("C*", $key)) {
            # multiply by the 32 bit FNV magic prime mod 2^64
            $hash = ($hash * 0x01000193) & 0xffffffff;
            # xor the bottom with the current octet
            $hash ^= $uchar;
        }
        # cast to int
        return unpack "i", pack "i", $hash;
    }
    else {
        croak("bad hash type $type");
    }
}
sub looks_like_number {
    my @new = ();
    for my $thing(@_) {
        if (!defined $thing or $thing eq '') {
            push @new, undef;
        }
        # magic from Randal
	elsif ( ($thing & ~ $thing) eq "0") {
            push @new, 1;
	}
        else {
	    push @new, 0;
	}
    }
    return (@_ >1) ? @new : $new[0];
}
sub neat {
    my $v = shift;
    my $maxlen = shift;
    return "undef" unless defined $v;
    return $v      if looks_like_number($v);
    my $newv = substr($v,0,$maxlen-5) if $maxlen;

    # John Tobey patch
    #
    if ($maxlen and $maxlen < length($v) + 2) {
        $v = substr($v,0,$maxlen-5);
        $v .= '...';
    }
    return "'$v'";
}

package DBI::var;              # ============ DBI::var

sub FETCH {
    my($key)=shift;
    return $DBI::err     if $$key eq '*err';
    return $DBI::errstr  if $$key eq '&errstr';
    if ($$key eq '"state'){
        my $state = $DBI::state;
        return $state if $state;
        return '' unless defined $state;
        if (!$state) {
            $state= ($DBI::err) ? "S1000" : "00000";
        }
        return $state;
    }
}

package DBD::var;		# ============ DBD::var

sub FETCH {
    die "DBD::var::FETCH @_";
}

package DBD::_::common;		# ============ DBD::_::common

# sub preparse { die "Preparse not implented in " . __FILE__ . "\n"; }

sub trace {	# XXX should set per-handle level, not global
    my ($h, $level, $file) = @_;
    my $old_level = $level;
    if (defined $level) {
	$trace = $level;
	printf TFH
            "    %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n",
	    $h, $level if $file;
    }
    _set_trace_file($file) if defined $file;
    return $old_level;
}
*debug = \&trace; *debug = \&trace; # twice to avoid typo warning

sub FETCH {
    my($h,$key)= @_;
    if (!$h->{$key} and $key =~ /^NAME_.c$/) {
        my $cols = $h->FETCH('NAME');
        return undef unless $cols;
        my @lcols = map { lc $_ } @$cols;
        $h->STORE('NAME_lc', \@lcols);
        my @ucols = map { uc $_ } @$cols;
        $h->STORE('NAME_uc',\@ucols);
        return $h->FETCH($key);
    }
    if (!$h->{$key} and $key =~ /^NAME.*_hash$/) {
        my $i=0;
        for my $c(@{$h->FETCH('NAME')}) {
            $h->{'NAME_hash'}->{$c}    = $i;
            $h->{'NAME_lc_hash'}->{"\L$c"} = $i;
            $h->{'NAME_uc_hash'}->{"\U$c"} = $i;
            $i++;
        }
    }
    return $h->{$key};
}
sub STORE {
    my($h,$key,$value)= @_;
    $h->{$key} = $value;
}
sub err {
    my $h = shift;
    # XXX need to be shared between dbh and sth
    my $err = $h->{'err'} || $h->{'errstr'};
    $h->{'Database'}->{'err'} = $err if $h->{'Database'};
    return $err;
}
sub errstr {
    my $h = shift;
    my $errstr = $h->{'errstr'} || ''; # $h->{'err'}; caught in DBD-CSV
    $h->{'Database'}->{'errstr'} = $errstr if $h->{'Database'};
    return $errstr;
}
sub state {
    #z DOESN'T SEEM TO EVER BE CALLED
    my $h = shift;
    my $state = $h->{'state'};
    return $state if defined $state and $state eq '' and !$h->err;
    if (!$state) {
        $state= ($h->err) ? "S1000" : "00000";
    }
    $h->{'Database'}->{'state'} = $state if $h->{'Database'};
    return $state;
}
sub event {
    # do nothing
}
sub set_err {
    my($h,$errnum,$msg,$state,$method, $rv)=@_;
    $h->{'Database'}->{'errstr'} = $msg if $h->{'Database'};
    $DBI::errstr = $msg;
    $DBI::state  = $state if defined $state;
    $h->{'state'}=$state if defined $state;
    $msg = $errnum unless defined $msg;
    $h->{'errstr'}=$msg;
    $h->{'err'} = $errnum;
    $DBI::err    = $errnum || undef;
    return $rv if $rv;
    return undef;
}
sub trace_msg {
    my($h,$msg,$minlevel)=@_;
    $minlevel = 1 unless defined $minlevel;
    $trace    = 0 unless defined $trace;
    return if $trace < $minlevel;
    print TFH $msg;
    return 1;
}
sub private_data {
    warn "private_data @_";
}
sub rows {
    return -1; # always returns -1 here, see DBD::_::st::rows below
}
sub DESTROY {}

package DBD::_::st;		# ============ DBD::_::st

sub fetchrow_arrayref	{
    my $h = shift;
    # if we're here then driver hasn't implemented fetch/fetchrow_arrayref
    # so we assume they've implemented fetchrow_array and call that instead
    my @row = $h->fetchrow_array or return;
    return $h->_set_fbav(\@row);
}
# twice to avoid typo warning
*fetch = \&fetchrow_arrayref;  *fetch = \&fetchrow_arrayref;

sub fetchrow_array	{
    my $h = shift;
    # if we're here then driver hasn't implemented fetchrow_array
    # so we assume they've implemented fetch/fetchrow_arrayref
    my $row = $h->fetch or return;
    return @$row;
}
#z The DBI/t/* tests missed a typo on fetchrow
# twice to avoid typo warning
*fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array;

sub fetchrow_hashref {
    my $h         = shift;
    my $FetchCase = shift;
    my $row       = $h->fetch or return;
    my $rowhash;
    my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME';
    @$rowhash{@{$h->{$FetchHashKeyName}}}=@$row;
    return $rowhash;
}
sub dbih_setup_fbav {
    my $h = shift;
    return $h->{'_fbav'} || do {
        $DBI::PurePerl::var->{rows} = $h->{'_rows'} = 0;
        my $fields = $h->{'NUM_OF_FIELDS'}
                  or DBI::croak("NUM_OF_FIELDS not set");
        my @row = (undef) x $fields;
        \@row;
    };
}
sub _get_fbav {
    my $h = shift;
    my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h);
    ++$h->{'_rows'} unless $h->{'_bound_cols'};
    return $av;
}
sub _set_fbav {
    my $h = shift;
    my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h);
    my $row = shift;
    if (my $bc = $h->{'_bound_cols'}) {
        for my $i (0..@$row-1) {
            my $bound = $bc->[$i];
            $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i];
        }
    }
    else {
        @$fbav = @$row;
        $DBI::PurePerl::var->{rows} = ++$h->{'_rows'};
    }
    return $fbav;
}
sub bind_col {
    my ($h, $col, $value_ref,$from_bind_columns) = @_;
    $col-- unless $from_bind_columns; #z fix later
    DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar")
	unless ref $value_ref eq 'SCALAR';
    my $fbav = $h->_get_fbav;
    $h->{'_bound_cols'}->[$col] = $value_ref;
    return 1;
}
sub bind_columns {
    my $h = shift;
    shift if !defined $_[0] or ref $_[0] eq 'HASH'; # old style args
    my $fbav = $h->_get_fbav;
    DBI::croak("bind_columns called with wrong number of args")
	if @_ != @$fbav;
    foreach (0..@_-1) {
        $h->bind_col($_, $_[$_],'from_bind_columns')
      }
    return 1;
}
sub finish {
    my $h = shift;
    $h->{'_rows'} = undef;
    $h->{'_fbav'} = undef;
    $h->{'Active'} = 0;
    return 1;
}
sub rows {
    my $h = shift;
    my $rows = $h->{'_rows'} || $DBI::PurePerl::var->{rows};
    return -1 unless defined $rows;
    return $rows;
}
1;
__END__