diff options
Diffstat (limited to 'lib/DBI/DBD')
| -rw-r--r-- | lib/DBI/DBD/Metadata.pm | 493 | ||||
| -rw-r--r-- | lib/DBI/DBD/SqlEngine.pm | 1232 | ||||
| -rw-r--r-- | lib/DBI/DBD/SqlEngine/Developers.pod | 422 | ||||
| -rw-r--r-- | lib/DBI/DBD/SqlEngine/HowTo.pod | 218 |
4 files changed, 2365 insertions, 0 deletions
diff --git a/lib/DBI/DBD/Metadata.pm b/lib/DBI/DBD/Metadata.pm new file mode 100644 index 0000000..75f5b89 --- /dev/null +++ b/lib/DBI/DBD/Metadata.pm @@ -0,0 +1,493 @@ +package DBI::DBD::Metadata; + +# $Id: Metadata.pm 14213 2010-06-30 19:29:18Z mjevans $ +# +# Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann, +# Steffen Goeldner and Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use Exporter (); +use Carp; + +use DBI; +use DBI::Const::GetInfoType qw(%GetInfoType); + +# Perl 5.005_03 does not recognize 'our' +@ISA = qw(Exporter); +@EXPORT = qw(write_getinfo_pm write_typeinfo_pm); + +$VERSION = sprintf("2.%06d", q$Revision: 14213 $ =~ /(\d+)/o); + + +use strict; + +=head1 NAME + +DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods + +=head1 SYNOPSIS + +The idea is to extract metadata information from a good quality +ODBC driver and use it to generate code and data to use in your own +DBI driver for the same database. + +To generate code to support the get_info method: + + perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" + + perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver + +To generate code to support the type_info method: + + perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" + + perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver + +Where C<dbi:ODBC:dsn-name> is the connection to use to extract the +data, and C<Driver> is the name of the driver you want the code +generated for (the driver name gets embedded into the output in +numerous places). + +=head1 Generating a GetInfo package for a driver + +The C<write_getinfo_pm> in the DBI::DBD::Metadata module generates a +DBD::Driver::GetInfo package on standard output. + +This method generates a DBD::Driver::GetInfo package from the data +source you specified in the parameter list or in the environment +variable DBI_DSN. +DBD::Driver::GetInfo should help a DBD author implement the DBI +get_info() method. +Because you are just creating this package, it is very unlikely that +DBD::Driver already provides a good implementation for get_info(). +Thus you will probably connect via DBD::ODBC. + +Once you are sure that it is producing reasonably sane data, you should +typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and +then hand edit the result. +Do not forget to update your Makefile.PL and MANIFEST to include this as +an extra PM file that should be installed. + +If you connect via DBD::ODBC, you should use version 0.38 or greater; + +Please take a critical look at the data returned! +ODBC drivers vary dramatically in their quality. + +The generator assumes that most values are static and places these +values directly in the %info hash. +A few examples show the use of CODE references and the implementation +via subroutines. +It is very likely that you will have to write additional subroutines for +values depending on the session state or server version, e.g. +SQL_DBMS_VER. + +A possible implementation of DBD::Driver::db::get_info() may look like: + + sub get_info { + my($dbh, $info_type) = @_; + require DBD::Driver::GetInfo; + my $v = $DBD::Driver::GetInfo::info{int($info_type)}; + $v = $v->($dbh) if ref $v eq 'CODE'; + return $v; + } + +Please replace Driver (or "<foo>") with the name of your driver. +Note that this stub function is generated for you by write_getinfo_pm +function, but you must manually transfer the code to Driver.pm. + +=cut + +sub write_getinfo_pm +{ + my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; + my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1}); + $driver = "<foo>" unless defined $driver; + + print <<PERL; + +# Transfer this to ${driver}.pm + +# The get_info function was automatically generated by +# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::db; # This line can be removed once transferred. + + sub get_info { + my(\$dbh, \$info_type) = \@_; + require DBD::${driver}::GetInfo; + my \$v = \$DBD::${driver}::GetInfo::info{int(\$info_type)}; + \$v = \$v->(\$dbh) if ref \$v eq 'CODE'; + return \$v; + } + +# Transfer this to lib/DBD/${driver}/GetInfo.pm + +# The \%info hash was automatically generated by +# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::GetInfo; + +use strict; +use DBD::${driver}; + +# Beware: not officially documented interfaces... +# use DBI::Const::GetInfoType qw(\%GetInfoType); +# use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues); + +my \$sql_driver = '${driver}'; +my \$sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.##### +my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION); +PERL + +my $kw_map = 0; +{ +# Informix CLI (ODBC) v3.81.0000 does not return a list of keywords. + local $\ = "\n"; + local $, = "\n"; + my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS}); + if ($kw) + { + print "\nmy \@Keywords = qw(\n"; + print sort split /,/, $kw; + print ");\n\n"; + print "sub sql_keywords {\n"; + print q% return join ',', @Keywords;%; + print "\n}\n\n"; + $kw_map = 1; + } +} + + print <<'PERL'; + +sub sql_data_source_name { + my $dbh = shift; + return "dbi:$sql_driver:" . $dbh->{Name}; +} + +sub sql_user_name { + my $dbh = shift; + # CURRENT_USER is a non-standard attribute, probably undef + # Username is a standard DBI attribute + return $dbh->{CURRENT_USER} || $dbh->{Username}; +} + +PERL + + print "\nour \%info = (\n"; + foreach my $key (sort keys %GetInfoType) + { + my $num = $GetInfoType{$key}; + my $val = eval { $dbh->get_info($num); }; + if ($key eq 'SQL_DATA_SOURCE_NAME') { + $val = '\&sql_data_source_name'; + } + elsif ($key eq 'SQL_KEYWORDS') { + $val = ($kw_map) ? '\&sql_keywords' : 'undef'; + } + elsif ($key eq 'SQL_DRIVER_NAME') { + $val = "\$INC{'DBD/$driver.pm'}"; + } + elsif ($key eq 'SQL_DRIVER_VER') { + $val = '$sql_driver_ver'; + } + elsif ($key eq 'SQL_USER_NAME') { + $val = '\&sql_user_name'; + } + elsif (not defined $val) { + $val = 'undef'; + } + elsif ($val eq '') { + $val = "''"; + } + elsif ($val =~ /\D/) { + $val =~ s/\\/\\\\/g; + $val =~ s/'/\\'/g; + $val = "'$val'"; + } + printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key; + } + print ");\n\n1;\n\n__END__\n"; +} + + + +=head1 Generating a TypeInfo package for a driver + +The C<write_typeinfo_pm> function in the DBI::DBD::Metadata module generates +on standard output the data needed for a driver's type_info_all method. +It also provides default implementations of the type_info_all +method for inclusion in the driver's main implementation file. + +The driver parameter is the name of the driver for which the methods +will be generated; for the sake of examples, this will be "Driver". +Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn", +where the odbc_dsn is a DSN for one of the driver's databases. +The user and pass parameters are the other optional connection +parameters that will be provided to the DBI connect method. + +Once you are sure that it is producing reasonably sane data, you should +typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm, +and then hand edit the result if necessary. +Do not forget to update your Makefile.PL and MANIFEST to include this as +an extra PM file that should be installed. + +Please take a critical look at the data returned! +ODBC drivers vary dramatically in their quality. + +The generator assumes that all the values are static and places these +values directly in the %info hash. + +A possible implementation of DBD::Driver::type_info_all() may look like: + + sub type_info_all { + my ($dbh) = @_; + require DBD::Driver::TypeInfo; + return [ @$DBD::Driver::TypeInfo::type_info_all ]; + } + +Please replace Driver (or "<foo>") with the name of your driver. +Note that this stub function is generated for you by the write_typeinfo_pm +function, but you must manually transfer the code to Driver.pm. + +=cut + + +# These two are used by fmt_value... +my %dbi_inv; +my %sql_type_inv; + +#-DEBUGGING-# +#sub print_hash +#{ +# my ($name, %hash) = @_; +# print "Hash: $name\n"; +# foreach my $key (keys %hash) +# { +# print "$key => $hash{$key}\n"; +# } +#} +#-DEBUGGING-# + +sub inverse_hash +{ + my (%hash) = @_; + my (%inv); + foreach my $key (keys %hash) + { + my $val = $hash{$key}; + die "Double mapping for key value $val ($inv{$val}, $key)!" + if (defined $inv{$val}); + $inv{$val} = $key; + } + return %inv; +} + +sub fmt_value +{ + my ($num, $val) = @_; + if (!defined $val) + { + $val = "undef"; + } + elsif ($val !~ m/^[-+]?\d+$/) + { + # All the numbers in type_info_all are integers! + # Anything that isn't an integer is a string. + # Ensure that no double quotes screw things up. + $val =~ s/"/\\"/g if ($val =~ m/"/o); + $val = qq{"$val"}; + } + elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/) + { + # All numeric... + $val = $sql_type_inv{$val} + if (defined $sql_type_inv{$val}); + } + return $val; +} + +sub write_typeinfo_pm +{ + my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; + my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1}); + $driver = "<foo>" unless defined $driver; + + print <<PERL; + +# Transfer this to ${driver}.pm + +# The type_info_all function was automatically generated by +# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::db; # This line can be removed once transferred. + + sub type_info_all + { + my (\$dbh) = \@_; + require DBD::${driver}::TypeInfo; + return [ \@\$DBD::${driver}::TypeInfo::type_info_all ]; + } + +# Transfer this to lib/DBD/${driver}/TypeInfo.pm. +# Don't forget to add version and intellectual property control information. + +# The \%type_info_all hash was automatically generated by +# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::TypeInfo; + +{ + require Exporter; + require DynaLoader; + \@ISA = qw(Exporter DynaLoader); + \@EXPORT = qw(type_info_all); + use DBI qw(:sql_types); + +PERL + + # Generate SQL type name mapping hashes. + # See code fragment in DBI specification. + my %sql_type_map; + foreach (@{$DBI::EXPORT_TAGS{sql_types}}) + { + no strict 'refs'; + $sql_type_map{$_} = &{"DBI::$_"}(); + $sql_type_inv{$sql_type_map{$_}} = $_; + } + #-DEBUG-# print_hash("sql_type_map", %sql_type_map); + #-DEBUG-# print_hash("sql_type_inv", %sql_type_inv); + + my %dbi_map = + ( + TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + FIXED_PREC_SCALE => 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + SQL_DATA_TYPE => 15, + SQL_DATETIME_SUB => 16, + NUM_PREC_RADIX => 17, + INTERVAL_PRECISION => 18, + ); + + #-DEBUG-# print_hash("dbi_map", %dbi_map); + + %dbi_inv = inverse_hash(%dbi_map); + + #-DEBUG-# print_hash("dbi_inv", %dbi_inv); + + my $maxlen = 0; + foreach my $key (keys %dbi_map) + { + $maxlen = length($key) if length($key) > $maxlen; + } + + # Print the name/value mapping entry in the type_info_all array; + my $fmt = " \%-${maxlen}s => \%2d,\n"; + my $numkey = 0; + my $maxkey = 0; + print " \$type_info_all = [\n {\n"; + foreach my $i (sort { $a <=> $b } keys %dbi_inv) + { + printf($fmt, $dbi_inv{$i}, $i); + $numkey++; + $maxkey = $i; + } + print " },\n"; + + print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n" + unless $numkey = $maxkey + 1; + + my $h = $dbh->type_info_all; + my @tia = @$h; + my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]}; + shift @tia; # Remove the mapping reference. + my $numtyp = $#tia; + + #-DEBUG-# print_hash("odbc_map", %odbc_map); + + # In theory, the key/number mapping sequence for %dbi_map + # should be the same as the one from the ODBC driver. However, to + # prevent the possibility of mismatches, and to deal with older + # missing attributes or unexpected new ones, we chase back through + # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc + # to map our new key number to the old one. + # Report if @dbi_to_odbc is not an identity mapping. + my @dbi_to_odbc; + foreach my $num (sort { $a <=> $b } keys %dbi_inv) + { + # Find the name in %dbi_inv that matches this index number. + my $dbi_key = $dbi_inv{$num}; + #-DEBUG-# print "dbi_key = $dbi_key\n"; + #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n"; + # Find the index in %odbc_map that has this key. + $dbi_to_odbc[$num] = (defined $odbc_map{$dbi_key}) ? $odbc_map{$dbi_key} : undef; + } + + # Determine the length of the longest formatted value in each field + my @len; + for (my $i = 0; $i <= $numtyp; $i++) + { + my @odbc_val = @{$tia[$i]}; + for (my $num = 0; $num <= $maxkey; $num++) + { + # Find the value of the entry in the @odbc_val array. + my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; + $val = fmt_value($num, $val); + #-DEBUG-# print "val = $val\n"; + $val = "$val,"; + $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num]; + } + } + + # Generate format strings to left justify each string in maximum field width. + my @fmt; + for (my $i = 0; $i <= $maxkey; $i++) + { + $fmt[$i] = "%-$len[$i]s"; + #-DEBUG-# print "fmt[$i] = $fmt[$i]\n"; + } + + # Format the data from type_info_all + for (my $i = 0; $i <= $numtyp; $i++) + { + my @odbc_val = @{$tia[$i]}; + print " [ "; + for (my $num = 0; $num <= $maxkey; $num++) + { + # Find the value of the entry in the @odbc_val array. + my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; + $val = fmt_value($num, $val); + printf $fmt[$num], "$val,"; + } + print " ],\n"; + } + + print " ];\n\n 1;\n}\n\n__END__\n"; + +} + +1; + +__END__ + +=head1 AUTHORS + +Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>), +Jochen Wiedmann <joe@ispsoft.de>, +Steffen Goeldner <sgoeldner@cpan.org>, +and Tim Bunce <dbi-users@perl.org>. + +=cut diff --git a/lib/DBI/DBD/SqlEngine.pm b/lib/DBI/DBD/SqlEngine.pm new file mode 100644 index 0000000..ae5c115 --- /dev/null +++ b/lib/DBI/DBD/SqlEngine.pm @@ -0,0 +1,1232 @@ +# -*- 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.03"; + +$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); + if ($prefix) + { + 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 $dbh = DBI::_new_dbh( + $drh, + { + Name => $dbname, + USER => $user, + CURRENT_USER => $user, + } + ); + + if ($dbh) + { + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->func( 0, "init_default_attributes" ); + my $two_phased_init; + defined $dbh->{sql_init_phase} and $two_phased_init = ++$dbh->{sql_init_phase}; + my %second_phase_attrs; + + 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; + if ($two_phased_init) + { + eval { $dbh->STORE( $var, $val ); }; + $@ and $second_phase_attrs{$var} = $val; + } + else + { + $dbh->STORE( $var, $val ); + } + } + elsif ( $var =~ m/^(.+?)=>(.*)/s ) + { + $var = $1; + ( $val = $2 ) =~ s/\\(.)/$1/g; + my $ref = eval $val; + $dbh->$var($ref); + } + } + + if ($two_phased_init) + { + foreach $a (qw(Profile RaiseError PrintError AutoCommit)) + { # do these first + exists $attr->{$a} or next; + eval { + $dbh->{$a} = $attr->{$a}; + delete $attr->{$a}; + }; + $@ and $second_phase_attrs{$a} = delete $attr->{$a}; + } + while ( my ( $a, $v ) = each %$attr ) + { + eval { $dbh->{$a} = $v }; + $@ and $second_phase_attrs{$a} = $v; + } + + $dbh->func( 1, "init_default_attributes" ); + %$attr = %second_phase_attrs; + } + + $dbh->func("init_done"); + + $dbh->STORE( Active => 1 ); + } + + return $dbh; +} # 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 ($@ || $stmt->{errstr}) + { + $dbh->set_err( $DBI::stderr, $@ || $stmt->{errstr} ); + undef $sth; + } + else + { + $sth->STORE( "sql_stmt", $stmt ); + $sth->STORE( "sql_params", [] ); + $sth->STORE( "NUM_OF_PARAMS", scalar( $stmt->params() ) ); + my @colnames = $sth->sql_get_colnames(); + $sth->STORE( "NUM_OF_FIELDS", scalar @colnames ); + } + } + return $sth; +} # prepare + +sub set_versions +{ + my $dbh = $_[0]; + $dbh->{sql_engine_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_engine_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_dialect => 1, # dialect 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 + sql_init_phase => 1, # Only during initialization + }; + $dbh->{sql_readonly_attrs} = { + sql_engine_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, $phase ) = @_; + my $given_phase = $phase; + + unless ( defined($phase) ) + { + # we have an "old" driver here + $phase = defined $dbh->{sql_init_phase}; + $phase and $phase = $dbh->{sql_init_phase}; + } + + if ( 0 == $phase ) + { + # 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 + + $dbh->{sql_dialect} = "CSV"; + + $dbh->{sql_init_phase} = $given_phase; + + # 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 init_done +{ + defined $_[0]->{sql_init_phase} and delete $_[0]->{sql_init_phase}; + delete $_[0]->{sql_valid_attrs}->{sql_init_phase}; + return; +} + +sub sql_parser_object +{ + my $dbh = $_[0]; + my $dialect = $dbh->{sql_dialect} || "CSV"; + my $parser = { + RaiseError => $dbh->FETCH("RaiseError"), + PrintError => $dbh->FETCH("PrintError"), + }; + my $sql_flags = $dbh->FETCH("sql_flags") || {}; + %$parser = ( %$parser, %$sql_flags ); + $parser = SQL::Parser->new( $dialect, $parser ); + $dbh->{sql_parser_object} = $parser; + return $parser; +} # 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; + + # Driver private attributes are lower cased + if ( $attrib eq ( lc $attrib ) ) + { + # first let the implementation deliver an alias for the attribute to fetch + # after it validates the legitimation of the fetch request + $attrib = $dbh->func( $attrib, "validate_FETCH_attr" ) or return; + + 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 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_engine_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) + { + # rt69260 and rt67223 - the same issue in 2 different queues + push @table_list, $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 ( $type == DBI::SQL_BIGINT() + || $type == DBI::SQL_INTEGER() + || $type == DBI::SQL_SMALLINT() + || $type == DBI::SQL_TINYINT() ) + { + $val += 0; + } + elsif ( $type == DBI::SQL_DECIMAL() + || $type == DBI::SQL_DOUBLE() + || $type == DBI::SQL_FLOAT() + || $type == DBI::SQL_NUMERIC() + || $type == 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 = $_[0]; + $sth->SUPER::STORE( Active => 0 ); + delete $sth->{sql_stmt}{data}; + return 1; +} # finish + +sub fetch ($) +{ + my $sth = $_[0]; + 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") ) # XXX: (TODO) Only chop on CHAR fields, + { # not on VARCHAR or NUMERIC (see DBI docs) + $_ && $_ =~ s/ +$// for @$dav; + } + return $sth->_set_fbav($dav); +} # fetch + +no warnings 'once'; +*fetchrow_arrayref = \&fetch; + +use warnings; + +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 $stmt = $sth->{sql_stmt} || {}; + my @coldefs = @{ $stmt->{column_defs} || [] }; + @colnames = map { $_->{name} || $_->{value} } @coldefs; + } + @colnames = $sth->{sql_stmt}->column_names() unless (@colnames); + + @colnames = () if ( grep { m/\*/ } @colnames ); + + return @colnames; +} + +sub FETCH ($$) +{ + my ( $sth, $attrib ) = @_; + + $attrib eq "NAME" and return [ $sth->sql_get_colnames() ]; + + $attrib eq "TYPE" and return [ (DBI::SQL_VARCHAR()) x scalar $sth->sql_get_colnames() ]; + $attrib eq "TYPE_NAME" and return [ ("VARCHAR") x scalar $sth->sql_get_colnames() ]; + $attrib eq "PRECISION" and return [ (0) x scalar $sth->sql_get_colnames() ]; + $attrib eq "NULLABLE" and return [ (1) x scalar $sth->sql_get_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 ) = @_; + 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); + +=pod + +=head1 NAME + +DBI::DBD::SqlEngine - Base class for DBI drivers without their own SQL engine + +=head1 SYNOPSIS + + package DBD::myDriver; + + use base qw(DBI::DBD::SqlEngine); + + sub driver + { + ... + my $drh = $proto->SUPER::driver($attr); + ... + return $drh->{class}; + } + + package DBD::myDriver::dr; + + @ISA = qw(DBI::DBD::SqlEngine::dr); + + sub data_sources { ... } + ... + + package DBD::myDriver::db; + + @ISA = qw(DBI::DBD::SqlEngine::db); + + sub init_valid_attributes { ... } + sub init_default_attributes { ... } + sub set_versions { ... } + sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } + sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } + sub get_myd_versions { ... } + sub get_avail_tables { ... } + + package DBD::myDriver::st; + + @ISA = qw(DBI::DBD::SqlEngine::st); + + sub FETCH { ... } + sub STORE { ... } + + package DBD::myDriver::Statement; + + @ISA = qw(DBI::DBD::SqlEngine::Statement); + + sub open_table { ... } + + package DBD::myDriver::Table; + + @ISA = qw(DBI::DBD::SqlEngine::Table); + + sub new { ... } + +=head1 DESCRIPTION + +DBI::DBD::SqlEngine abstracts the usage of SQL engines from the +DBD. DBD authors can concentrate on the data retrieval they want to +provide. + +It is strongly recommended that you read L<DBD::File::Developers> and +L<DBD::File::Roadmap>, because many of the DBD::File API is provided +by DBI::DBD::SqlEngine. + +Currently the API of DBI::DBD::SqlEngine is experimental and will +likely change in the near future to provide the table meta data basics +like DBD::File. + +=head2 Metadata + +The following attributes are handled by DBI itself and not by +DBI::DBD::SqlEngine, thus they all work as expected: + + Active + ActiveKids + CachedKids + CompatMode (Not used) + InactiveDestroy + AutoInactiveDestroy + Kids + PrintError + RaiseError + Warn (Not used) + +=head3 The following DBI attributes are handled by DBI::DBD::SqlEngine: + +=head4 AutoCommit + +Always on. + +=head4 ChopBlanks + +Works. + +=head4 NUM_OF_FIELDS + +Valid after C<< $sth->execute >>. + +=head4 NUM_OF_PARAMS + +Valid after C<< $sth->prepare >>. + +=head4 NAME + +Valid after C<< $sth->execute >>; probably undef for Non-Select statements. + +=head4 NULLABLE + +Not really working, always returns an array ref of ones, as DBD::CSV +does not verify input data. Valid after C<< $sth->execute >>; undef for +non-select statements. + +=head3 The following DBI attributes and methods are not supported: + +=over 4 + +=item bind_param_inout + +=item CursorName + +=item LongReadLen + +=item LongTruncOk + +=back + +=head3 DBI::DBD::SqlEngine specific attributes + +In addition to the DBI attributes, you can use the following dbh +attributes: + +=head4 sql_engine_version + +Contains the module version of this driver (B<readonly>) + +=head4 sql_nano_version + +Contains the module version of DBI::SQL::Nano (B<readonly>) + +=head4 sql_statement_version + +Contains the module version of SQL::Statement, if available (B<readonly>) + +=head4 sql_handler + +Contains the SQL Statement engine, either DBI::SQL::Nano or SQL::Statement +(B<readonly>). + +=head4 sql_parser_object + +Contains an instantiated instance of SQL::Parser (B<readonly>). +This is filled when used first time (only when used with SQL::Statement). + +=head4 sql_sponge_driver + +Contains an internally used DBD::Sponge handle (B<readonly>). + +=head4 sql_valid_attrs + +Contains the list of valid attributes for each DBI::DBD::SqlEngine based +driver (B<readonly>). + +=head4 sql_readonly_attrs + +Contains the list of those attributes which are readonly (B<readonly>). + +=head4 sql_identifier_case + +Contains how DBI::DBD::SqlEngine deals with non-quoted SQL identifiers: + + * SQL_IC_UPPER (1) means all identifiers are internally converted + into upper-cased pendants + * SQL_IC_LOWER (2) means all identifiers are internally converted + into lower-cased pendants + * SQL_IC_MIXED (4) means all identifiers are taken as they are + +These conversions happen if (and only if) no existing identifier matches. +Once existing identifier is used as known. + +The SQL statement execution classes doesn't have to care, so don't expect +C<sql_identifier_case> affects column names in statements like + + SELECT * FROM foo + +=head4 sql_quoted_identifier_case + +Contains how DBI::DBD::SqlEngine deals with quoted SQL identifiers +(B<readonly>). It's fixated to SQL_IC_SENSITIVE (3), which is interpreted +as SQL_IC_MIXED. + +=head4 sql_flags + +Contains additional flags to instantiate an SQL::Parser. Because an +SQL::Parser is instantiated only once, it's recommended to set this flag +before any statement is executed. + +=head4 sql_dialect + +Controls the dialect understood by SQL::Parser. Possible values (delivery +state of SQL::Statement): + + * ANSI + * CSV + * AnyData + +Defaults to "CSV". Because an SQL::Parser is instantiated only once and +SQL::Parser doesn't allow to modify the dialect once instantiated, +it's strongly recommended to set this flag before any statement is +executed (best place is connect attribute hash). + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc DBI::DBD::SqlEngine + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBI> +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Statement> + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/DBI> +L<http://annocpan.org/dist/SQL-Statement> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/d/DBI> + +=item * Search CPAN + +L<http://search.cpan.org/dist/DBI/> + +=back + +=head2 Where can I go for more help? + +For questions about installation or usage, please ask on the +dbi-dev@perl.org mailing list. + +If you have a bug report, patch or suggestion, please open +a new report ticket on CPAN, if there is not already one for +the issue you want to report. Of course, you can mail any of the +module maintainers, but it is less likely to be missed if +it is reported on RT. + +Report tickets should contain a detailed description of the bug or +enhancement request you want to report and at least an easy way to +verify/reproduce the issue and any supplied fix. Patches are always +welcome, too. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Tim Bunce, Martin Evans and H.Merijn Brand for their continued +support while developing DBD::File, DBD::DBM and DBD::AnyData. +Their support, hints and feedback helped to design and implement this +module. + +=head1 AUTHOR + +This module is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +The original authors are Jochen Wiedmann and Jeff Zucker. + +=head1 COPYRIGHT AND LICENSE + + Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack + Copyright (C) 2004-2009 by Jeff Zucker + Copyright (C) 1998-2004 by Jochen Wiedmann + +All rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=head1 SEE ALSO + +L<DBI>, L<DBD::File>, L<DBD::AnyData> and L<DBD::Sys>. + +=cut diff --git a/lib/DBI/DBD/SqlEngine/Developers.pod b/lib/DBI/DBD/SqlEngine/Developers.pod new file mode 100644 index 0000000..2ee3a5f --- /dev/null +++ b/lib/DBI/DBD/SqlEngine/Developers.pod @@ -0,0 +1,422 @@ +=head1 NAME + +DBI::DBD::SqlEngine::Developers - Developers documentation for DBI::DBD::SqlEngine + +=head1 SYNOPSIS + + package DBD::myDriver; + + use base qw(DBI::DBD::SqlEngine); + + sub driver + { + ... + my $drh = $proto->SUPER::driver($attr); + ... + return $drh->{class}; + } + + sub CLONE { ... } + + package DBD::myDriver::dr; + + @ISA = qw(DBI::DBD::SqlEngine::dr); + + sub data_sources { ... } + ... + + package DBD::myDriver::db; + + @ISA = qw(DBI::DBD::SqlEngine::db); + + sub init_valid_attributes { ... } + sub init_default_attributes { ... } + sub set_versions { ... } + sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } + sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } + sub get_myd_versions { ... } + sub get_avail_tables { ... } + + package DBD::myDriver::st; + + @ISA = qw(DBI::DBD::SqlEngine::st); + + sub FETCH { ... } + sub STORE { ... } + + package DBD::myDriver::Statement; + + @ISA = qw(DBI::DBD::SqlEngine::Statement); + + sub open_table { ... } + + package DBD::myDriver::Table; + + @ISA = qw(DBI::DBD::SqlEngine::Table); + + sub new { ... } + + sub fetch_row { ... } + sub push_row { ... } + sub push_names { ... } + sub seek { ... } + sub truncate { ... } + sub drop { ... } + + # optimize the SQL engine by add one or more of + sub update_current_row { ... } + # or + sub update_specific_row { ... } + # or + sub update_one_row { ... } + # or + sub insert_new_row { ... } + # or + sub delete_current_row { ... } + # or + sub delete_one_row { ... } + +=head1 DESCRIPTION + +This document describes the interface of DBI::DBD::SqlEngine for DBD +developers who write DBI::DBD::SqlEngine based DBI drivers. It supplements +L<DBI::DBD> and L<DBI::DBD::SqlEngine::HowTo>, which you should read first. + +=head1 CLASSES + +Each DBI driver must provide a package global C<< driver >> method and +three DBI related classes: + +=over 4 + +=item DBI::DBD::SqlEngine::dr + +Driver package, contains the methods DBI calls indirectly via DBI +interface: + + DBI->connect ('DBI:DBM:', undef, undef, {}) + + # invokes + package DBD::DBM::dr; + @DBD::DBM::dr::ISA = qw(DBI::DBD::SqlEngine::dr); + + sub connect ($$;$$$) + { + ... + } + +Similar for C<< data_sources () >> and C<< disconnect_all() >>. + +Pure Perl DBI drivers derived from DBI::DBD::SqlEngine do not usually need to +override any of the methods provided through the DBD::XXX::dr package +however if you need additional initialization in the connect method +you may need to. + +=item DBI::DBD::SqlEngine::db + +Contains the methods which are called through DBI database handles +(C<< $dbh >>). e.g., + + $sth = $dbh->prepare ("select * from foo"); + # returns the f_encoding setting for table foo + $dbh->csv_get_meta ("foo", "f_encoding"); + +DBI::DBD::SqlEngine provides the typical methods required here. Developers who +write DBI drivers based on DBI::DBD::SqlEngine need to override the methods +C<< set_versions >> and C<< init_valid_attributes >>. + +=item DBI::DBD::SqlEngine::st + +Contains the methods to deal with prepared statement handles. e.g., + + $sth->execute () or die $sth->errstr; + +=back + +=head2 DBI::DBD::SqlEngine + +This is the main package containing the routines to initialize +DBI::DBD::SqlEngine based DBI drivers. Primarily the +C<< DBI::DBD::SqlEngine::driver >> method is invoked, either directly +from DBI when the driver is initialized or from the derived class. + + package DBD::DBM; + + use base qw( DBI::DBD::SqlEngine ); + + sub driver + { + my ( $class, $attr ) = @_; + ... + my $drh = $class->SUPER::driver( $attr ); + ... + return $drh; + } + +It is not necessary to implement your own driver method as long as +additional initialization (e.g. installing more private driver +methods) is not required. You do not need to call C<< setup_driver >> +as DBI::DBD::SqlEngine takes care of it. + +=head2 DBI::DBD::SqlEngine::dr + +The driver package contains the methods DBI calls indirectly via the DBI +interface (see L<DBI/DBI Class Methods>). + +DBI::DBD::SqlEngine based DBI drivers usually do not need to implement anything here, +it is enough to do the basic initialization: + + package DBD:XXX::dr; + + @DBD::XXX::dr::ISA = qw (DBI::DBD::SqlEngine::dr); + $DBD::XXX::dr::imp_data_size = 0; + $DBD::XXX::dr::data_sources_attr = undef; + $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; + +=head2 DBI::DBD::SqlEngine::db + +This package defines the database methods, which are called via the DBI +database handle C<< $dbh >>. + +Methods provided by DBI::DBD::SqlEngine: + +=over 4 + +=item ping + +Simply returns the content of the C<< Active >> attribute. Override +when your driver needs more complicated actions here. + +=item prepare + +Prepares a new SQL statement to execute. Returns a statement handle, +C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor +recommended to override this method. + +=item FETCH + +Fetches an attribute of a DBI database object. Private handle attributes +must have a prefix (this is mandatory). If a requested attribute is +detected as a private attribute without a valid prefix, the driver prefix +(written as C<$drv_prefix>) is added. + +The driver prefix is extracted from the attribute name and verified against +C<< $dbh->{ $drv_prefix . "valid_attrs" } >> (when it exists). If the +requested attribute value is not listed as a valid attribute, this method +croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ +$drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the +attribute value is returned. So it's not possible to modify +C<f_valid_attrs> from outside of DBI::DBD::SqlEngine::db or a derived class. + +=item STORE + +Stores a database private attribute. Private handle attributes must have a +prefix (this is mandatory). If a requested attribute is detected as a private +attribute without a valid prefix, the driver prefix (written as +C<$drv_prefix>) is added. If the database handle has an attribute +C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in +that hash, this method croaks. If the database handle has an attribute +C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there +can be stored (once they are initialized). Trying to overwrite such an +immutable attribute forces this method to croak. + +An example of a valid attributes list can be found in +C<< DBI::DBD::SqlEngine::db::init_valid_attributes >>. + +=item set_versions + +This method sets the attributes C<< f_version >>, C<< sql_nano_version >>, +C<< sql_statement_version >> and (if not prohibited by a restrictive +C<< ${prefix}_valid_attrs >>) C<< ${prefix}_version >>. + +This method is called at the end of the C<< connect () >> phase. + +When overriding this method, do not forget to invoke the superior one. + +=item init_valid_attributes + +This method is called after the database handle is instantiated as the +first attribute initialization. + +C<< DBI::DBD::SqlEngine::db::init_valid_attributes >> initializes the +attributes C<sql_valid_attrs> and C<sql_readonly_attrs>. + +When overriding this method, do not forget to invoke the superior one, +preferably before doing anything else. + +=item init_default_attributes + +This method is called after the database handle is instantiated to +initialize the default attributes. + +C<< DBI::DBD::SqlEngine::db::init_default_attributes >> initializes the +attributes C<sql_identifier_case>, C<sql_quoted_identifier_case>, +C<sql_handler>, C<sql_engine_version>, C<sql_nano_version> and +C<sql_statement_version> when L<SQL::Statement> is available. + +When the derived implementor class provides the attribute to validate +attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute +containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} += {...}; >>), the attributes C<drv_valid_attrs>, C<drv_readonly_attrs> and +C<drv_version> are added (when available) to the list of valid and +immutable attributes (where C<drv_> is interpreted as the driver prefix). + +=item get_versions + +This method is called by the code injected into the instantiated driver to +provide the user callable driver method C<< ${prefix}versions >> (e.g. +C<< dbm_versions >>, C<< csv_versions >>, ...). + +The DBI::DBD::SqlEngine implementation returns all version information known by +DBI::DBD::SqlEngine (e.g. DBI version, Perl version, DBI::DBD::SqlEngine version and +the SQL handler version). + +C<get_versions> takes the C<$dbh> as the first argument and optionally a +second argument containing a table name. The second argument is not +evaluated in C<< DBI::DBD::SqlEngine::db::get_versions >> itself - but +might be in the future. + +If the derived implementor class provides a method named +C<get_${drv_prefix}versions>, this is invoked and the return value of +it is associated to the derived driver name: + + if (my $dgv = $dbh->{ImplementorClass}->can ("get_" . $drv_prefix . "versions") { + (my $derived_driver = $dbh->{ImplementorClass}) =~ s/::db$//; + $versions{$derived_driver} = &$dgv ($dbh, $table); + } + +Override it to add more version information about your module, (e.g. +some kind of parser version in case of DBD::CSV, ...), if one line is not +enough room to provide all relevant information. + +=item sql_parser_object + +Returns a L<SQL::Parser> instance, when C<< sql_handler >> is set to +"SQL::Statement". The parser instance is stored in C<< sql_parser_object >>. + +It is not recommended to override this method. + +=item disconnect + +Disconnects from a database. All local table information is discarded and +the C<< Active >> attribute is set to 0. + +=item type_info_all + +Returns information about all the types supported by DBI::DBD::SqlEngine. + +=item table_info + +Returns a statement handle which is prepared to deliver information about +all known tables. + +=item list_tables + +Returns a list of all known table names. + +=item quote + +Quotes a string for use in SQL statements. + +=item commit + +Warns about a useless call (if warnings enabled) and returns. +DBI::DBD::SqlEngine is typically a driver which commits every action instantly when +executed. + +=item rollback + +Warns about a useless call (if warnings enabled) and returns. +DBI::DBD::SqlEngine is typically a driver which commits every action instantly when +executed. + +=back + +=head2 DBI::DBD::SqlEngine::st + +Contains the methods to deal with prepared statement handles: + +=over 4 + +=item bind_param + +Common routine to bind placeholders to a statement for execution. It +is dangerous to override this method without detailed knowledge about +the DBI::DBD::SqlEngine internal storage structure. + +=item execute + +Executes a previously prepared statement (with placeholders, if any). + +=item finish + +Finishes a statement handle, discards all buffered results. The prepared +statement is not discarded so the statement can be executed again. + +=item fetch + +Fetches the next row from the result-set. This method may be rewritten +in a later version and if it's overridden in a derived class, the +derived implementation should not rely on the storage details. + +=item fetchrow_arrayref + +Alias for C<< fetch >>. + +=item FETCH + +Fetches statement handle attributes. Supported attributes (for full overview +see L<DBI/Statement Handle Attributes>) are C<NAME>, C<TYPE>, C<PRECISION> +and C<NULLABLE>. Each column is returned as C<NULLABLE> which might be wrong +depending on the derived backend storage. If the statement handle has +private attributes, they can be fetched using this method, too. B<Note> that +statement attributes are not associated with any table used in this statement. + +This method usually requires extending in a derived implementation. +See L<DBD::CSV> or L<DBD::DBM> for some example. + +=item STORE + +Allows storing of statement private attributes. No special handling is +currently implemented here. + +=item rows + +Returns the number of rows affected by the last execute. This method might +return C<undef>. + +=back + +=head2 DBI::DBD::SqlEngine::Statement + +Derives from DBI::SQL::Nano::Statement for unified naming when deriving +new drivers. No additional feature is provided from here. + +=head2 DBI::DBD::SqlEngine::Table + +Derives from DBI::SQL::Nano::Table for unified naming when deriving +new drivers. No additional feature is provided from here. + +You should consult the documentation of C<< SQL::Eval::Table >> (see +L<SQL::Eval>) to get more information about the abstract methods of the +table's base class you have to override and a description of the table +meta information expected by the SQL engines. + +=head1 AUTHOR + +The module DBI::DBD::SqlEngine is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +All rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=cut diff --git a/lib/DBI/DBD/SqlEngine/HowTo.pod b/lib/DBI/DBD/SqlEngine/HowTo.pod new file mode 100644 index 0000000..764dd08 --- /dev/null +++ b/lib/DBI/DBD/SqlEngine/HowTo.pod @@ -0,0 +1,218 @@ +=head1 NAME + +DBI::DBD::SqlEngine::HowTo - Guide to create DBI::DBD::SqlEngine based driver + +=head1 SYNOPSIS + + perldoc DBI::DBD::SqlEngine::HowTo + perldoc DBI + perldoc DBI::DBD + perldoc DBI::DBD::SqlEngine::Developers + perldoc SQL::Eval + perldoc DBI::DBD::SqlEngine + perldoc DBI::DBD::SqlEngine::HowTo + perldoc SQL::Statement::Embed + +=head1 DESCRIPTION + +This document provides a step-by-step guide, how to create a new +C<DBI::DBD::SqlEngine> based DBD. It expects that you carefully read the +L<DBI> documentation and that you're familiar with L<DBI::DBD> and had +read and understood L<DBD::ExampleP>. + +This document addresses experienced developers who are really sure that +they need to invest time when writing a new DBI Driver. Writing a DBI +Driver is neither a weekend project nor an easy job for hobby coders +after work. Expect one or two man-month of time for the first start. + +Those who are still reading, should be able to sing the rules of +L<DBI::DBD/CREATING A NEW DRIVER>. + +=head1 CREATING DRIVER CLASSES + +Do you have an entry in DBI's DBD registry? For this guide, a prefix of +C<foo_> is assumed. + +=head2 Sample Skeleton + + package DBD::Foo; + + use strict; + use warnings; + use vars qw($VERSION); + use base qw(DBI::DBD::SqlEngine); + + use DBI (); + + $VERSION = "0.001"; + + package DBD::Foo::dr; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBI::DBD::SqlEngine::dr); + $imp_data_size = 0; + + package DBD::Foo::db; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBI::DBD::SqlEngine::db); + $imp_data_size = 0; + + package DBD::Foo::st; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBI::DBD::SqlEngine::st); + $imp_data_size = 0; + + package DBD::Foo::Statement; + + use vars qw(@ISA); + + @ISA = qw(DBI::DBD::SqlEngine::Statement); + + package DBD::Foo::Table; + + use vars qw(@ISA); + + @ISA = qw(DBI::DBD::SqlEngine::Table); + + 1; + +Tiny, eh? And all you have now is a DBD named foo which will is able to +deal with temporary tables, as long as you use L<SQL::Statement>. In +L<DBI::SQL::Nano> environments, this DBD can do nothing. + +=head2 Deal with own attributes + +Before we start doing usable stuff with our DBI driver, we need to think +about what we want to do and how we want to do it. + +Do we need tunable knobs accessible by users? Do we need status +information? All this is handled in attributes of the database handles (be +careful when your DBD is running "behind" a L<DBD::Gofer> proxy). + +How come the attributes into the DBD and how are they fetchable by the +user? Good question, but you should know because you've read the L<DBI> +documentation. + +C<DBI::DBD::SqlEngine::db::FETCH> and C<DBI::DBD::SqlEngine::db::STORE> +taking care for you - all they need to know is which attribute names +are valid and mutable or immutable. Tell them by adding +C<init_valid_attributes> to your db class: + + sub init_valid_attributes + { + my $dbh = $_[0]; + + $dbh->SUPER::init_valid_attributes (); + + $dbh->{foo_valid_attrs} = { + foo_version => 1, # contains version of this driver + foo_valid_attrs => 1, # contains the valid attributes of foo drivers + foo_readonly_attrs => 1, # contains immutable attributes of foo drivers + foo_bar => 1, # contains the bar attribute + foo_baz => 1, # contains the baz attribute + foo_manager => 1, # contains the manager of the driver instance + foo_manager_type => 1, # contains the manager class of the driver instance + }; + $dbh->{foo_readonly_attrs} = { + foo_version => 1, # ensure no-one modifies the driver version + foo_valid_attrs => 1, # do not permit to add more valid attributes ... + foo_readonly_attrs => 1, # ... or make the immutable mutable + foo_manager => 1, # manager is set internally only + }; + + return $dbh; + } + +Woooho - but now the user cannot assign new managers? This is intended, +overwrite C<STORE> to handle it! + + sub STORE ($$$) + { + my ( $dbh, $attrib, $value ) = @_; + + $dbh->SUPER::STORE( $attrib, $value ); + + # we're still alive, so no exception is thrown ... + # by DBI::DBD::SqlEngine::db::STORE + if ( $attrib eq "foo_manager_type" ) + { + $dbh->{foo_manager} = $dbh->{foo_manager_type}->new(); + # ... probably correct some states based on the new + # foo_manager_type - see DBD::Sys for an example + } + } + +But ... my driver runs without a manager until someone first assignes +a C<foo_manager_type>. Well, no - there're two places where you can +initialize defaults: + + sub init_default_attributes + { + my ($dbh, $phase) = @_; + + $dbh->SUPER::init_default_attributes($phase); + + if( 0 == $phase ) + { + # init all attributes which have no knowledge about + # user settings from DSN or the attribute hash + $dbh->{foo_manager_type} = "DBD::Foo::Manager"; + } + elsif( 1 == $phase ) + { + # init phase with more knowledge from DSN or attribute + # hash + $dbh->{foo_manager} = $dbh->{foo_manager_type}->new(); + } + + return $dbh; + } + +So far we can prevent the users to use our database driver as data +storage for anything and everything. We care only about the real important +stuff for peace on earth and alike attributes. But in fact, the driver +still can't do anything. It can do less than nothing - meanwhile it's +not a stupid storage area anymore. + +=head2 Dealing with Tables + +Let's put some life into it - it's going to be time for it. + +This is a good point where a quick side step to L<SQL::Statement::Embed> +will help to shorten the next paragraph. The documentation in +SQL::Statement::Embed regarding embedding in own DBD's works pretty +fine with SQL::Statement and DBI::SQL::Nano. + +=head2 Testing + +Now you should have your first own DBD. Was easy, wasn't it? But does +it work well? Prove it by writing tests and remember to use +dbd_edit_mm_attribs from L<DBI::DBD> to ensure testing even rare cases. + +=head1 AUTHOR + +This guide is written by Jens Rehsack. DBI::DBD::SqlEngine is written by +Jens Rehsack using code from DBD::File originally written by Jochen +Wiedmann and Jeff Zucker. + +The module DBI::DBD::SqlEngine is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +All rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=cut |