On Thu, Mar 28, 2002 at 02:52:31PM -0500, [EMAIL PROTECTED] wrote:
> Not to seem over anxious, but what it the status of the discussion on
> the PurlPerl version of DBI? Last I saw in the thread "Pure-perl DBI
> emulation - what use" it looked like the version deserved a little
> devel time. I'd like to offer services beta testing a copy once it's
> fairly stable. I can handle the DBD::CSV and DBD::MySQL drivers on
> Linux (RHL 7.1) running Perl 5.6.0. Please let me know if I can help.
Well, since you ask... I've attached the latest version!
It's far from complete, but lots of things do work.
Please send any patches to Jeff Zucker (CC'd) and cc me
(and/or [EMAIL PROTECTED], but not dbi-users please).
Replacing the "bootstrap DBI;" line in DBI.pm with "require DBI::PurePerl;"
and running "make test" may be a good way to play with it.
Tim.
p.s. Jeff, this is the verson I sent you but with the NUM_OF_FIELDS bug fixed.
package DBI;
# Copyright (c) 2002 Tim Bunce Ireland.
#
# See COPYRIGHT section in DBI.pm for usage and distribution rights.
use strict;
use Carp;
my $trace = 1;
*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 ($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 {
warn "_get_imp_data @_"; return;
}
sub _handles {
warn "_handles @_"; return;
}
sub _install_method {
my ( $caller, $method, $from, $param_hash ) = @_;
my ($class, $method_name) = $method =~ /DBI::(.+)::(.+)$/;
if ($method =~ /func/) {
*$method = sub {
my $h = shift;
my $func = pop @_;
my $imp = $h->{"ImplementorClass"};
$imp =~ s/^(.*)::[^:]+$/$1/;
my $sub = $imp.'::db::'.$func;
&$sub($h,@_);
}
}
else {
*$method = sub {
my $h = $_[0];
printf TFH " > $method_name(@_)\n" if $trace;
my $imp = $h->{"ImplementorClass"};
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 $msg = sprintf "$method failed: $h->{errstr}";
carp $msg if $h->{"PrintError"};
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->{"ImplementorClass"} = $imp_class;
}
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 {
return shift =~ m/^[+-]?(?:(?:\.\d+)|(?:\d+\.?\d*))(?:[eE][+-]?\d+)?/;
}
sub neat {
my $v = shift;
return "undef" unless defined $v;
return $v if looks_like_number($v);
return "'$v'";
}
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;
}
_set_trace_file($file) if defined $file;
return $old_level;
}
*debug = \&trace; *debug = \&trace; # twice to avoid typo warning
sub FETCH {
my($h,$key)= @_;
return $h->{$key};
}
sub STORE {
my($h,$key,$value)= @_;
$h->{$key} = $value;
}
sub err {
my $h = shift;
$h->{err} || $h->{errstr}; # XXX need to be shared between dbh and sth
}
sub errstr {
my $h = shift;
$h->{errstr} || $h->{err};
}
sub state {
my $h = shift;
$h->{state} || ($h->err ? "S1000" : "00000");
}
sub event {
# do nothing
}
sub set_err {
my($h,$errnum,$msg,$state)=@_;
$msg = $errnum unless defined $msg;
$h->STORE('err',$errnum);
$h->STORE('errstr',$msg);
$h->STORE('state',$state) if $state;
return undef;
}
sub trace_msg {
my($h,$msg,$minlevel)=@_;
$minlevel = 1 unless defined $minlevel;
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 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};
return $av;
}
sub _set_fbav {
my $h = shift;
my $fbav = $h->{_fbav} ||= dbih_setup_fbav($h);
my $row = shift;
# done this way else bind_col(umns) will break
$fbav->[$_] = $row->[$_] foreach (0..@$row-1);
return $fbav;
}
sub bind_col {
my ($h, $col, $value_ref) = shift;
DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar")
unless ref $value_ref eq 'SCALAR';
my $fbav = $h->_get_fbav;
# XXX may not be quite right
*{$fbav->[$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;
}
1;
__END__
