Re: current DBD::AnyData will be broken when releasing next DBI
Jens Rehsack <[email protected]>
| Newsgroups | gmane.comp.lang.perl.modules.dbi.sybase.devel |
|---|---|
| Message-ID | <[email protected]> |
2010/6/24 Tim Bunce <[email protected]>: > On Wed, Jun 23, 2010 at 07:56:14PM +0200, Jens Rehsack wrote: [...] >> > Rather than trying to get a "clean" DBD::AnyData, how about we aim for a >> > "dirty" one instead? >> > >> > DBD::AnyData says "use base qw( DBD::File );". The DBD::File that >> > shipped with DBI 1.611 could be copied into the DBD::AnyData distro >> > and renamed to DBD::AnyOldFile (and hacked internally to match). >> > Then DBD::AnyData could say "use base qw( DBD::AnyOldFile );" >> > >> > Not pretty, or clean, but possibly the basis of a workable solution? >> >> That would be the DBI::DBD::SqlEngine (what is more or less the only >> real dependency). >> And this module is required for the next version of DBD::Sys, too. > > Sorry Jens, I'm not sure what you're saying here. I made the same mistake again - implicit referring to an old discussion :) DBD::AnyData is not using anything of DBD::File except the SQL-Engine code. That's what DBD::Sys would like to do, too :) And maybe (if the maintainers are active) DBD::Google and DBD::Excel, too. I've attached a patch which extracts the common sql-interface code out of DBD::File into a base class/driver. Maybe code explains better than my words :) Jens
DBI-Sql-Engine.patch
(application/octet-stream, 59.1 KB)
Index: lib/DBD/File.pm
===================================================================
--- lib/DBD/File.pm (revision 14184)
+++ lib/DBD/File.pm (working copy)
@@ -19,17 +19,19 @@
# General Public License or the Artistic License, as specified in
# the Perl README file.
-require 5.005;
+require 5.008;
use strict;
+use warnings;
use DBI ();
-require DBI::SQL::Nano;
package DBD::File;
use strict;
+use warnings;
+use base qw(DBI::DBD::SqlEngine);
use Carp;
use vars qw( @ISA $VERSION $drh );
@@ -37,10 +39,7 @@
$drh = undef; # holds driver handle(s) once initialized
-DBI->setup_driver ("DBD::File"); # only needed once but harmless to repeat
-
my %accessors = (
- versions => "get_versions",
get_meta => "get_file_meta",
set_meta => "set_file_meta",
clear_meta => "clear_file_meta",
@@ -71,8 +70,7 @@
$attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://;
}
- $drh->{$class} = DBI::_new_drh ($class . "::dr", $attr);
- $drh->{$class}->STORE (ShowErrorStatement => 1);
+ $drh->{$class} = $class->SUPER::driver($attr);
my $prefix = DBI->driver_prefix ($class);
my $dbclass = $class . "::db";
@@ -105,7 +103,11 @@
package DBD::File::dr;
use strict;
+use warnings;
+use vars qw(@ISA $imp_data_size);
+
+@DBD::File::dr::ISA = qw(DBI::DBD::SqlEngine::dr);
$DBD::File::dr::imp_data_size = 0;
sub connect ($$;$$$)
@@ -207,82 +209,24 @@
package DBD::File::db;
use strict;
+use warnings;
+
+use vars qw(@ISA $imp_data_size);
+
use Carp;
require File::Spec;
require Cwd;
use Scalar::Util qw(refaddr); # in CORE since 5.7.3
-if (eval { require Clone; }) {
- Clone->import ("clone");
- }
-else {
- require Storable; # in CORE since 5.7.3
- *clone = \&Storable::dclone;
- }
-
+@DBD::File::db::ISA = qw(DBI::DBD::SqlEngine::db);
$DBD::File::db::imp_data_size = 0;
-sub ping
-{
- ($_[0]->FETCH ("Active")) ? 1 : 0;
- } # ping
-
-sub prepare ($$;@)
-{
- my ($dbh, $statement, @attribs) = @_;
-
- # create a 'blank' sth
- my $sth = DBI::_new_sth ($dbh, {Statement => $statement});
-
- if ($sth) {
- my $class = $sth->FETCH ("ImplementorClass");
- $class =~ s/::st$/::Statement/;
- my $stmt;
-
- # if using SQL::Statement version > 1
- # cache the parser object if the DBD supports parser caching
- # SQL::Nano and older SQL::Statements don't support this
-
- if ( $dbh->{sql_handler} eq "SQL::Statement" and
- $dbh->{sql_statement_version} > 1) {
- my $parser = $dbh->{sql_parser_object};
- $parser ||= eval { $dbh->func ("sql_parser_object") };
- if ($@) {
- $stmt = eval { $class->new ($statement) };
- }
- else {
- $stmt = eval { $class->new ($statement, $parser) };
- }
- }
- else {
- $stmt = eval { $class->new ($statement) };
- }
- if ($@) {
- $dbh->set_err ($DBI::stderr, $@);
- undef $sth;
- }
- else {
- $sth->STORE ("f_stmt", $stmt);
- $sth->STORE ("f_params", []);
- $sth->STORE ("NUM_OF_PARAMS", scalar ($stmt->params ()));
- }
- }
- return $sth;
- } # prepare
-
sub set_versions
{
my $dbh = shift;
$dbh->{f_version} = $DBD::File::VERSION;
- for (qw( nano_version statement_version )) {
- # strip development release version part
- ($dbh->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_} || "") =~ s/_[0-9]+$//;
- }
- $dbh->{sql_handler} = $dbh->{sql_statement_version}
- ? "SQL::Statement"
- : "DBI::SQL::Nano";
- return $dbh;
+ return $dbh->SUPER::set_versions ();
} # set_versions
sub init_valid_attributes
@@ -336,26 +280,21 @@
my $dbh = shift;
# must be done first, because setting flags implicitly calls $dbdname::db->STORE
- $dbh->func ("init_valid_attributes");
+ $dbh->SUPER::init_default_attributes();
- $dbh->func ("set_versions");
-
# f_ext should not be initialized
# f_map is deprecated (but might return)
$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
$dbh->{f_meta} = {};
$dbh->{f_meta_map} = {}; # choose new name because it contains other keys
- $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER
- $dbh->{sql_quoted_identifier_case} = 3; # SQL_IC_SENSITIVE
-
# complete derived attributes, if required
(my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
my $drv_prefix = DBI->driver_prefix ($drv_class);
my $valid_attrs = $drv_prefix . "valid_attrs";
my $ro_attrs = $drv_prefix . "readonly_attrs";
- my @comp_attrs = qw(valid_attrs version readonly_attrs);
+ my @comp_attrs = qw();
if (exists $dbh->{$drv_prefix . "meta"}) {
my $attr = $dbh->{$drv_prefix . "meta"};
defined $attr and defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and
@@ -401,79 +340,10 @@
return 1;
} # disconnect
-sub FETCH ($$)
+sub validate_STORE_attr
{
- my ($dbh, $attrib) = @_;
- $attrib eq "AutoCommit" and
- return 1;
-
- if ($attrib eq (lc $attrib)) {
- # Driver private attributes are lower cased
-
- # XXX Error-check for valid attributes
- # not implemented yet, see STORE
- #
- # XXX return cloned value when readonly attr
- # and not scalar type
- # use: *clone = $haveClone ? \&Clone::clone : \&Storable::dclone;
- #
- my $attr_prefix;
- $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1;
- unless ($attr_prefix) {
- (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
- $attr_prefix = DBI->driver_prefix ($drv_class);
- $attrib = $attr_prefix . $attrib;
- }
- my $valid_attrs = $attr_prefix . "valid_attrs";
- my $ro_attrs = $attr_prefix . "readonly_attrs";
- exists $dbh->{$valid_attrs} and ($dbh->{$valid_attrs}{$attrib} or
- return $dbh->set_err ($DBI::stderr, "Invalid attribute '$attrib'"));
- exists $dbh->{$ro_attrs} and $dbh->{$ro_attrs}{$attrib} and
- defined $dbh->{$attrib} and refaddr ($dbh->{$attrib}) and
- return clone ($dbh->{$attrib});
-
- return $dbh->{$attrib};
- }
- # else pass up to DBI to handle
- return $dbh->SUPER::FETCH ($attrib);
- } # FETCH
-
-sub STORE ($$$)
-{
my ($dbh, $attrib, $value) = @_;
- if ($attrib eq "AutoCommit") {
- $value and return 1; # is already set
- croak "Can't disable AutoCommit";
- }
-
- if ($attrib eq lc $attrib) {
- # Driver private attributes are lower cased
-
- # I'm not implementing this yet because other drivers may be
- # setting f_ and sql_ attrs I don't know about
- # I'll investigate and publicize warnings to DBD authors
- # then implement this
-
- # return to implementor if not f_ or sql_
- # not implemented yet
- # my $class = $dbh->FETCH ("ImplementorClass");
- #
- my $attr_prefix;
- $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1;
- unless ($attr_prefix) {
- (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
- $attr_prefix = DBI->driver_prefix ($drv_class);
- $attrib = $attr_prefix . $attrib;
- }
- my $valid_attrs = $attr_prefix . "valid_attrs";
- my $ro_attrs = $attr_prefix . "readonly_attrs";
- exists $dbh->{$valid_attrs} and ($dbh->{$valid_attrs}{$attrib} or
- return $dbh->set_err ($DBI::stderr, "Invalid attribute '$attrib'"));
- exists $dbh->{$ro_attrs} and $dbh->{$ro_attrs}{$attrib} and defined $dbh->{$attrib} and
- return $dbh->set_err ($DBI::stderr, "attribute '$attrib' is readonly and must not be modified");
- # $dbh->{$attrib} = $value;
-
if ($attrib eq "f_dir") {
-d $value or
return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
@@ -486,67 +356,24 @@
carp "'$value' doesn't look like a valid file extension attribute\n";
}
- if ( $attrib eq "sql_identifier_case" ||
- $attrib eq "sql_quoted_identifier_case"
- and
- $value < 1 || $value > 4) {
- croak "attribute '$attrib' must have a value from 1 .. 4 (SQL_IC_UPPER .. SQL_IC_MIXED)";
- # XXX correctly a remap of all entries in f_meta/f_meta_map is required here
- }
+ return $dbh->SUPER::validate_STORE_attr($attrib, $value);
+}
- # if (($attrib =~ m/^f_/ && $dbh->{f_readonly_attrs}{$attrib} or
- # $attrib =~ m/^sql_/ && $dbh->{sql_readonly_attrs}{$attrib}) and
- # defined $dbh->{$attrib}) {
- # croak "attribute '$attrib' is readonly and must not be modified";
- # }
-
- $dbh->{$attrib} = $value;
- return 1;
- }
-
- return $dbh->SUPER::STORE ($attrib, $value);
- } # STORE
-
-sub get_versions
+sub get_dbm_versions
{
my ($dbh, $table) = @_;
- my %vsn = (
- OS => "$^O ($Config::Config{osvers})",
- Perl => "$] ($Config::Config{archname})",
- DBI => $DBI::VERSION,
- );
- my %vmp;
- my $dbd_file_verinfo = join " ",
- $dbh->{f_version}, "using", $dbh->{sql_handler},
- $dbh->{sql_handler} eq "SQL::Statement"
- ? $dbh->{sql_statement_version}
- : $dbh->{sql_nano_version};
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ s/::db$/::Table/;
+ my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) );
- (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
- my $drv_prefix = DBI->driver_prefix ($drv_class);
- my $ddgv = $dbh->{ImplementorClass}->can ("get_${drv_prefix}versions");
- if ($ddgv) {
- $vsn{"DBD::File"} = $dbd_file_verinfo;
- $vmp{"DBD::File"} = " DBD::File";
- $vsn{$drv_class} = &$ddgv ($dbh, $table);
- }
- else {
- $vsn{"DBD::File"} = $dbd_file_verinfo;
- }
+ my $dbd_file_verinfo = $dbh->{f_version};
+ $meta->{f_encoding} and $dbd_file_verinfo .= " using " . $meta->{f_encoding} . " encoding";
- $DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION;
+ return $dbd_file_verinfo;
+}
- my @versions = map { sprintf "%-16s %s", $vmp{$_} || $_, $vsn{$_} }
- sort {
- $a->isa ($b) and return -1;
- $b->isa ($a) and return 1;
- return $a cmp $b;
- } keys %vsn;
-
- return wantarray ? @versions : join "\n", @versions;
- } # get_versions
-
sub get_single_table_meta
{
my ($dbh, $table, $attr) = @_;
@@ -658,158 +485,41 @@
return;
} # clear_file_meta
-sub DESTROY ($)
+sub get_avail_tables
{
- my $dbh = shift;
- $dbh->SUPER::FETCH ("Active") and $dbh->disconnect ;
- undef $dbh->{sql_parser_object};
- } # DESTROY
+ my $dbh = $_[0];
-sub type_info_all ($)
-{
- [ { TYPE_NAME => 0,
- DATA_TYPE => 1,
- PRECISION => 2,
- LITERAL_PREFIX => 3,
- LITERAL_SUFFIX => 4,
- CREATE_PARAMS => 5,
- NULLABLE => 6,
- CASE_SENSITIVE => 7,
- SEARCHABLE => 8,
- UNSIGNED_ATTRIBUTE => 9,
- MONEY => 10,
- AUTO_INCREMENT => 11,
- LOCAL_TYPE_NAME => 12,
- MINIMUM_SCALE => 13,
- MAXIMUM_SCALE => 14,
- },
- [ "VARCHAR", DBI::SQL_VARCHAR (),
- undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
- ],
- [ "CHAR", DBI::SQL_CHAR (),
- undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
- ],
- [ "INTEGER", DBI::SQL_INTEGER (),
- undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0,
- ],
- [ "REAL", DBI::SQL_REAL (),
- undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0,
- ],
- [ "BLOB", DBI::SQL_LONGVARBINARY (),
- undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
- ],
- [ "BLOB", DBI::SQL_LONGVARBINARY (),
- undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
- ],
- [ "TEXT", DBI::SQL_LONGVARCHAR (),
- undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
- ]];
- } # type_info_all
+ my @tables = $dbh->SUPER::get_avail_tables ();
-{ my $names = [
- qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )];
+ my $dir = $dbh->{f_dir};
+ my $dirh = Symbol::gensym ();
- sub table_info ($)
- {
- my $dbh = shift;
- my $dir = $dbh->{f_dir};
- my $dirh = Symbol::gensym ();
+ unless (opendir $dirh, $dir) {
+ $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
+ return @tables;
+ }
- unless (opendir $dirh, $dir) {
- $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
- return;
- }
-
- my $class = $dbh->FETCH ("ImplementorClass");
- $class =~ s/::db$/::Table/;
- my ($file, @tables, %names);
- my $schema = exists $dbh->{f_schema}
- ? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
- ? $dbh->{f_schema} : undef
- : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
- my %seen;
- while (defined ($file = readdir ($dirh))) {
- my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX
- # $tbl && $meta && -f $meta->{f_fqfn} or next;
- $seen{defined $schema ? $schema : "\0"}{$tbl}++ or
- push @tables, [ undef, $schema, $tbl, "TABLE", undef ];
- }
- unless (closedir $dirh) {
- $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
- return;
- }
-
- my $dbh2 = $dbh->{csv_sponge_driver};
- unless ($dbh2) {
- $dbh2 = $dbh->{csv_sponge_driver} = DBI->connect ("DBI:Sponge:");
- unless ($dbh2) {
- $dbh->set_err ($DBI::stderr, $DBI::errstr);
- return;
- }
- }
-
- # Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
- @tables or return;
-
- my $sth = $dbh2->prepare ("TABLE_INFO", {
- rows => \@tables,
- NAMES => $names,
- });
- $sth or $dbh->set_err ($DBI::stderr, $dbh2->errstr);
- return $sth;
- } # table_info
- }
-
-sub list_tables ($)
-{
- my $dbh = shift;
- my ($sth, @tables);
- $sth = $dbh->table_info () or return;
- while (my $ref = $sth->fetchrow_arrayref ()) {
- push @tables, $ref->[2];
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ s/::db$/::Table/;
+ my ($file, %names);
+ my $schema = exists $dbh->{f_schema}
+ ? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
+ ? $dbh->{f_schema} : undef
+ : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
+ my %seen;
+ while (defined ($file = readdir ($dirh))) {
+ my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX
+ # $tbl && $meta && -f $meta->{f_fqfn} or next;
+ $seen{defined $schema ? $schema : "\0"}{$tbl}++ or
+ push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ];
}
+ unless (closedir $dirh) {
+ $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
+ }
+
return @tables;
- } # list_tables
+ } # get_avail_tables
-sub quote ($$;$)
-{
- my ($self, $str, $type) = @_;
- defined $str or return "NULL";
- defined $type && (
- $type == DBI::SQL_NUMERIC ()
- || $type == DBI::SQL_DECIMAL ()
- || $type == DBI::SQL_INTEGER ()
- || $type == DBI::SQL_SMALLINT ()
- || $type == DBI::SQL_FLOAT ()
- || $type == DBI::SQL_REAL ()
- || $type == DBI::SQL_DOUBLE ()
- || $type == DBI::SQL_TINYINT ())
- and return $str;
-
- $str =~ s/\\/\\\\/sg;
- $str =~ s/\0/\\0/sg;
- $str =~ s/\'/\\\'/sg;
- $str =~ s/\n/\\n/sg;
- $str =~ s/\r/\\r/sg;
- return "'$str'";
- } # quote
-
-sub commit ($)
-{
- my $dbh = shift;
- $dbh->FETCH ("Warn") and
- carp "Commit ineffective while AutoCommit is on", -1;
- return 1;
- } # commit
-
-sub rollback ($)
-{
- my $dbh = shift;
- $dbh->FETCH ("Warn") and
- carp "Rollback ineffective while AutoCommit is on", -1;
- return 0;
- } # rollback
-
# ====== Tie-Meta ==============================================================
package DBD::File::TieMeta;
@@ -963,164 +673,22 @@
package DBD::File::st;
use strict;
+use warnings;
+use vars qw(@ISA $imp_data_size);
+
+@DBD::File::st::ISA = qw(DBI::DBD::SqlEngine::st);
$DBD::File::st::imp_data_size = 0;
-sub bind_param ($$$;$)
-{
- my ($sth, $pNum, $val, $attr) = @_;
- if ($attr && defined $val) {
- my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr;
- if ( $attr == DBI::SQL_BIGINT ()
- || $attr == DBI::SQL_INTEGER ()
- || $attr == DBI::SQL_SMALLINT ()
- || $attr == DBI::SQL_TINYINT ()
- ) {
- $val += 0;
- }
- elsif ($attr == DBI::SQL_DECIMAL ()
- || $attr == DBI::SQL_DOUBLE ()
- || $attr == DBI::SQL_FLOAT ()
- || $attr == DBI::SQL_NUMERIC ()
- || $attr == DBI::SQL_REAL ()
- ) {
- $val += 0.;
- }
- else {
- $val = "$val";
- }
- }
- $sth->{f_params}[$pNum - 1] = $val;
- return 1;
- } # bind_param
-
-sub execute
-{
- my $sth = shift;
- my $params = @_ ? ($sth->{f_params} = [ @_ ]) : $sth->{f_params};
-
- $sth->finish;
- my $stmt = $sth->{f_stmt};
- unless ($sth->{f_params_checked}++) {
- # bug in SQL::Statement 1.20 and below causes breakage
- # on all but the first call
- unless ((my $req_prm = $stmt->params ()) == (my $nparm = @$params)) {
- my $msg = "You passed $nparm parameters where $req_prm required";
- $sth->set_err ($DBI::stderr, $msg);
- return;
- }
- }
- my @err;
- my $result = eval {
- local $SIG{__WARN__} = sub { push @err, @_ };
- $stmt->execute ($sth, $params);
- };
- if ($@ || @err) {
- $sth->set_err ($DBI::stderr, $@ || $err[0]);
- return undef;
- }
-
- if ($stmt->{NUM_OF_FIELDS}) { # is a SELECT statement
- $sth->STORE (Active => 1);
- $sth->FETCH ("NUM_OF_FIELDS") or
- $sth->STORE ("NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS});
- }
- return $result;
- } # execute
-
-sub finish
-{
- my $sth = shift;
- $sth->SUPER::STORE (Active => 0);
- delete $sth->{f_stmt}{data};
- return 1;
- } # finish
-
-sub fetch ($)
-{
- my $sth = shift;
- my $data = $sth->{f_stmt}{data};
- if (!$data || ref $data ne "ARRAY") {
- $sth->set_err ($DBI::stderr,
- "Attempt to fetch row without a preceeding execute () call or from a non-SELECT statement"
- );
- return;
- }
- my $dav = shift @$data;
- unless ($dav) {
- $sth->finish;
- return;
- }
- if ($sth->FETCH ("ChopBlanks")) {
- $_ && $_ =~ s/\s+$// for @$dav;
- }
- return $sth->_set_fbav ($dav);
- } # fetch
-*fetchrow_arrayref = \&fetch;
-
-my %unsupported_attrib = map { $_ => 1 } qw( TYPE PRECISION );
-
-sub FETCH ($$)
-{
- my ($sth, $attrib) = @_;
- exists $unsupported_attrib{$attrib}
- and return undef; # Workaround for a bug in DBI 0.93
- $attrib eq "NAME" and
- return $sth->FETCH ("f_stmt")->{NAME};
- if ($attrib eq "NULLABLE") {
- my ($meta) = $sth->FETCH ("f_stmt")->{NAME}; # Intentional !
- $meta or return undef;
- return [ (1) x @$meta ];
- }
- if ($attrib eq lc $attrib) {
- # Private driver attributes are lower cased
- return $sth->{$attrib};
- }
- # else pass up to DBI to handle
- return $sth->SUPER::FETCH ($attrib);
- } # FETCH
-
-sub STORE ($$$)
-{
- my ($sth, $attrib, $value) = @_;
- exists $unsupported_attrib{$attrib}
- and return; # Workaround for a bug in DBI 0.93
- if ($attrib eq lc $attrib) {
- # Private driver attributes are lower cased
- $sth->{$attrib} = $value;
- return 1;
- }
- return $sth->SUPER::STORE ($attrib, $value);
- } # STORE
-
-sub DESTROY ($)
-{
- my $sth = shift;
- $sth->SUPER::FETCH ("Active") and $sth->finish;
- undef $sth->{f_stmt};
- undef $sth->{f_params};
- } # DESTROY
-
-sub rows ($)
-{
- return $_[0]->{f_stmt}{NUM_OF_ROWS};
- } # rows
-
# ====== SQL::STATEMENT ========================================================
package DBD::File::Statement;
use strict;
-use Carp;
+use warnings;
-# Jochen's old check for flock ()
-#
-# my $locking = $^O ne "MacOS" &&
-# ($^O ne "MSWin32" || !Win32::IsWin95 ()) &&
-# $^O ne "VMS";
+@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement );
-@DBD::File::Statement::ISA = qw( DBI::SQL::Nano::Statement );
-
sub open_table ($$$$$)
{
my ($self, $data, $table, $createMode, $lockMode) = @_;
@@ -1142,6 +710,8 @@
package DBD::File::Table;
use strict;
+use warnings;
+
use Carp;
require IO::File;
require File::Basename;
@@ -1152,7 +722,7 @@
# will work on NFS (flock () may hang hard)
my $locking = eval { flock STDOUT, 0; 1 };
-@DBD::File::Table::ISA = qw(DBI::SQL::Nano::Table);
+@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table );
# ====== FLYWEIGHT SUPPORT =====================================================
@@ -1186,8 +756,8 @@
$user_spec_file = 0;
}
- (Cwd::abs_path ($dir) eq $meta->{f_dir} or $dir eq "./") and
- $dir = "";
+ -d File::Spec->catdir ($meta->{f_dir}, $dir) or
+ croak (File::Spec->catdir ($meta->{f_dir}, $dir) . ": $!");
!$respect_case and $meta->{sql_identifier_case} == 1 and # XXX SQL_IC_UPPER
$tbl = uc $tbl;
@@ -1195,7 +765,9 @@
$tbl = lc $tbl;
my $searchdir = File::Spec->file_name_is_absolute ($dir)
? $dir
- : File::Spec->catdir ($meta->{f_dir}, $dir);
+ : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
+ $searchdir eq $meta->{f_dir} and
+ $dir = "";
unless ($user_spec_file) {
$file_is_table and $file = "$tbl$ext";
Index: lib/DBD/DBM.pm
===================================================================
--- lib/DBD/DBM.pm (revision 14184)
+++ lib/DBD/DBM.pm (working copy)
@@ -76,86 +76,32 @@
$DBD::DBM::db::imp_data_size = 0;
@DBD::DBM::db::ISA = qw(DBD::File::db);
-# the ::db::STORE method is what gets called when you set
-# a lower-cased database handle attribute such as $dbh->{somekey}=$someval;
-#
-# STORE should check to make sure that "somekey" is a valid attribute name
-# but only if it is really one of our attributes (starts with dbm_ or foo_)
-# You can also check for valid values for the attributes if needed
-# and/or perform other operations
-#
-sub STORE ($$$)
+sub validate_STORE_attr
{
my ( $dbh, $attrib, $value ) = @_;
- # use DBD::File's STORE unless its one of our own attributes
- #
- if ( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
- {
- # carp "Usage of '$attrib' is depreciated, use 'dbm_$attrib' instead" if( $^W );
- $attrib = "dbm_" . $attrib; # backward compatibility - would like to carp here
- }
if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" )
{
( my $newattrib = $attrib ) =~ s/^dbm_/f_/g;
# carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if( $^W );
$attrib = $newattrib;
}
- return $dbh->SUPER::STORE( $attrib, $value ) unless ( 0 == index( $attrib, 'dbm_' ) );
- # throw an error if it has our prefix but isn't a valid attr name
- #
- if (
- $dbh->{dbm_valid_attrs}->{$attrib}
- or $attrib eq 'dbm_valid_attrs' # gotta start somewhere :-)
- )
- {
- # check here if you need to validate values
- # or conceivably do other things as well
- #
- $dbh->{$attrib} = $value;
- return 1;
- }
- else
- {
- # throw an error if it has our prefix but isn't a valid attr name
- return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'!" );
- }
+ return $dbh->SUPER::validate_STORE_attr( $attrib, $value );
}
-# and FETCH is done similar to STORE
-#
-sub FETCH ($$)
+sub validate_FETCH_attr
{
my ( $dbh, $attrib ) = @_;
- if ( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
- {
- $attrib = "dbm_" . $attrib; # backward compatibility - would like to carp here
- }
if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" )
{
( my $newattrib = $attrib ) =~ s/^dbm_/f_/g;
# carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if( $^W );
$attrib = $newattrib;
}
- return $dbh->SUPER::FETCH($attrib) unless ( 0 == index( $attrib, 'dbm_' ) );
- if (
- $dbh->{dbm_valid_attrs}->{$attrib}
- or $attrib eq 'dbm_valid_attrs' # gotta start somewhere :-)
- )
- {
- # check here if you need to validate values
- # or conceivably do other things as well
- #
- return $dbh->{$attrib};
- }
- else
- {
- # throw an error if it has our prefix but isn't a valid attr name
- return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" );
- }
+ return $dbh->SUPER::validate_FETCH_attr($attrib);
}
sub set_versions
@@ -185,17 +131,17 @@
dbm_version => 1, # verbose DBD::DBM version
dbm_store_metadata => 1, # column names, etc.
dbm_berkeley_flags => 1, # for BerkeleyDB
- dbm_valid_attrs => 1, # DBD::DBM::db valid attrs
- dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs
- dbm_meta => 1, # DBD::DBM public access for f_meta
- dbm_tables => 1, # DBD::DBM public access for f_meta
+ dbm_valid_attrs => 1, # DBD::DBM::db valid attrs
+ dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs
+ dbm_meta => 1, # DBD::DBM public access for f_meta
+ dbm_tables => 1, # DBD::DBM public access for f_meta
};
$dbh->{dbm_readonly_attrs} = {
- dbm_version => 1, # verbose DBD::DBM version
- dbm_valid_attrs => 1, # DBD::DBM::db valid attrs
- dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs
- dbm_meta => 1, # DBD::DBM public access for f_meta
- };
+ dbm_version => 1, # verbose DBD::DBM version
+ dbm_valid_attrs => 1, # DBD::DBM::db valid attrs
+ dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs
+ dbm_meta => 1, # DBD::DBM public access for f_meta
+ };
$dbh->{dbm_meta} = "dbm_tables";
@@ -214,12 +160,12 @@
sub get_dbm_versions
{
- my ($dbh, $table) = @_;
+ my ( $dbh, $table ) = @_;
$table ||= '';
- my $class = $dbh->FETCH ("ImplementorClass");
+ my $class = $dbh->FETCH("ImplementorClass");
$class =~ s/::db$/::Table/;
- my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
+ my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 );
$meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) );
my $dver;
@@ -228,18 +174,17 @@
eval $eval_str;
my $dtype = $meta->{dbm_type};
$dtype .= ' (' . $dver . ')' if $dver;
- if( $meta->{dbm_mldbm} )
+ if ( $meta->{dbm_mldbm} )
{
- $dtype .= ' + MLDBM';
- $eval_str = '$dver = $MLDBM::VERSION';
- eval $eval_str;
- $dtype .= ' (' . $dver . ')' if $dver;
- $dtype .= ' + ' . $meta->{dbm_mldbm};
- $eval_str = sprintf( 'require MLDBM::Serializer::%s;' .
- '$dver = $MLDBM::Serializer::%s::VERSION',
- $meta->{dbm_mldbm}, $meta->{dbm_mldbm} );
- eval $eval_str;
- $dtype .= ' (' . $dver . ')' if $dver;
+ $dtype .= ' + MLDBM';
+ $eval_str = '$dver = $MLDBM::VERSION';
+ eval $eval_str;
+ $dtype .= ' (' . $dver . ')' if $dver;
+ $dtype .= ' + ' . $meta->{dbm_mldbm};
+ $eval_str = sprintf( 'require MLDBM::Serializer::%s;' . '$dver = $MLDBM::Serializer::%s::VERSION',
+ $meta->{dbm_mldbm}, $meta->{dbm_mldbm} );
+ eval $eval_str;
+ $dtype .= ' (' . $dver . ')' if $dver;
}
return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype );
}
@@ -258,17 +203,7 @@
{
my ( $sth, $attr ) = @_;
- # Being a bit dirty here, as neither SQL::Statement::Structure nor
- # DBI::SQL::Nano::Statement_ does not offer an interface to the
- # required data
- my @colnames;
- if ( $sth->{f_stmt}->isa('SQL::Statement') )
- {
- my $struct = $sth->{f_stmt}{struct} || {};
- my @coldefs = @{ $struct->{column_defs} || [] };
- @colnames = map { $_->{name} || $_->{value} } @coldefs;
- }
- @colnames = $sth->{f_stmt}->column_names() unless (@colnames);
+ my @colnames = $sth->sql_get_colnames();
$attr eq "TYPE" and return [ map { "CHAR" } @colnames ];
@@ -408,8 +343,8 @@
my @tie_args;
if ( $meta->{dbm_type} eq 'BerkeleyDB' )
{
- my $DB_CREATE = 1; # but import constants if supplied
- my $DB_RDONLY = 16; #
+ my $DB_CREATE = BerkeleyDB::DB_CREATE();
+ my $DB_RDONLY = BerkeleyDB::DB_RDONLY();
my %tie_flags;
if ( my $f = $meta->{dbm_berkeley_flags} )
{
@@ -464,10 +399,10 @@
$col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' );
if ( $meta->{dbm_store_metadata} and not $meta->{hash}->{"_metadata \0"} )
{
- $schema or $schema = '';
+ $schema or $schema = '';
$meta->{hash}->{"_metadata \0"} = join( "",
- "<dbd_metadata>", "<schema>$schema</schema>",
- "<col_names>", join( ",", @{$col_names} ) . "</col_names>",
+ "<dbd_metadata>", "<schema>$schema</schema>", "<col_names>",
+ join( ",", @{$col_names} ) . "</col_names>",
"</dbd_metadata>" );
}
@@ -523,15 +458,17 @@
sub insert_new_row ($$$)
{
my ( $self, $data, $row_aryref ) = @_;
- my $meta = $self->{meta};
- my $ncols = scalar(@{$meta->{col_names}});
- my $nitems = scalar(@{$row_aryref});
- $ncols == $nitems or
- croak "You tried to insert $nitems, but table is created with $ncols columns";
+ my $meta = $self->{meta};
+ my $ncols = scalar( @{ $meta->{col_names} } );
+ my $nitems = scalar( @{$row_aryref} );
+ $ncols == $nitems
+ or croak "You tried to insert $nitems, but table is created with $ncols columns";
- my $key = shift @$row_aryref;
- exists($meta->{hash}->{$key}) and
- croak "Row with PK '$key' already exists";
+ my $key = shift @$row_aryref;
+ my $exists;
+ eval { $exists = exists( $meta->{hash}->{$key} ); };
+ $exists
+ and croak "Row with PK '$key' already exists";
if ( $meta->{dbm_mldbm} )
{
@@ -553,14 +490,15 @@
my $meta = $self->{meta};
# some sanity checks ...
- my $ncols = scalar( @$row_aryref );
+ my $ncols = scalar(@$row_aryref);
$ncols < 2 and croak "At least 2 columns are required for DBD::DBM tables ...";
- !$meta->{dbm_mldbm} and $ncols > 2 and
- croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols";
+ !$meta->{dbm_mldbm}
+ and $ncols > 2
+ and croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols";
$meta->{col_names} = $row_aryref;
return unless $meta->{dbm_store_metadata};
- my $stmt = $data->{f_stmt};
+ my $stmt = $data->{sql_stmt};
my $col_names = join( ',', @{$row_aryref} );
my $schema = $data->{Database}->{Statement};
$schema =~ s/^[^\(]+\((.+)\)$/$1/s;
Index: lib/DBI/DBD/SqlEngine.pm
===================================================================
--- lib/DBI/DBD/SqlEngine.pm (revision 0)
+++ lib/DBI/DBD/SqlEngine.pm (revision 0)
@@ -0,0 +1,875 @@
+# -*- perl -*-
+#
+# DBI::DBD::SqlEngine - A base class for implementing DBI drivers that
+# have not an own SQL engine
+#
+# This module is currently maintained by
+#
+# H.Merijn Brand & Jens Rehsack
+#
+# The original author is Jochen Wiedmann.
+#
+# Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack
+# Copyright (C) 2004 by Jeff Zucker
+# Copyright (C) 1998 by Jochen Wiedmann
+#
+# All rights reserved.
+#
+# You may distribute this module under the terms of either the GNU
+# General Public License or the Artistic License, as specified in
+# the Perl README file.
+
+require 5.008;
+
+use strict;
+
+use DBI ();
+require DBI::SQL::Nano;
+
+package DBI::DBD::SqlEngine;
+
+use strict;
+
+use Carp;
+use vars qw( @ISA $VERSION $drh %methods_installed);
+
+$VERSION = "0.01";
+
+$drh = undef; # holds driver handle(s) once initialized
+
+DBI->setup_driver("DBI::DBD::SqlEngine"); # only needed once but harmless to repeat
+
+my %accessors = ( versions => "get_driver_versions", );
+
+sub driver ($;$)
+{
+ my ( $class, $attr ) = @_;
+
+ # Drivers typically use a singleton object for the $drh
+ # We use a hash here to have one singleton per subclass.
+ # (Otherwise DBD::CSV and DBD::DBM, for example, would
+ # share the same driver object which would cause problems.)
+ # An alternative would be not not cache the $drh here at all
+ # and require that subclasses do that. Subclasses should do
+ # their own caching, so caching here just provides extra safety.
+ $drh->{$class} and return $drh->{$class};
+
+ $attr ||= {};
+ {
+ no strict "refs";
+ unless ( $attr->{Attribution} )
+ {
+ $class eq "DBI::DBD::SqlEngine"
+ and $attr->{Attribution} = "$class by Jens Rehsack";
+ $attr->{Attribution} ||= ${ $class . "::ATTRIBUTION" }
+ || "oops the author of $class forgot to define this";
+ }
+ $attr->{Version} ||= ${ $class . "::VERSION" };
+ $attr->{Name} or ( $attr->{Name} = $class ) =~ s/^DBD\:\://;
+ }
+
+ $drh->{$class} = DBI::_new_drh( $class . "::dr", $attr );
+ $drh->{$class}->STORE( ShowErrorStatement => 1 );
+
+ my $prefix = DBI->driver_prefix($class);
+ my $dbclass = $class . "::db";
+ while ( my ( $accessor, $funcname ) = each %accessors )
+ {
+ my $method = $prefix . $accessor;
+ $dbclass->can($method) and next;
+ my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname;
+sub %s::%s
+{
+ my $func = %s->can (q{%s});
+ goto &$func;
+ }
+EOI
+ eval $inject;
+ $dbclass->install_method($method);
+ }
+
+ # XXX inject DBD::XXX::Statement unless exists
+
+ my $stclass = $class . "::st";
+ $stclass->install_method("sql_get_colnames") unless ( $methods_installed{$class}++ );
+
+ return $drh->{$class};
+} # driver
+
+sub CLONE
+{
+ undef $drh;
+} # CLONE
+
+# ====== DRIVER ================================================================
+
+package DBI::DBD::SqlEngine::dr;
+
+use strict;
+use warnings;
+
+use vars qw(@ISA $imp_data_size);
+
+$imp_data_size = 0;
+
+sub connect ($$;$$$)
+{
+ my ( $drh, $dbname, $user, $auth, $attr ) = @_;
+
+ # create a 'blank' dbh
+ my $this = DBI::_new_dbh(
+ $drh,
+ {
+ Name => $dbname,
+ USER => $user,
+ CURRENT_USER => $user,
+ }
+ );
+
+ if ($this)
+ {
+ # must be done first, because setting flags implicitly calls $dbdname::db->STORE
+ $this->func("init_default_attributes");
+
+ my ( $var, $val );
+ while ( length $dbname )
+ {
+ if ( $dbname =~ s/^((?:[^\\;]|\\.)*?);//s )
+ {
+ $var = $1;
+ }
+ else
+ {
+ $var = $dbname;
+ $dbname = "";
+ }
+ if ( $var =~ m/^(.+?)=(.*)/s )
+ {
+ $var = $1;
+ ( $val = $2 ) =~ s/\\(.)/$1/g;
+ $this->{$var} = $val;
+ }
+ elsif ( $var =~ m/^(.+?)=>(.*)/s )
+ {
+ $var = $1;
+ ( $val = $2 ) =~ s/\\(.)/$1/g;
+ my $ref = eval $val;
+ $this->$var($ref);
+ }
+ }
+
+ $this->STORE( Active => 1 );
+ }
+
+ return $this;
+} # connect
+
+sub disconnect_all
+{
+} # disconnect_all
+
+sub DESTROY
+{
+ undef;
+} # DESTROY
+
+# ====== DATABASE ==============================================================
+
+package DBI::DBD::SqlEngine::db;
+
+use strict;
+use warnings;
+
+use vars qw(@ISA $imp_data_size);
+
+use Carp;
+
+if ( eval { require Clone; } )
+{
+ Clone->import("clone");
+}
+else
+{
+ require Storable; # in CORE since 5.7.3
+ *clone = \&Storable::dclone;
+}
+
+$imp_data_size = 0;
+
+sub ping
+{
+ ( $_[0]->FETCH("Active") ) ? 1 : 0;
+} # ping
+
+sub prepare ($$;@)
+{
+ my ( $dbh, $statement, @attribs ) = @_;
+
+ # create a 'blank' sth
+ my $sth = DBI::_new_sth( $dbh, { Statement => $statement } );
+
+ if ($sth)
+ {
+ my $class = $sth->FETCH("ImplementorClass");
+ $class =~ s/::st$/::Statement/;
+ my $stmt;
+
+ # if using SQL::Statement version > 1
+ # cache the parser object if the DBD supports parser caching
+ # SQL::Nano and older SQL::Statements don't support this
+
+ if ( $class->isa("SQL::Statement") )
+ {
+ my $parser = $dbh->{sql_parser_object};
+ $parser ||= eval { $dbh->func("sql_parser_object") };
+ if ($@)
+ {
+ $stmt = eval { $class->new($statement) };
+ }
+ else
+ {
+ $stmt = eval { $class->new( $statement, $parser ) };
+ }
+ }
+ else
+ {
+ $stmt = eval { $class->new($statement) };
+ }
+ if ($@)
+ {
+ $dbh->set_err( $DBI::stderr, $@ );
+ undef $sth;
+ }
+ else
+ {
+ $sth->STORE( "sql_stmt", $stmt );
+ $sth->STORE( "sql_params", [] );
+ $sth->STORE( "NUM_OF_PARAMS", scalar( $stmt->params() ) );
+ }
+ }
+ return $sth;
+} # prepare
+
+sub set_versions
+{
+ my $dbh = $_[0];
+ $dbh->{sql_version} = $DBI::DBD::SqlEngine::VERSION;
+ for (qw( nano_version statement_version ))
+ {
+ defined $DBI::SQL::Nano::versions->{$_} or next;
+ $dbh->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_};
+ }
+ $dbh->{sql_handler} =
+ $dbh->{sql_statement_version}
+ ? "SQL::Statement"
+ : "DBI::SQL::Nano";
+
+ return $dbh;
+} # set_versions
+
+sub init_valid_attributes
+{
+ my $dbh = $_[0];
+
+ $dbh->{sql_valid_attrs} = {
+ sql_version => 1, # DBI::DBD::SqlEngine version
+ sql_handler => 1, # Nano or S:S
+ sql_nano_version => 1, # Nano version
+ sql_statement_version => 1, # S:S version
+ sql_flags => 1, # flags for SQL::Parser
+ sql_quoted_identifier_case => 1, # case for quoted identifiers
+ sql_identifier_case => 1, # case for non-quoted identifiers
+ sql_parser_object => 1, # SQL::Parser instance
+ sql_sponge_driver => 1, # Sponge driver for table_info ()
+ sql_valid_attrs => 1, # SQL valid attributes
+ sql_readonly_attrs => 1, # SQL readonly attributes
+ };
+ $dbh->{sql_readonly_attrs} = {
+ sql_version => 1, # DBI::DBD::SqlEngine version
+ sql_handler => 1, # Nano or S:S
+ sql_nano_version => 1, # Nano version
+ sql_statement_version => 1, # S:S version
+ sql_quoted_identifier_case => 1, # case for quoted identifiers
+ sql_parser_object => 1, # SQL::Parser instance
+ sql_sponge_driver => 1, # Sponge driver for table_info ()
+ sql_valid_attrs => 1, # SQL valid attributes
+ sql_readonly_attrs => 1, # SQL readonly attributes
+ };
+
+ return $dbh;
+} # init_valid_attributes
+
+sub init_default_attributes
+{
+ my $dbh = shift;
+
+ # must be done first, because setting flags implicitly calls $dbdname::db->STORE
+ $dbh->func("init_valid_attributes");
+
+ $dbh->func("set_versions");
+
+ $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER
+ $dbh->{sql_quoted_identifier_case} = 3; # SQL_IC_SENSITIVE
+
+ # complete derived attributes, if required
+ ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//;
+ my $drv_prefix = DBI->driver_prefix($drv_class);
+ my $valid_attrs = $drv_prefix . "valid_attrs";
+ my $ro_attrs = $drv_prefix . "readonly_attrs";
+
+ my @comp_attrs = qw(valid_attrs version readonly_attrs);
+
+ foreach my $comp_attr (@comp_attrs)
+ {
+ my $attr = $drv_prefix . $comp_attr;
+ defined $dbh->{$valid_attrs}
+ and !defined $dbh->{$valid_attrs}{$attr}
+ and $dbh->{$valid_attrs}{$attr} = 1;
+ defined $dbh->{$ro_attrs}
+ and !defined $dbh->{$ro_attrs}{$attr}
+ and $dbh->{$ro_attrs}{$attr} = 1;
+ }
+
+ return $dbh;
+} # init_default_attributes
+
+sub sql_parser_object
+{
+ my $dbh = $_[0];
+ my $parser = {
+ dialect => "CSV",
+ RaiseError => $dbh->FETCH("RaiseError"),
+ PrintError => $dbh->FETCH("PrintError"),
+ };
+ my $sql_flags = $dbh->FETCH("sql_flags") || {};
+ %$parser = ( %$parser, %$sql_flags );
+ $parser = SQL::Parser->new( $parser->{dialect}, $parser );
+ $dbh->{sql_parser_object} = $parser;
+ return $parser;
+} # cache_sql_parser_object
+
+sub sql_sponge_driver
+{
+ my $dbh = $_[0];
+ my $dbh2 = $dbh->{sql_sponge_driver};
+ unless ($dbh2)
+ {
+ $dbh2 = $dbh->{sql_sponge_driver} = DBI->connect("DBI:Sponge:");
+ unless ($dbh2)
+ {
+ $dbh->set_err( $DBI::stderr, $DBI::errstr );
+ return;
+ }
+ }
+}
+
+sub disconnect ($)
+{
+ $_[0]->STORE( Active => 0 );
+ return 1;
+} # disconnect
+
+sub validate_FETCH_attr
+{
+ my ( $dbh, $attrib ) = @_;
+
+ return $attrib;
+}
+
+sub FETCH ($$)
+{
+ my ( $dbh, $attrib ) = @_;
+ $attrib eq "AutoCommit"
+ and return 1;
+
+ if ( $attrib eq ( lc $attrib ) )
+ {
+ # Driver private attributes are lower cased
+
+ my $attr_prefix;
+ $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1;
+ unless ($attr_prefix)
+ {
+ ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//;
+ $attr_prefix = DBI->driver_prefix($drv_class);
+ $attrib = $attr_prefix . $attrib;
+ }
+ my $valid_attrs = $attr_prefix . "valid_attrs";
+ my $ro_attrs = $attr_prefix . "readonly_attrs";
+
+ $attrib = $dbh->func( $attrib, "validate_FETCH_attr" ) or return;
+
+ exists $dbh->{$valid_attrs}
+ and ( $dbh->{$valid_attrs}{$attrib}
+ or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) );
+ exists $dbh->{$ro_attrs}
+ and $dbh->{$ro_attrs}{$attrib}
+ and defined $dbh->{$attrib}
+ and refaddr( $dbh->{$attrib} )
+ and return clone( $dbh->{$attrib} );
+
+ return $dbh->{$attrib};
+ }
+ # else pass up to DBI to handle
+ return $dbh->SUPER::FETCH($attrib);
+} # FETCH
+
+sub validate_STORE_attr
+{
+ my ( $dbh, $attrib, $value ) = @_;
+
+ if ( $attrib eq "sql_identifier_case" || $attrib eq "sql_quoted_identifier_case"
+ and $value < 1 || $value > 4 )
+ {
+ croak "attribute '$attrib' must have a value from 1 .. 4 (SQL_IC_UPPER .. SQL_IC_MIXED)";
+ # XXX correctly a remap of all entries in f_meta/f_meta_map is required here
+ }
+
+ return ( $attrib, $value );
+}
+
+# the ::db::STORE method is what gets called when you set
+# a lower-cased database handle attribute such as $dbh->{somekey}=$someval;
+#
+# STORE should check to make sure that "somekey" is a valid attribute name
+# but only if it is really one of our attributes (starts with dbm_ or foo_)
+# You can also check for valid values for the attributes if needed
+# and/or perform other operations
+#
+sub STORE ($$$)
+{
+ my ( $dbh, $attrib, $value ) = @_;
+
+ if ( $attrib eq "AutoCommit" )
+ {
+ $value and return 1; # is already set
+ croak "Can't disable AutoCommit";
+ }
+
+ if ( $attrib eq lc $attrib )
+ {
+ # Driver private attributes are lower cased
+
+ my $attr_prefix;
+ $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1;
+ unless ($attr_prefix)
+ {
+ ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//;
+ $attr_prefix = DBI->driver_prefix($drv_class);
+ $attrib = $attr_prefix . $attrib;
+ }
+ my $valid_attrs = $attr_prefix . "valid_attrs";
+ my $ro_attrs = $attr_prefix . "readonly_attrs";
+
+ ( $attrib, $value ) = $dbh->func( $attrib, $value, "validate_STORE_attr" );
+ $attrib or return;
+
+ exists $dbh->{$valid_attrs}
+ and ( $dbh->{$valid_attrs}{$attrib}
+ or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) );
+ exists $dbh->{$ro_attrs}
+ and $dbh->{$ro_attrs}{$attrib}
+ and defined $dbh->{$attrib}
+ and return $dbh->set_err( $DBI::stderr, "attribute '$attrib' is readonly and must not be modified" );
+
+ $dbh->{$attrib} = $value;
+ return 1;
+ }
+
+ return $dbh->SUPER::STORE( $attrib, $value );
+} # STORE
+
+sub get_driver_versions
+{
+ my ( $dbh, $table ) = @_;
+ my %vsn = (
+ OS => "$^O ($Config::Config{osvers})",
+ Perl => "$] ($Config::Config{archname})",
+ DBI => $DBI::VERSION,
+ );
+ my %vmp;
+
+ my $sql_engine_verinfo =
+ join " ",
+ $dbh->{sql_version}, "using", $dbh->{sql_handler},
+ $dbh->{sql_handler} eq "SQL::Statement"
+ ? $dbh->{sql_statement_version}
+ : $dbh->{sql_nano_version};
+
+ my $indent = 0;
+ my @deriveds = ( $dbh->{ImplementorClass} );
+ while (@deriveds)
+ {
+ my $derived = shift @deriveds;
+ $derived eq "DBI::DBD::SqlEngine::db" and last;
+ $derived->isa("DBI::DBD::SqlEngine::db") or next;
+ #no strict 'refs';
+ eval "push \@deriveds, \@${derived}::ISA";
+ #use strict;
+ ( my $drv_class = $derived ) =~ s/::db$//;
+ my $drv_prefix = DBI->driver_prefix($drv_class);
+ my $ddgv = $dbh->{ImplementorClass}->can("get_${drv_prefix}versions");
+ my $drv_version = $ddgv ? &$ddgv( $dbh, $table ) : $dbh->{ $drv_prefix . "version" };
+ $drv_version ||= eval "\$" . $derived . "::VERSION";; # XXX access $drv_class::VERSION via symbol table
+ $vsn{$drv_class} = $drv_version;
+ $indent and $vmp{$drv_class} = " " x $indent . $drv_class;
+ $indent += 2;
+ }
+
+ $vsn{"DBI::DBD::SqlEngine"} = $sql_engine_verinfo;
+ $indent and $vmp{"DBI::DBD::SqlEngine"} = " " x $indent . "DBI::DBD::SqlEngine";
+
+ $DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION;
+
+ $indent += 20;
+ my @versions = map { sprintf "%-${indent}s %s", $vmp{$_} || $_, $vsn{$_} }
+ sort {
+ $a->isa($b) and return -1;
+ $b->isa($a) and return 1;
+ $a->isa("DBI::DBD::SqlEngine") and return -1;
+ $b->isa("DBI::DBD::SqlEngine") and return 1;
+ return $a cmp $b;
+ } keys %vsn;
+
+ return wantarray ? @versions : join "\n", @versions;
+} # get_versions
+
+sub DESTROY ($)
+{
+ my $dbh = shift;
+ $dbh->SUPER::FETCH("Active") and $dbh->disconnect;
+ undef $dbh->{sql_parser_object};
+} # DESTROY
+
+sub type_info_all ($)
+{
+ [
+ {
+ TYPE_NAME => 0,
+ DATA_TYPE => 1,
+ PRECISION => 2,
+ LITERAL_PREFIX => 3,
+ LITERAL_SUFFIX => 4,
+ CREATE_PARAMS => 5,
+ NULLABLE => 6,
+ CASE_SENSITIVE => 7,
+ SEARCHABLE => 8,
+ UNSIGNED_ATTRIBUTE => 9,
+ MONEY => 10,
+ AUTO_INCREMENT => 11,
+ LOCAL_TYPE_NAME => 12,
+ MINIMUM_SCALE => 13,
+ MAXIMUM_SCALE => 14,
+ },
+ [ "VARCHAR", DBI::SQL_VARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ],
+ [ "CHAR", DBI::SQL_CHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ],
+ [ "INTEGER", DBI::SQL_INTEGER(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ],
+ [ "REAL", DBI::SQL_REAL(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ],
+ [ "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ],
+ [ "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ],
+ [ "TEXT", DBI::SQL_LONGVARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ]
+ ];
+} # type_info_all
+
+sub get_avail_tables
+{
+ my $dbh = $_[0];
+ my @tables = ();
+
+ if ( $dbh->{sql_handler} eq "SQL::Statement" and $dbh->{sql_ram_tables} )
+ {
+ foreach my $table ( keys %{ $dbh->{sql_ram_tables} } )
+ {
+ push @tables, [ undef, undef, $table, "TABLE", "TEMP" ];
+ }
+ }
+
+ return @tables;
+} # get_avail_tables
+
+{
+ my $names = [qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )];
+
+ sub table_info ($)
+ {
+ my $dbh = shift;
+
+ my @tables = $dbh->func("get_avail_tables");
+
+ # Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
+ @tables or return;
+
+ my $dbh2 = $dbh->func("sql_sponge_driver");
+ my $sth = $dbh2->prepare(
+ "TABLE_INFO",
+ {
+ rows => \@tables,
+ NAMES => $names,
+ }
+ );
+ $sth or $dbh->set_err( $DBI::stderr, $dbh2->errstr );
+ return $sth;
+ } # table_info
+}
+
+sub list_tables ($)
+{
+ my $dbh = shift;
+ my @table_list;
+
+ my @tables = $dbh->func("get_avail_tables") or return;
+ foreach my $ref (@tables)
+ {
+ push @tables, $ref->[2];
+ }
+
+ return @table_list;
+} # list_tables
+
+sub quote ($$;$)
+{
+ my ( $self, $str, $type ) = @_;
+ defined $str or return "NULL";
+ defined $type && ( $type == DBI::SQL_NUMERIC()
+ || $type == DBI::SQL_DECIMAL()
+ || $type == DBI::SQL_INTEGER()
+ || $type == DBI::SQL_SMALLINT()
+ || $type == DBI::SQL_FLOAT()
+ || $type == DBI::SQL_REAL()
+ || $type == DBI::SQL_DOUBLE()
+ || $type == DBI::SQL_TINYINT() )
+ and return $str;
+
+ $str =~ s/\\/\\\\/sg;
+ $str =~ s/\0/\\0/sg;
+ $str =~ s/\'/\\\'/sg;
+ $str =~ s/\n/\\n/sg;
+ $str =~ s/\r/\\r/sg;
+ return "'$str'";
+} # quote
+
+sub commit ($)
+{
+ my $dbh = shift;
+ $dbh->FETCH("Warn")
+ and carp "Commit ineffective while AutoCommit is on", -1;
+ return 1;
+} # commit
+
+sub rollback ($)
+{
+ my $dbh = shift;
+ $dbh->FETCH("Warn")
+ and carp "Rollback ineffective while AutoCommit is on", -1;
+ return 0;
+} # rollback
+
+# ====== STATEMENT =============================================================
+
+package DBI::DBD::SqlEngine::st;
+
+use strict;
+use warnings;
+
+use vars qw(@ISA $imp_data_size);
+
+$imp_data_size = 0;
+
+sub bind_param ($$$;$)
+{
+ my ( $sth, $pNum, $val, $attr ) = @_;
+ if ( $attr && defined $val )
+ {
+ my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr;
+ if ( $attr == DBI::SQL_BIGINT()
+ || $attr == DBI::SQL_INTEGER()
+ || $attr == DBI::SQL_SMALLINT()
+ || $attr == DBI::SQL_TINYINT() )
+ {
+ $val += 0;
+ }
+ elsif ( $attr == DBI::SQL_DECIMAL()
+ || $attr == DBI::SQL_DOUBLE()
+ || $attr == DBI::SQL_FLOAT()
+ || $attr == DBI::SQL_NUMERIC()
+ || $attr == DBI::SQL_REAL() )
+ {
+ $val += 0.;
+ }
+ else
+ {
+ $val = "$val";
+ }
+ }
+ $sth->{sql_params}[ $pNum - 1 ] = $val;
+ return 1;
+} # bind_param
+
+sub execute
+{
+ my $sth = shift;
+ my $params = @_ ? ( $sth->{sql_params} = [@_] ) : $sth->{sql_params};
+
+ $sth->finish;
+ my $stmt = $sth->{sql_stmt};
+ unless ( $sth->{sql_params_checked}++ )
+ {
+ # bug in SQL::Statement 1.20 and below causes breakage
+ # on all but the first call
+ unless ( ( my $req_prm = $stmt->params() ) == ( my $nparm = @$params ) )
+ {
+ my $msg = "You passed $nparm parameters where $req_prm required";
+ $sth->set_err( $DBI::stderr, $msg );
+ return;
+ }
+ }
+ my @err;
+ my $result;
+ eval {
+ local $SIG{__WARN__} = sub { push @err, @_ };
+ $result = $stmt->execute( $sth, $params );
+ };
+ unless ( defined $result )
+ {
+ $sth->set_err( $DBI::stderr, $@ || $stmt->{errstr} || $err[0] );
+ return;
+ }
+
+ if ( $stmt->{NUM_OF_FIELDS} )
+ { # is a SELECT statement
+ $sth->STORE( Active => 1 );
+ $sth->FETCH("NUM_OF_FIELDS")
+ or $sth->STORE( "NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS} );
+ }
+ return $result;
+} # execute
+
+sub finish
+{
+ my $sth = shift;
+ $sth->SUPER::STORE( Active => 0 );
+ delete $sth->{sql_stmt}{data};
+ return 1;
+} # finish
+
+sub fetch ($)
+{
+ my $sth = shift;
+ my $data = $sth->{sql_stmt}{data};
+ if ( !$data || ref $data ne "ARRAY" )
+ {
+ $sth->set_err( $DBI::stderr,
+ "Attempt to fetch row without a preceeding execute () call or from a non-SELECT statement" );
+ return;
+ }
+ my $dav = shift @$data;
+ unless ($dav)
+ {
+ $sth->finish;
+ return;
+ }
+ if ( $sth->FETCH("ChopBlanks") )
+ {
+ $_ && $_ =~ s/\s+$// for @$dav;
+ }
+ return $sth->_set_fbav($dav);
+} # fetch
+
+no warnings 'once';
+*fetchrow_arrayref = \&fetch;
+
+use warnings;
+
+my %unsupported_attrib = map { $_ => 1 } qw( TYPE PRECISION );
+
+sub sql_get_colnames
+{
+ my $sth = $_[0];
+ # Being a bit dirty here, as neither SQL::Statement::Structure nor
+ # DBI::SQL::Nano::Statement_ does not offer an interface to the
+ # required data
+ my @colnames;
+ if( $sth->{sql_stmt}->{NAME} and "ARRAY" eq ref($sth->{sql_stmt}->{NAME}) )
+ {
+ @colnames = @{$sth->{sql_stmt}->{NAME}};
+ }
+ elsif ( $sth->{sql_stmt}->isa('SQL::Statement') )
+ {
+ my $struct = $sth->{sql_stmt}{struct} || {};
+ my @coldefs = @{ $struct->{column_defs} || [] };
+ @colnames = map { $_->{name} || $_->{value} } @coldefs;
+ }
+ @colnames = $sth->{sql_stmt}->column_names() unless (@colnames);
+
+ return @colnames;
+}
+
+sub FETCH ($$)
+{
+ my ( $sth, $attrib ) = @_;
+ exists $unsupported_attrib{$attrib}
+ and return; # Workaround for a bug in DBI 0.93
+ $attrib eq "NAME"
+ and return [ $sth->sql_get_colnames() ];
+ if ( $attrib eq "NULLABLE" )
+ {
+ my @colnames = $sth->sql_get_colnames();
+ @colnames or return;
+ return [ (1) x @colnames ];
+ }
+ if ( $attrib eq lc $attrib )
+ {
+ # Private driver attributes are lower cased
+ return $sth->{$attrib};
+ }
+ # else pass up to DBI to handle
+ return $sth->SUPER::FETCH($attrib);
+} # FETCH
+
+sub STORE ($$$)
+{
+ my ( $sth, $attrib, $value ) = @_;
+ exists $unsupported_attrib{$attrib}
+ and return; # Workaround for a bug in DBI 0.93
+ if ( $attrib eq lc $attrib )
+ {
+ # Private driver attributes are lower cased
+ $sth->{$attrib} = $value;
+ return 1;
+ }
+ return $sth->SUPER::STORE( $attrib, $value );
+} # STORE
+
+sub DESTROY ($)
+{
+ my $sth = shift;
+ $sth->SUPER::FETCH("Active") and $sth->finish;
+ undef $sth->{sql_stmt};
+ undef $sth->{sql_params};
+} # DESTROY
+
+sub rows ($)
+{
+ return $_[0]->{sql_stmt}{NUM_OF_ROWS};
+} # rows
+
+# ====== SQL::STATEMENT ========================================================
+
+package DBI::DBD::SqlEngine::Statement;
+
+use strict;
+use warnings;
+
+use Carp;
+
+@DBI::DBD::SqlEngine::Statement::ISA = qw(DBI::SQL::Nano::Statement);
+
+# ====== SQL::TABLE ============================================================
+
+package DBI::DBD::SqlEngine::Table;
+
+use strict;
+use warnings;
+
+@DBI::DBD::SqlEngine::Table::ISA = qw(DBI::SQL::Nano::Table);
+
Index: lib/DBI/SQL/Nano.pm
===================================================================
--- lib/DBI/SQL/Nano.pm (revision 14184)
+++ lib/DBI/SQL/Nano.pm (working copy)
@@ -31,7 +31,7 @@
$VERSION = sprintf( "1.%06d", q$Revision$ =~ /(\d+)/o );
$versions->{nano_version} = $VERSION;
- if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.27_01' } )
+ if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.27_02' } )
{
@DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
@DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_);
@@ -287,7 +287,7 @@
my $command = $self->{command};
( $self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'}, $self->{'data'}, ) = $self->$command( $data, $params );
$self->{NAME} ||= $self->{column_names};
- $self->{'NUM_OF_ROWS'} || '0E0';
+ return $self->{'NUM_OF_ROWS'} || '0E0';
}
my $enoentstr = "Cannot open .*\(" . Errno::ENOENT . "\)";
Index: MANIFEST
===================================================================
--- MANIFEST (revision 14184)
+++ MANIFEST (working copy)
@@ -47,6 +47,7 @@
lib/DBI/Const/GetInfoType.pm GetInfo type code data based on standards
lib/DBI/DBD.pm Some basic help for people writing DBI drivers
lib/DBI/DBD/Metadata.pm Metadata tools for people writing DBI drivers
+lib/DBI/DBD/SqlEngine.pm SQL Engine for drivers without an own
lib/DBI/FAQ.pm The DBI FAQ in module form for perldoc
lib/DBI/Gofer/Execute.pm Execution logic for DBD::Gofer server
lib/DBI/Gofer/Request.pm Request object from DBD::Gofer
Index: t/50dbm_simple.t
===================================================================
--- t/50dbm_simple.t (revision 14184)
+++ t/50dbm_simple.t (working copy)
@@ -244,11 +244,15 @@
skip "prepare failed: " . $dbh->errstr || 'unknown error',
($sql =~ /SELECT/) ? 2 : 1;
}
- my @bind = split /,/, $comment if $sth->{NUM_OF_PARAMS};
+ my @bind;
+ if($sth->{NUM_OF_PARAMS})
+ {
+ @bind = split /,/, $comment;
+ }
# if execute errors we will handle it, not PrintError:
$sth->{PrintError} = 0;
my $n = $sth->execute(@bind);
- if ($sth->err and $sql !~ /^DROP/ ) {
+ if ($sth->errstr and $sql !~ /^DROP/ ) {
skip "execute failed: " . $sth->errstr || 'unknown error',
($sql =~ /^(?:SELECT|UPDATE|DELETE)/) ? 2 : 1;
}
Index: DBI.pm
===================================================================
--- DBI.pm (revision 14184)
+++ DBI.pm (working copy)
@@ -349,7 +349,7 @@
sapdb_ => { class => 'DBD::SAP_DB', },
solid_ => { class => 'DBD::Solid', },
sponge_ => { class => 'DBD::Sponge', },
- sql_ => { class => 'SQL::Statement', },
+ sql_ => { class => 'DBI::DBD::SqlEngine', },
sqlite_ => { class => 'DBD::SQLite', },
syb_ => { class => 'DBD::Sybase', },
sys_ => { class => 'DBD::Sys', },