########################################################################
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;
my $trace = $ENV{DBI_TRACE} || 0;
*TFH = \*STDERR;

warn __FILE__;

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 */

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";
    }
    _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  _install_method {
    my ( $caller, $method, $from, $param_hash ) = @_;
    my ($class, $method_name) = $method =~ /DBI::(.+)::(.+)$/;
    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 'DESTROY') {
            $is_destroy = 1;
            $keep_err   = 1;
        }
        if ( $method_name eq 'STORE') {
            my($h,$key,$value)=@_;
  	    if ( $key eq 'errstr' ) {
                $h->{Database}->{errstr} = $value;
	    }
        }
        if ( $method_name eq 'FETCH' and $class eq 'db') {
            my($h,$key)=@_;
  	    if ( $key eq 'AutoCommit' ) {
                return ($h->{$key}) ? 1 : 0;
	    }
  	    if ( $key =~ /errstr/ ) {
                return $DBI::errstr;
	    }
        }
        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;
                if ( scalar(@_) > 1 ) {
	            my $msg = sprintf
		          "DBI %s: invalid number of parameters: handle + %ld\n",
   		          $method_name, @_-1;
		    croak $msg;
	        }
	    }
        }
        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;
        (wantarray) ? (@ret = &$sub(@_)) : (@ret = scalar &$sub(@_));
        if ($h->{err} and !$keep_err){
            my $estr = $h->{errstr}  || $DBI::errstr || 'No Message :-(';
            my $msg = sprintf "$method failed: $estr\n";
            if ($h->{Statement} and $h->{ShowErrorStatement}) {
               $msg .= " for [".$h->{Statement}."]";
	     }
             if (my $subsub = $h->{HandleError}) {
                 my $rv = &$subsub($msg,@_);
                 return $rv if $rv;
             }
	     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) = @_;
    if ( ref($h) =~ /DBI::db/ ) {
      $h->{Taint}      = $DBI::PurePerl::lasth->{Taint} ;
      $h->{PrintError} = $DBI::PurePerl::lasth->{PrintError} ;
      $h->{RaiseError} = $DBI::PurePerl::lasth->{RaiseError} ;
      $h->{Driver}->{Name} = $DBI::PurePerl::lasth->{Name} ;
    }
    $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) =~ /DBI::db/ and ref($h) =~ /DBI::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}); # but change on execute
    }
    $DBI::PurePerl::lasth = $h;
}

sub _svdump { }
sub dump_handle { my $h = shift; warn join "\n", %$h; }
sub hash {
    my ($key, $type) = @_;
    die "hash not supported by ".__FILE__;
}
sub looks_like_number {
    my @new = ();
    for my $thing(@_) {
        if (!defined $thing or $thing eq '') {
            push @new, undef;
        }
        elsif ($thing =~ m/^[+-]?(?:(?:\.\d+)|(?:\d+\.?\d*))(?:[eE][+-]?\d+)?/        ) {
            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;
   $newv .= '...' if( $maxlen and $maxlen < length $v);
   return "'$newv'";
}

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

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

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

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};
    $h->{Database}->{errstr} = $errstr if $h->{Database};
    return $errstr;
}
sub state {
    my $h = shift;
    my $state = $h->{state};

    #z when should "" be returned?
    #
    return $state if defined $state and $state eq '' and !$h->err;
    $state ||= $DBI::state;
    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)=@_;
    $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;
    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 DBI::var;

sub STORE_PP {
    my($key,$value)=@_;
    if ($$key eq '!lasth' ) {
        return $DBI::PurePerl::lasth = $value;
    }
    if ($$key eq '*err' ) {
        return $DBI::PurePerl::lasth->{err} = $value;
    }
    if ($$key eq '&errstr' ) {
        return $DBI::PurePerl::lasth->{errstr} = $value;
    }
    if ($$key eq '"state' ) {
        return $DBI::PurePerl::lasth->{state} = $value;
    }
    Carp::croak("Can't modify \$DBI::$$key special variable") ;
}

sub FETCH {
    my($key)=shift;
    return $DBI::PurePerl::lasth if $$key eq '!lasth';
    return $DBI::PurePerl::lasth->state if $$key eq '"state';
    return $DBI::PurePerl::lasth->{err}   if $$key eq '*err';
    return $DBI::errstr || $DBI::PurePerl::lasth->errstr if $$key eq '&errstr';
}


package DBD::_::st;		# ============ 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);
}
*fetch = \&fetchrow_arrayref;  *fetch = \&fetchrow_arrayref; # twice to avoid typo warning

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;
}
*fetchrows = \&fetchrow_array; *fetchrows = \&fetchrow_array; # twice to avoid typo warning

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 {
	$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::rows = ++$h->{_rows};
    }
    return $fbav;
}

sub bind_col {
    my ($h, $col, $value_ref) = @_;
    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;
    $h->bind_col($_, $_[$_]) foreach (0..@_-1);
    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::rows;
    return -1 unless defined $rows;
    return $rows;
}

1;
__END__