########################################################################
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;

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::(.+)::(.+)$/;
    no strict qw(refs);
    my $set_dbh_key;
    if ( $method_name eq 'STORE' and $class eq 'db' ) {
        #z needed when DBD::foo sets $dbh->{bar} in DBD::foo::db
        #  without using $dbh->STORE
        $set_dbh_key = sub {
             my($h,$key,$value)=@_;
             $h->{$key}=$value;
        }
    }
    else {
       $set_dbh_key = sub {}
    }
    if ($method =~ /func/) {
        *$method = sub {
            my $h = shift;
            $h->{'err'}=0;
            $h->{'errstr'}='';
            $h->{'state'}=undef;
            my $func = pop @_;
            my $imp = $h->{"ImplementorClass"};
            $imp =~ s/^(.*)::[^:]+$/$1/;
            my $sub = $imp.'::db::'.$func;
	    $sub = $imp->can($sub)
		or croak "Can't find $method_name method for $h";
	    my @ret;
            (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_));
	    if ($h->{'err'} ) {
                my $estr = $h->{'errstr'} || $h->errstr || '?';
		my $msg = sprintf "$method failed: $estr";
		carp  $msg if $h->{"PrintError"};
		croak $msg if $h->{"RaiseError"};
	    }
	    printf TFH "    < $method_name(@_)\n" if $trace;
	    return (wantarray) ? @ret : $ret[0];
        }
    }
    else {
        *$method = sub {
            my $h = $_[0];
            my $imp;
            eval { $imp = $h->{"ImplementorClass"} if $h; };
            return unless defined $imp;
            &$set_dbh_key(@_);

            #z should err be reset for all methods?
            $h->{'err'}=0;
            $h->{'errstr'}='';
            $h->{'state'}=undef;

            #z Store dbh->{Statement} only on execute
            if ($method_name eq 'execute') {
                $h->{'Database'}->STORE('Statement',$h->{'Statement'});
	    }

            #z something like this, but not this
            if ( $param_hash and defined $param_hash->{'U'}
             and defined $param_hash->{'O'}
	     and $param_hash->{'O'} == 0x0080
             and scalar @{$param_hash->{'U'}} -1 != scalar(@_)
             ) {
		my $msg = sprintf
		    "DBI %s: invalid number of parameters: handle + %ld\n",
		    $method_name, @_-1;
		croak $msg;
	    }

	    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}) {
                my $estr = $h->{zerrstr} || 'No Message :-(';
		my $msg = sprintf "$method failed: $estr\n";
		carp  $msg if $h->{"PrintError"};
                #z
                # AAAAAAAAAARGGGGH!
		# this prints and croaks but doesn't pass to $@ !!!
                # print $msg if $h->{RaiseError}
                #
		croak $msg if $h->{"RaiseError"};
	    }
	    printf TFH "    < $method_name(@_)\n" if $trace;
	    return (wantarray) ? @ret : $ret[0];
        }
    }
}

sub _setup_handle {
    my($h, $imp_class, $parent, $imp_data) = @_;
    $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->{"AutoCommit"}=1 unless defined $h->{"AutoCommit"};
    $h->{"Warn"} = 1 unless defined $h->{"Warn"};
    if ( $parent and ref($parent) =~ /DBI::db/ and ref($h) =~ /DBI::st/) {
       $h->STORE('RaiseError',$parent->{RaiseError});
       $h->STORE('PrintError',$parent->{PrintError});
       $h->STORE('Database',$parent);
       $parent->STORE('Statement',$h->{Statement}); # but change on execute
    }
}

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;
        @$cols = map { lc $_ } @$cols;
        $h->STORE('NAME_lc',$cols);
        @$cols = map { uc $_ } @$cols;
        $h->STORE('NAME_uc',$cols);
        return $h->{$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)= @_;
    return $h->{$key} = $value;
}


sub err {
    my $h = shift;
    # XXX need to be shared between dbh and sth
    $DBI::zerr = $h->{err} || $h->{errstr};
}
sub errstr {
    my $h = shift;
    $h->{zerrstr} = $DBI::zerrstr = $h->{errstr} || $h->{err};
}
sub state {
    my $h = shift;
    $DBI::zstate = $h->{state} || ($h->err ? "S1000" : "00000");
}
sub event {
    # do nothing
}
sub set_err {
    my($h,$errnum,$msg,$state)=@_;
    $msg = $errnum unless defined $msg;
    #z
    # Avert your eyes if you don't want to see a horrendous kludge
    #   (and check DBI::var::FETCH for the other half)
    #
    $DBI::zerr    = $errnum;
    $DBI::zerrstr = $msg;
    $DBI::zstate  = $state;
    $h->{'zerrstr'}=$msg;
    $h->{'errstr'}=$msg;
    $h->{'state'}=$state if $state;
    $h->{'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 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;
    #z TIM'S CHANGE
    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;
        ++$h->{_rows};
    }
=pod
    #z MY ORIGINAL METHOD (THO FIRST LINE IS TIM'S)
    $fbav->[$_] = $row->[$_] foreach (0..@$row-1);
    if ($h->{_bound_cols}) {
        for my $i(0..@$fbav-1) {
            ${$h->{_bound_cols}->[$i]} = $fbav->[$i];
        }
    }
    else {
        ++$h->{_rows};
    }
=cut
    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};
    return -1 unless defined $rows;
    return $rows;
}

package DBI::var;

sub FETCH {
    #z more kludges, but mostly effective
    my($pointer)=shift;
    if ($$pointer =~ /errstr/ ) {
      return $DBI::zerrstr;
    }
    elsif ($$pointer =~ /err/ ) {
      return $DBI::zerr;
    }
    if ($$pointer =~ /state/ ) {
      my $state = $DBI::zstate;
      $state = '' if $DBI::zerr == 0;
      if (!defined $state) {
         $state = ($DBI::zerr) ? "S1000" : "00000";
      } 
      return $state;
    }
}

package DBD::_::db;

sub connected {}

#z just a sample of how preparse might work

my %comment_in = (
    DBIpp_cm_cs  => '\/\*(.*)\*\/',  #  '/**/' C-style
    DBIpp_cm_hs  => '#([^\n]+)'   ,  #  '#'   perl style
    DBIpp_cm_dd  => '--([^\n]+)'  ,  #  '--'  dash dash
    DBIpp_cm_dw  => '-- ([^\n]+)' ,  #  '-- ' dash dash whitespace
);
my %comment_out = (
    DBIpp_cm_cs  => '/*$1*/' ,       #  '/**/' C-style
    DBIpp_cm_hs  => '#$1\n'  ,       #  '#'   perl style
    DBIpp_cm_dd  => '--$1'   ,       #  '--'  dash dash
    DBIpp_cm_dw  => '-- $1'  ,       #  '--'  dash dash whitespace

);

sub preparse {
    my $dbh = shift;
    my $str = shift;
    my $out_style = shift;
    my $in_style = shift;
    my $comment;
    my $in  = $comment_in{$in_style};
    if ($out_style) {
        my $out = $comment_out{$out_style};
        $str =~ s/$in/my $c=$1;$out =~ s~\$1~$c~;$out=~s~\\n~\n~;$out/e;
    }
    return $str;
}

1;
__END__