Author: REHSACK
Date: Mon Jun 28 02:10:12 2010
New Revision: 14186
Added:
dbi/trunk/lib/DBI/DBD/SqlEngine.pm
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
dbi/trunk/lib/DBI/SQL/Nano.pm
dbi/trunk/t/50dbm_simple.t
Log:
Extract dealing with Perl SQL engines from DBD::File into
DBI::DBD::SqlEngine for better subclassing of 3rd party non-db DBDs
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Jun 28 02:10:12 2010
@@ -38,6 +38,9 @@
Merged some optimizations from SQL::Statement into DBI::SQL::Nano
(Jens Rehsack)
Added basic test for DBD::File (H.Merijn Brand, Jens Rehsack)
+ Extract dealing with Perl SQL engines from DBD::File into
+ DBI::DBD::SqlEngine for better subclassing of 3rd party non-db DBDs
+ (Jens Rehsack)
Updated and clarified documentation for finish method (Tim Bunce).
Changes to DBD::File for better English and hopefully better
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Jun 28 02:10:12 2010
@@ -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', },
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Mon Jun 28 02:10:12 2010
@@ -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
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Mon Jun 28 02:10:12 2010
@@ -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,13 @@
sub get_dbm_versions
{
- my ($dbh, $table) = @_;
+ my ( $dbh, $table ) = @_;
$table ||= '';
- my $class = $dbh->FETCH ("ImplementorClass");
+ my $class = $dbh->{ImplementorClass};
$class =~ s/::db$/::Table/;
- my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
+ $table and
+ 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 +175,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 +204,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 +344,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 +400,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 +459,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 $key = shift @$row_aryref;
- exists($meta->{hash}->{$key}) and
- croak "Row with PK '$key' already exists";
+ 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;
+ my $exists;
+ eval { $exists = exists( $meta->{hash}->{$key} ); };
+ $exists
+ and croak "Row with PK '$key' already exists";
if ( $meta->{dbm_mldbm} )
{
@@ -553,14 +491,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;
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Mon Jun 28 02:10:12 2010
@@ -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,9 +280,7 @@
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->SUPER::init_default_attributes ();
# f_ext should not be initialized
# f_map is deprecated (but might return)
@@ -346,16 +288,13 @@
$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,151 +340,48 @@
return 1;
} # disconnect
-sub FETCH ($$)
-{
- 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 ($$$)
+sub validate_STORE_attr
{
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'");
- File::Spec->file_name_is_absolute ($value) or
- $value = Cwd::abs_path ($value);
- }
-
- if ($attrib eq "f_ext") {
- $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or
- 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
- }
-
- # 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";
- # }
+ if ($attrib eq "f_dir") {
+ -d $value or
+ return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
+ File::Spec->file_name_is_absolute ($value) or
+ $value = Cwd::abs_path ($value);
+ }
- $dbh->{$attrib} = $value;
- return 1;
+ if ($attrib eq "f_ext") {
+ $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or
+ carp "'$value' doesn't look like a valid file extension attribute\n";
}
- return $dbh->SUPER::STORE ($attrib, $value);
- } # STORE
+ return $dbh->SUPER::validate_STORE_attr ($attrib, $value);
+}
-sub get_versions
+sub get_f_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 $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;
- }
- $DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION;
+ my $class = $dbh->{ImplementorClass};
+ $class =~ s/::db$/::Table/;
+ $table and
+ my ( undef, $meta ) = $class->get_table_meta ($dbh, $table, 1);
+ $meta or ($meta = {} and $class->bootstrap_table_meta ($dbh, $meta, $table));
+
+ my $dbd_file_verinfo = $dbh->{f_version};
+
+ my $dver;
+ my $eval_str;
+ $eval_str = sprintf ('$dver = $%s::VERSION', "IO::File");
+ eval $eval_str;
+ my $dtype = "IO::File";
+ $dtype .= ' (' . $dver . ')' if $dver;
- 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;
+ $meta->{f_encoding} and $dtype .= " + " . $meta->{f_encoding} . " encoding";
- return wantarray ? @versions : join "\n", @versions;
- } # get_versions
+ return sprintf ("%s using %s", $dbh->{f_version}, $dtype);
+ } # get_f_versions
sub get_single_table_meta
{
@@ -658,157 +494,40 @@
return;
} # clear_file_meta
-sub DESTROY ($)
-{
- my $dbh = shift;
- $dbh->SUPER::FETCH ("Active") and $dbh->disconnect ;
- undef $dbh->{sql_parser_object};
- } # DESTROY
-
-sub type_info_all ($)
+sub get_avail_tables
{
- [ { 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 $names = [
- qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )];
-
- 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;
- }
-
- 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;
- }
- }
+ my $dbh = $_[0];
- # Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
- @tables or return;
+ my @tables = $dbh->SUPER::get_avail_tables ();
- my $sth = $dbh2->prepare ("TABLE_INFO", {
- rows => \@tables,
- NAMES => $names,
- });
- $sth or $dbh->set_err ($DBI::stderr, $dbh2->errstr);
- return $sth;
- } # table_info
- }
+ my $dir = $dbh->{f_dir};
+ my $dirh = Symbol::gensym ();
-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];
+ unless (opendir $dirh, $dir) {
+ $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
+ return @tables;
}
- return @tables;
- } # 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
+ 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: $!");
+ }
-sub rollback ($)
-{
- my $dbh = shift;
- $dbh->FETCH ("Warn") and
- carp "Rollback ineffective while AutoCommit is on", -1;
- return 0;
- } # rollback
+ return @tables;
+ } # get_avail_tables
# ====== Tie-Meta ==============================================================
@@ -963,163 +682,21 @@
package DBD::File::st;
use strict;
+use warnings;
-$DBD::File::st::imp_data_size = 0;
+use vars qw(@ISA $imp_data_size);
-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
+@DBD::File::st::ISA = qw(DBI::DBD::SqlEngine::st);
+$DBD::File::st::imp_data_size = 0;
# ====== SQL::STATEMENT ========================================================
package DBD::File::Statement;
use strict;
-use Carp;
-
-# Jochen's old check for flock ()
-#
-# my $locking = $^O ne "MacOS" &&
-# ($^O ne "MSWin32" || !Win32::IsWin95 ()) &&
-# $^O ne "VMS";
+use warnings;
-@DBD::File::Statement::ISA = qw( DBI::SQL::Nano::Statement );
+@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement );
sub open_table ($$$$$)
{
@@ -1142,6 +719,8 @@
package DBD::File::Table;
use strict;
+use warnings;
+
use Carp;
require IO::File;
require File::Basename;
@@ -1152,7 +731,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 +765,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 +774,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";
Added: dbi/trunk/lib/DBI/DBD/SqlEngine.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/DBD/SqlEngine.pm Mon Jun 28 02:10:12 2010
@@ -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);
+
Modified: dbi/trunk/lib/DBI/SQL/Nano.pm
==============================================================================
--- dbi/trunk/lib/DBI/SQL/Nano.pm (original)
+++ dbi/trunk/lib/DBI/SQL/Nano.pm Mon Jun 28 02:10:12 2010
@@ -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 . "\)";
Modified: dbi/trunk/t/50dbm_simple.t
==============================================================================
--- dbi/trunk/t/50dbm_simple.t (original)
+++ dbi/trunk/t/50dbm_simple.t Mon Jun 28 02:10:12 2010
@@ -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;
}
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.