Front page | perl.dbi.changes |
Postings from December 2012
[svn:dbi] r15542 - in dbi/trunk: . lib/DBD lib/DBD/File lib/DBI/DBD lib/DBI/DBD/SqlEngine lib/DBI/SQL t
From:
REHSACK
Date:
December 21, 2012 17:11
Subject:
[svn:dbi] r15542 - in dbi/trunk: . lib/DBD lib/DBD/File lib/DBI/DBD lib/DBI/DBD/SqlEngine lib/DBI/SQL t
Message ID:
20121221171132.E8F61184BA1@xx12.develooper.com
Author: REHSACK
Date: Fri Dec 21 09:11:32 2012
New Revision: 15542
Modified:
dbi/trunk/ (props changed)
dbi/trunk/.aspell.local.pws
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/git-svn-vsn.pl
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
dbi/trunk/lib/DBD/File/Developers.pod
dbi/trunk/lib/DBD/File/HowTo.pod
dbi/trunk/lib/DBD/File/Roadmap.pod
dbi/trunk/lib/DBI/DBD/SqlEngine.pm
dbi/trunk/lib/DBI/DBD/SqlEngine/Developers.pod
dbi/trunk/lib/DBI/DBD/SqlEngine/HowTo.pod
dbi/trunk/lib/DBI/SQL/Nano.pm
dbi/trunk/t/49dbd_file.t
dbi/trunk/t/50dbm_simple.t
dbi/trunk/t/85gofer.t
Log:
merge sqlengine branch into trunk
Modified: dbi/trunk/.aspell.local.pws
==============================================================================
--- dbi/trunk/.aspell.local.pws (original)
+++ dbi/trunk/.aspell.local.pws Fri Dec 21 09:11:32 2012
@@ -1,4 +1,4 @@
-personal_ws-1.1 en_EN 121
+personal_ws-1.1 en_EN 133
# checked files:
# - lib/DBD/DBM.pm
# - lib/DBD/File.pm
@@ -6,6 +6,7 @@
# - lib/DBD/File/Roadmap.pod
# - lib/DBI/DBD/Metadata.pm
# - lib/DBI/DBD/SqlEngine.pm
+# - lib/DBI/DBD/SqlEngine/Developers.pod
# - lib/DBI/SQL/Nano.pm
AIX
ALRM
@@ -54,6 +55,7 @@
Dunlop
EINTR
eval
+extensibility
filename
getinfo
GetInfo
@@ -66,15 +68,20 @@
hasn
Haworth
implementor
+indices
Informix
INI
+instantiation
+instantiations
IRC
isn
iso
JDBC
+Jens
Jochen
JOINs
jrehsack
+JSON
jzucker
lang
latin
@@ -97,11 +104,14 @@
multi
MyFancyLogger
namespace
+namespaces
Nano
nl
NULLABLE
ODBC
+optimizations
pag
+parametrized
pre
precompiled
readonly
@@ -113,11 +123,14 @@
Solaris
speeded
st
+Steffen
sth
Storable
+subclasses
subdirectories
txt
TypeInfo
+unlinked
unrecognised
usenet
UTF
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Dec 21 09:11:32 2012
@@ -8,21 +8,29 @@
=cut
-
-=head2 Changes in DBI 1.623 (svn r15467) 19th Nov 2012
+=head2 Changes in DBI 1.623 (svn r15467) 13th Dec 2012
Fixed RT#64330 - ping wipes out errstr (Martin J. Evans).
- Fixed RT#80474 - segfault in DESTROY with threads.
Fixed RT#75868 - DBD::Proxy shouldn't call connected() on the server.
+ Fixed RT#80474 - segfault in DESTROY with threads.
+ Fixed RT#81516 - Test failures due to hash randomisation in perl 5.17.6
+ thanks to Jens Rehsack and H.Merijn Brand and feedback on IRC
Fixed RT#81724 - Handle copy-on-write scalars (sprout)
Fixed unused variable / self-assignment compiler warnings.
-
Corrected typo in DBI->installed_versions docs RT#78825
thanks to Jan Dubois.
Corrected a spelling error thanks to Chris Sanders.
+ Fixed default table_info in DBI::DBD::SqlEngine which passed NAMES
+ attribute instead of NAME to DBD::Sponge RT72343 (Martin J. Evans)
+
+ Refactored table meta information management from DBD::File into
+ DBI::DBD::SqlEngine (H.Merijn Brand, Jens Rehsack)
+ Pevent undefined f_dir being used in opendir (H.Merijn Brand)
Added logic to force destruction of children before parents
- during global destruction. Re RT#75614.
+ during global destruction. See RT#75614.
+ Added DBD::File Plugin-Support for table names and data sources
+ (Jens Rehsack, #dbi Team)
Added new tests to 08keeperr for RT#64330
thanks to Kenichi Ishigaki.
Added extra internal handle type check, RT#79952
@@ -31,6 +39,10 @@
Removed internal _not_impl method (Martin J. Evans).
+ NOTE: The "old-style" DBD::DBM attributes 'dbm_ext' and 'dbm_lockfile'
+ had been deprecated for several years and their use will now generate
+ a warning.
+
=head2 Changes in DBI 1.622 (svn r15327) 6th June 2012
Fixed lack of =encoding in non-ASCII pod docs. RT#77588
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Fri Dec 21 09:11:32 2012
@@ -6805,13 +6805,13 @@
Type: array-ref, read-only
-Like L</NAME> but always returns lowercase names.
+Like C</NAME> but always returns lowercase names.
=head3 C<NAME_uc>
Type: array-ref, read-only
-Like L</NAME> but always returns uppercase names.
+Like C</NAME> but always returns uppercase names.
=head3 C<NAME_hash>
Modified: dbi/trunk/git-svn-vsn.pl
==============================================================================
--- dbi/trunk/git-svn-vsn.pl (original)
+++ dbi/trunk/git-svn-vsn.pl Fri Dec 21 09:11:32 2012
@@ -18,9 +18,9 @@
open my $gl, "-|", "git log -1 $f";
my ($svn_id, $svn_date, $svn_author) = ("", "");
while (<$gl>) {
- m/git-svn-id:.*?trunk\@([0-9]+)/ and $svn_id = $1;
- m/^Date:\s*(.*)/ and $svn_date = $1;
- m/^Author:\s*(\S+)/ and $svn_author = $1;
+ m/git-svn-id:.*?(?:trunk|sqlengine)\@([0-9]+)/ and $svn_id = $1;
+ m/^Date:\s*(.*)/ and $svn_date = $1;
+ m/^Author:\s*(\S+)/ and $svn_author = $1;
}
#print STDERR " + $svn_id, $svn_author, $svn_date\n";
$svn_id or return;
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Fri Dec 21 09:11:32 2012
@@ -3,7 +3,7 @@
# DBD::DBM - a DBI driver for DBM files
#
# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
-# Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand
+# Copyright (c) 2010-2013 by Jens Rehsack & H.Merijn Brand
#
# All rights reserved.
#
@@ -24,7 +24,7 @@
#################
use base qw( DBD::File );
use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed);
-$VERSION = '0.06';
+$VERSION = '0.08';
$ATTRIBUTION = 'DBD::DBM by Jens Rehsack';
# no need to have driver() unless you need private methods
@@ -76,6 +76,8 @@
$DBD::DBM::db::imp_data_size = 0;
@DBD::DBM::db::ISA = qw(DBD::File::db);
+use Carp qw/carp/;
+
sub validate_STORE_attr
{
my ( $dbh, $attrib, $value ) = @_;
@@ -83,7 +85,7 @@
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 );
+ carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if ($^W);
$attrib = $newattrib;
}
@@ -97,7 +99,7 @@
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 );
+ carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if ($^W);
$attrib = $newattrib;
}
@@ -229,10 +231,9 @@
{
my ( $sth, $tname ) = @_;
return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname;
- return $sth->set_err( $DBI::stderr, "Unknown table '$tname'!" )
- unless ( $sth->{Database}->{f_meta}
- and $sth->{Database}->{f_meta}->{$tname} );
- return $sth->{Database}->{f_meta}->{$tname}->{schema};
+ my $tbl_meta = $sth->{Database}->func( $tname, "f_schema", "get_sql_engine_meta" )
+ or return $sth->set_err( $sth->{Database}->err(), $sth->{Database}->errstr() );
+ return $tbl_meta->{$tname}->{f_schema};
}
# you could put some :st private methods here
@@ -256,17 +257,6 @@
my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir';
-sub file2table
-{
- my ( $self, $meta, $file, $file_is_table, $quoted ) = @_;
-
- my $tbl = $self->SUPER::file2table( $meta, $file, $file_is_table, $quoted ) or return;
-
- $meta->{f_dontopen} = 1;
-
- return $tbl;
-}
-
my %reset_on_modify = (
dbm_type => "dbm_tietype",
dbm_mldbm => "dbm_tietype",
@@ -274,12 +264,12 @@
__PACKAGE__->register_reset_on_modify( \%reset_on_modify );
my %compat_map = (
- ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ),
- dbm_ext => 'f_ext',
- dbm_file => 'f_file',
- dbm_lockfile => ' f_lockfile',
- );
-__PACKAGE__->register_compat_map (\%compat_map);
+ ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ),
+ dbm_ext => 'f_ext',
+ dbm_file => 'f_file',
+ dbm_lockfile => ' f_lockfile',
+ );
+__PACKAGE__->register_compat_map( \%compat_map );
sub bootstrap_table_meta
{
@@ -322,6 +312,8 @@
{
my ( $self, $dbh, $meta, $table ) = @_;
+ $meta->{f_dontopen} = 1;
+
unless ( defined( $meta->{dbm_tietype} ) )
{
my $tie_type = $meta->{dbm_type};
@@ -353,10 +345,11 @@
$self->SUPER::init_table_meta( $dbh, $meta, $table );
}
-sub open_file
+sub open_data
{
- my ( $self, $meta, $attrs, $flags ) = @_;
- $self->SUPER::open_file( $meta, $attrs, $flags );
+ my ( $className, $meta, $attrs, $flags ) = @_;
+ $className->SUPER::open_data( $meta, $attrs, $flags );
+
unless ( $flags->{dropMode} )
{
# TIEING
@@ -401,7 +394,7 @@
my $tie_class = $meta->{dbm_tietype};
eval { tie %{ $meta->{hash} }, $tie_class, @tie_args };
$@ and croak "Cannot tie(\%h $tie_class @tie_args): $@";
- -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" );
+ -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" );
}
unless ( $flags->{createMode} )
@@ -730,7 +723,7 @@
=head1 USAGE
-This section will explain some useage cases in more detail. To get an
+This section will explain some usage cases in more detail. To get an
overview about the available attributes, see L</Metadata>.
=head2 Specifying Files and Directories
@@ -1332,11 +1325,11 @@
=item C<YAML::MLDBM>
-Additional serializer for MLDBM. YAML is very portable between languanges.
+Additional serializer for MLDBM. YAML is very portable between languages.
=item C<MLDBM::Serializer::JSON>
-Additional serializer for MLDBM. JSON is very portable between languanges,
+Additional serializer for MLDBM. JSON is very portable between languages,
probably more than YAML.
=back
@@ -1445,7 +1438,7 @@
took over maintenance.
Copyright (c) 2004 by Jeff Zucker, all rights reserved.
- Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand, all rights reserved.
+ Copyright (c) 2010-2013 by Jens Rehsack & H.Merijn Brand, 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
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Fri Dec 21 09:11:32 2012
@@ -9,7 +9,7 @@
#
# The original author is Jochen Wiedmann.
#
-# Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack
+# Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack
# Copyright (C) 2004 by Jeff Zucker
# Copyright (C) 1998 by Jochen Wiedmann
#
@@ -31,20 +31,14 @@
use strict;
use warnings;
-use base qw(DBI::DBD::SqlEngine);
+use base qw( DBI::DBD::SqlEngine );
use Carp;
-use vars qw(@ISA $VERSION $drh);
+use vars qw( @ISA $VERSION $drh );
-$VERSION = "0.40";
+$VERSION = "0.41";
$drh = undef; # holds driver handle(s) once initialized
-my %accessors = (
- get_meta => "get_file_meta",
- set_meta => "set_file_meta",
- clear_meta => "clear_file_meta",
- );
-
sub driver ($;$)
{
my ($class, $attr) = @_;
@@ -72,24 +66,6 @@
$drh->{$class} = $class->SUPER::driver ($attr);
- 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
return $drh->{$class};
@@ -107,9 +83,9 @@
use strict;
use warnings;
-use vars qw(@ISA $imp_data_size);
+use vars qw( @ISA $imp_data_size );
-@DBD::File::dr::ISA = qw(DBI::DBD::SqlEngine::dr);
+@DBD::File::dr::ISA = qw( DBI::DBD::SqlEngine::dr );
$DBD::File::dr::imp_data_size = 0;
sub dsn_quote
@@ -121,33 +97,8 @@
return $str;
} # dsn_quote
-sub data_sources ($;$)
-{
- my ($drh, $attr) = @_;
- my $dir = $attr && exists $attr->{f_dir}
- ? $attr->{f_dir}
- : File::Spec->curdir ();
- my %attrs;
- $attr and %attrs = %$attr;
- delete $attrs{f_dir};
- my $dsnextra = join ";", map { $_ . "=" . dsn_quote ($attrs{$_}) } keys %attrs;
- my ($dirh) = Symbol::gensym ();
- unless (opendir $dirh, $dir) {
- $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
- return;
- }
-
- my ($file, @dsns, %names, $driver);
- $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";
-
- while (defined ($file = readdir ($dirh))) {
- my $d = File::Spec->catdir ($dir, $file);
- # allow current dir ... it can be a data_source too
- $file ne File::Spec->updir () && -d $d and
- push @dsns, "DBI:$driver:f_dir=" . dsn_quote ($d) . ($dsnextra ? ";$dsnextra" : "");
- }
- return @dsns;
- } # data_sources
+# XXX rewrite using TableConfig ...
+sub default_table_source { "DBD::File::TableSource::FileSystem" }
sub disconnect_all
{
@@ -165,16 +116,24 @@
use strict;
use warnings;
-use vars qw(@ISA $imp_data_size);
+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
+use Scalar::Util qw( refaddr ); # in CORE since 5.7.3
-@DBD::File::db::ISA = qw(DBI::DBD::SqlEngine::db);
+@DBD::File::db::ISA = qw( DBI::DBD::SqlEngine::db );
$DBD::File::db::imp_data_size = 0;
+sub data_sources
+{
+ my ($dbh, $attr, @other) = @_;
+ ref ($attr) eq "HASH" or $attr = {};
+ exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir};
+ return $dbh->SUPER::data_sources ($attr, @other);
+ } # data_source
+
sub set_versions
{
my $dbh = shift;
@@ -192,8 +151,6 @@
f_dir => 1, # base directory
f_ext => 1, # file extension
f_schema => 1, # schema name
- f_meta => 1, # meta data for tables
- f_meta_map => 1, # mapping table for identifier case
f_lock => 1, # Table locking mode
f_lockfile => 1, # Table lockfile extension
f_encoding => 1, # Encoding of the file
@@ -225,79 +182,41 @@
}
if (0 == $phase) {
- # check whether we're running in a Gofer server or not (see
- # validate_FETCH_attr for details)
- $dbh->{f_in_gofer} = (defined $INC{"DBD/Gofer.pm"} && (caller(5))[0] eq "DBI::Gofer::Execute");
# f_ext should not be initialized
# f_map is deprecated (but might return)
$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
- $dbh->{f_meta} = {};
- $dbh->{f_meta_map} = {}; # choose new name because it contains other keys
+
+ push @{$dbh->{sql_init_order}{90}}, "f_meta";
# 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 = ();
- if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{f_in_gofer}) {
- my $attr = $dbh->{$drv_prefix . "meta"};
- defined $attr and defined $dbh->{$valid_attrs} and
- !defined $dbh->{$valid_attrs}{$attr} and
- $dbh->{$valid_attrs}{$attr} = 1;
-
- my %h;
- tie %h, "DBD::File::TieTables", $dbh;
- $dbh->{$attr} = \%h;
-
- push @comp_attrs, "meta";
- }
+ if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) {
+ my $attr = $dbh->{$drv_prefix . "meta"};
+ defined $dbh->{f_valid_attrs}{f_meta}
+ and $dbh->{f_valid_attrs}{f_meta} = 1;
- 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;
+ $dbh->{f_meta} = $dbh->{$attr};
}
}
return $dbh;
} # init_default_attributes
-sub disconnect ($)
-{
- %{$_[0]->{f_meta}} = ();
- return $_[0]->SUPER::disconnect ();
- } # disconnect
-
sub validate_FETCH_attr
{
my ($dbh, $attrib) = @_;
- # If running in a Gofer server, access to our tied compatibility hash
- # would force Gofer to serialize the tieing object including it's
- # private $dbh reference used to do the driver function calls.
- # This will result in nasty exceptions. So return a copy of the
- # f_meta structure instead, which is the source of for the compatibility
- # tie-hash. It's not as good as liked, but the best we can do in this
- # situation.
- if ($dbh->{f_in_gofer}) {
- (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
- my $drv_prefix = DBI->driver_prefix ($drv_class);
- exists $dbh->{$drv_prefix . "meta"} && $attrib eq $dbh->{$drv_prefix . "meta"} and
- $attrib = "f_meta";
- }
+ $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";
- return $attrib;
+ return $dbh->SUPER::validate_FETCH_attr ($attrib);
} # validate_FETCH_attr
sub validate_STORE_attr
{
my ($dbh, $attrib, $value) = @_;
- if ($attrib eq "f_dir") {
+ if ($attrib eq "f_dir" && defined $value) {
-d $value or
return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
File::Spec->file_name_is_absolute ($value) or
@@ -309,17 +228,7 @@
carp "'$value' doesn't look like a valid file extension attribute\n";
}
- (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
- my $drv_prefix = DBI->driver_prefix ($drv_class);
-
- if (exists $dbh->{$drv_prefix . "meta"}) {
- my $attr = $dbh->{$drv_prefix . "meta"};
- if ($attrib eq $attr) {
- while (my ($k, $v) = each %$value) {
- $dbh->{$attrib}{$k} = $v;
- }
- }
- }
+ $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";
return $dbh->SUPER::validate_STORE_attr ($attrib, $value);
} # validate_STORE_attr
@@ -330,13 +239,6 @@
my $class = $dbh->{ImplementorClass};
$class =~ s/::db$/::Table/;
- my (undef, $meta);
- $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
- unless ($meta) {
- $meta = {};
- $class->bootstrap_table_meta ($dbh, $meta, $table);
- }
-
my $dver;
my $dtype = "IO::File";
eval {
@@ -346,303 +248,19 @@
$dtype .= " ($dver)";
};
- $meta->{f_encoding} and $dtype .= " + " . $meta->{f_encoding} . " encoding";
+ my $f_encoding;
+ if ($table) {
+ my $meta;
+ $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
+ $meta and $meta->{f_encoding} and $f_encoding = $meta->{f_encoding};
+ } # if ($table)
+ $f_encoding ||= $dbh->{f_encoding};
+
+ $f_encoding and $dtype .= " + " . $f_encoding . " encoding";
return sprintf "%s using %s", $dbh->{f_version}, $dtype;
} # get_f_versions
-sub get_single_table_meta
-{
- my ($dbh, $table, $attr) = @_;
- my $meta;
-
- $table eq "." and
- return $dbh->FETCH ($attr);
-
- (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
- (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
- $meta or croak "No such table '$table'";
-
- # prevent creation of undef attributes
- return $class->get_table_meta_attr ($meta, $attr);
- } # get_single_table_meta
-
-sub get_file_meta
-{
- my ($dbh, $table, $attr) = @_;
-
- my $gstm = $dbh->{ImplementorClass}->can ("get_single_table_meta");
-
- $table eq "*" and
- $table = [ ".", keys %{$dbh->{f_meta}} ];
- $table eq "+" and
- $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ];
- ref $table eq "Regexp" and
- $table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ];
-
- ref $table || ref $attr or
- return &$gstm ($dbh, $table, $attr);
-
- ref $table or $table = [ $table ];
- ref $attr or $attr = [ $attr ];
- "ARRAY" eq ref $table or
- croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table;
- "ARRAY" eq ref $attr or
- croak "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr;
-
- my %results;
- foreach my $tname (@{$table}) {
- my %tattrs;
- foreach my $aname (@{$attr}) {
- $tattrs{$aname} = &$gstm ($dbh, $tname, $aname);
- }
- $results{$tname} = \%tattrs;
- }
-
- return \%results;
- } # get_file_meta
-
-sub set_single_table_meta
-{
- my ($dbh, $table, $attr, $value) = @_;
- my $meta;
-
- $table eq "." and
- return $dbh->STORE ($attr, $value);
-
- (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
- (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
- $meta or croak "No such table '$table'";
- $class->set_table_meta_attr ($meta, $attr, $value);
-
- return $dbh;
- } # set_single_table_meta
-
-sub set_file_meta
-{
- my ($dbh, $table, $attr, $value) = @_;
-
- my $sstm = $dbh->{ImplementorClass}->can ("set_single_table_meta");
-
- $table eq "*" and
- $table = [ ".", keys %{$dbh->{f_meta}} ];
- $table eq "+" and
- $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ];
- ref ($table) eq "Regexp" and
- $table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ];
-
- ref $table || ref $attr or
- return &$sstm ($dbh, $table, $attr, $value);
-
- ref $table or $table = [ $table ];
- ref $attr or $attr = { $attr => $value };
- "ARRAY" eq ref $table or
- croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table;
- "HASH" eq ref $attr or
- croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr;
-
- foreach my $tname (@{$table}) {
- my %tattrs;
- while (my ($aname, $aval) = each %$attr) {
- &$sstm ($dbh, $tname, $aname, $aval);
- }
- }
-
- return $dbh;
- } # set_file_meta
-
-sub clear_file_meta
-{
- my ($dbh, $table) = @_;
-
- (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
- my (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
- $meta and %{$meta} = ();
-
- return;
- } # clear_file_meta
-
-sub get_avail_tables
-{
- my $dbh = shift;
-
- my @tables = $dbh->SUPER::get_avail_tables ();
- my $dir = $dbh->{f_dir};
- my $dirh = Symbol::gensym ();
-
- unless (opendir $dirh, $dir) {
- $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
- return @tables;
- }
-
- 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" ];
- }
- closedir $dirh or
- $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
-
- return @tables;
- } # get_avail_tables
-
-# ====== Tie-Meta ==============================================================
-
-package DBD::File::TieMeta;
-
-use Carp qw(croak);
-require Tie::Hash;
-@DBD::File::TieMeta::ISA = qw(Tie::Hash);
-
-sub TIEHASH
-{
- my ($class, $tblClass, $tblMeta) = @_;
-
- my $self = bless ({ tblClass => $tblClass, tblMeta => $tblMeta, }, $class);
- return $self;
- } # new
-
-sub STORE
-{
- my ($self, $meta_attr, $meta_val) = @_;
-
- $self->{tblClass}->set_table_meta_attr ($self->{tblMeta}, $meta_attr, $meta_val);
-
- return;
- } # STORE
-
-sub FETCH
-{
- my ($self, $meta_attr) = @_;
-
- return $self->{tblClass}->get_table_meta_attr ($self->{tblMeta}, $meta_attr);
- } # FETCH
-
-sub FIRSTKEY
-{
- my $a = scalar keys %{$_[0]->{tblMeta}};
- each %{$_[0]->{tblMeta}};
- } # FIRSTKEY
-
-sub NEXTKEY
-{
- each %{$_[0]->{tblMeta}};
- } # NEXTKEY
-
-sub EXISTS
-{
- exists $_[0]->{tblMeta}{$_[1]};
- } # EXISTS
-
-sub DELETE
-{
- croak "Can't delete single attributes from table meta structure";
- } # DELETE
-
-sub CLEAR
-{
- %{$_[0]->{tblMeta}} = ()
- } # CLEAR
-
-sub SCALAR
-{
- scalar %{$_[0]->{tblMeta}}
- } # SCALAR
-
-# ====== Tie-Tables ============================================================
-
-package DBD::File::TieTables;
-
-use Carp qw(croak);
-require Tie::Hash;
-@DBD::File::TieTables::ISA = qw(Tie::Hash);
-
-sub TIEHASH
-{
- my ($class, $dbh) = @_;
-
- (my $tbl_class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
- my $self = bless ({ dbh => $dbh, tblClass => $tbl_class, }, $class);
- return $self;
- } # new
-
-sub STORE
-{
- my ($self, $table, $tbl_meta) = @_;
-
- "HASH" eq ref $tbl_meta or
- croak "Invalid data for storing as table meta data (must be hash)";
-
- (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1);
- $meta or croak "Invalid table name '$table'";
-
- while (my ($meta_attr, $meta_val) = each %$tbl_meta) {
- $self->{tblClass}->set_table_meta_attr ($meta, $meta_attr, $meta_val);
- }
-
- return;
- } # STORE
-
-sub FETCH
-{
- my ($self, $table) = @_;
-
- (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1);
- $meta or croak "Invalid table name '$table'";
-
- my %h;
- tie %h, "DBD::File::TieMeta", $self->{tblClass}, $meta;
-
- return \%h;
- } # FETCH
-
-sub FIRSTKEY
-{
- my $a = scalar keys %{$_[0]->{dbh}->{f_meta}};
- each %{$_[0]->{dbh}->{f_meta}};
- } # FIRSTKEY
-
-sub NEXTKEY
-{
- each %{$_[0]->{dbh}->{f_meta}};
- } # NEXTKEY
-
-sub EXISTS
-{
- exists $_[0]->{dbh}->{f_meta}->{$_[1]} or
- exists $_[0]->{dbh}->{f_meta_map}->{$_[1]};
- } # EXISTS
-
-sub DELETE
-{
- my ($self, $table) = @_;
-
- (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1);
- $meta or croak "Invalid table name '$table'";
-
- delete $_[0]->{dbh}->{f_meta}->{$meta->{table_name}};
- } # DELETE
-
-sub CLEAR
-{
- %{$_[0]->{dbh}->{f_meta}} = ();
- %{$_[0]->{dbh}->{f_meta_map}} = ();
- } # CLEAR
-
-sub SCALAR
-{
- scalar %{$_[0]->{dbh}->{f_meta}}
- } # SCALAR
-
# ====== STATEMENT =============================================================
package DBD::File::st;
@@ -650,9 +268,9 @@
use strict;
use warnings;
-use vars qw(@ISA $imp_data_size);
+use vars qw( @ISA $imp_data_size );
-@DBD::File::st::ISA = qw(DBI::DBD::SqlEngine::st);
+@DBD::File::st::ISA = qw( DBI::DBD::SqlEngine::st );
$DBD::File::st::imp_data_size = 0;
my %supported_attrs = (
@@ -675,7 +293,7 @@
# fill overall_defs unless we know
unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) {
my $all_meta =
- $sth->{Database}->func ("*", "table_defs", "get_file_meta");
+ $sth->{Database}->func ("*", "table_defs", "get_sql_engine_meta");
while (my ($tbl, $meta) = each %$all_meta) {
exists $meta->{table_defs} && ref $meta->{table_defs} or next;
foreach (keys %{$meta->{table_defs}{columns}}) {
@@ -695,7 +313,7 @@
@colnames ];
$attr eq "NULLABLE" and
- return [ map { ( grep m/^NOT NULL$/ =>
+ return [ map { ( grep { $_ eq "NOT NULL" }
@{ $sth->{f_overall_defs}{$_}{constraints} || [] })
? 0 : 1 }
@colnames ];
@@ -705,67 +323,195 @@
return $sth->SUPER::FETCH ($attr);
} # FETCH
-# ====== SQL::STATEMENT ========================================================
+# ====== TableSource ===========================================================
-package DBD::File::Statement;
+package DBD::File::TableSource::FileSystem;
use strict;
use warnings;
-@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement );
+use IO::Dir;
+
+@DBD::File::TableSource::FileSystem::ISA = "DBI::DBD::SqlEngine::TableSource";
+
+sub data_sources
+{
+ my ($class, $drh, $attr) = @_;
+ my $dir = $attr && exists $attr->{f_dir}
+ ? $attr->{f_dir}
+ : File::Spec->curdir ();
+ defined $dir or return; # Stream-based databases do not have f_dir
+ my %attrs;
+ $attr and %attrs = %$attr;
+ delete $attrs{f_dir};
+ my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote");
+ my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs;
+ my $dirh = IO::Dir->new ($dir);
+ unless (defined $dirh) {
+ $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
+ return;
+ }
-sub open_table ($$$$$)
+ my ($file, @dsns, %names, $driver);
+ $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";
+
+ while (defined ($file = $dirh->read ())) {
+ my $d = File::Spec->catdir ($dir, $file);
+ # allow current dir ... it can be a data_source too
+ $file ne File::Spec->updir () && -d $d and
+ push @dsns, "DBI:$driver:f_dir=" . &{$dsn_quote} ($d) . ($dsnextra ? ";$dsnextra" : "");
+ }
+ return @dsns;
+ } # data_sources
+
+sub avail_tables
{
- my ($self, $data, $table, $createMode, $lockMode) = @_;
+ my ($self, $dbh) = @_;
- my $class = ref $self;
- $class =~ s/::Statement/::Table/;
+ my $dir = $dbh->{f_dir};
+ defined $dir or return; # Stream based db's cannot be queried for tables
+ my $dirh = IO::Dir->new ($dir);
- my $flags = {
- createMode => $createMode,
- lockMode => $lockMode,
- };
- $self->{command} eq "DROP" and $flags->{dropMode} = 1;
+ unless (defined $dirh) {
+ $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
+ return;
+ }
- return $class->new ($data, { table => $table }, $flags);
- } # open_table
+ 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;
+ my @tables;
+ while (defined ($file = $dirh->read ())) {
+ 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" ];
+ }
+ $dirh->close () or
+ $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
-# ====== SQL::TABLE ============================================================
+ return @tables;
+ } # avail_tables
-package DBD::File::Table;
+# ====== DataSource ============================================================
+
+package DBD::File::DataSource::Stream;
use strict;
use warnings;
use Carp;
-require IO::File;
-require File::Basename;
-require File::Spec;
-require Cwd;
+
+@DBD::File::DataSource::Stream::ISA = "DBI::DBD::SqlEngine::DataSource";
# We may have a working flock () built-in but that doesn't mean that locking
# will work on NFS (flock () may hang hard)
-my $locking = eval { flock STDOUT, 0; 1 };
+my $locking = eval {
+ my $fh;
+ my $nulldevice = File::Spec->devnull ();
+ open $fh, ">", $nulldevice or croak "Can't open $nulldevice: $!";
+ flock $fh, 0;
+ close $fh;
+ 1;
+ };
-@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table );
+sub complete_table_name
+{
+ my ($self, $meta, $file, $respect_case) = @_;
-# ====== FLYWEIGHT SUPPORT =====================================================
+ my $tbl = $file;
+ if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER
+ $tbl = uc $tbl;
+ }
+ elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
+ $tbl = lc $tbl;
+ }
+
+ $meta->{f_fqfn} = undef;
+ $meta->{f_fqbn} = undef;
+ $meta->{f_fqln} = undef;
+
+ $meta->{table_name} = $tbl;
+
+ return $tbl;
+ } # complete_table_name
+
+sub apply_encoding
+{
+ my ($self, $meta, $fn) = @_;
+ defined $fn or $fn = "file handle " . fileno ($meta->{fh});
+ if (my $enc = $meta->{f_encoding}) {
+ binmode $meta->{fh}, ":encoding($enc)" or
+ croak "Failed to set encoding layer '$enc' on $fn: $!";
+ }
+ else {
+ binmode $meta->{fh} or croak "Failed to set binary mode on $fn: $!";
+ }
+ } # apply_encoding
+
+sub open_data
+{
+ my ($self, $meta, $attrs, $flags) = @_;
+
+ $flags->{dropMode} and croak "Can't drop a table in stream";
+ my $fn = "file handle " . fileno ($meta->{f_file});
+
+ if ($flags->{createMode} || $flags->{lockMode}) {
+ $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "w+") or
+ croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
+ }
+ else {
+ $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "r") or
+ croak "Cannot open $fn for reading: $! (" . ($!+0) . ")";
+ }
+
+ if ($meta->{fh}) {
+ $self->apply_encoding ($meta, $fn);
+ } # have $meta->{$fh}
+
+ if ($self->can_flock && $meta->{fh}) {
+ my $lm = defined $flags->{f_lock}
+ && $flags->{f_lock} =~ m/^[012]$/
+ ? $flags->{f_lock}
+ : $flags->{lockMode} ? 2 : 1;
+ if ($lm == 2) {
+ flock $meta->{fh}, 2 or croak "Cannot obtain exclusive lock on $fn: $!";
+ }
+ elsif ($lm == 1) {
+ flock $meta->{fh}, 1 or croak "Cannot obtain shared lock on $fn: $!";
+ }
+ # $lm = 0 is forced no locking at all
+ }
+ } # open_data
+
+sub can_flock { $locking }
+
+package DBD::File::DataSource::File;
+
+use strict;
+use warnings;
+
+@DBD::File::DataSource::File::ISA = "DBD::File::DataSource::Stream";
+
+use Carp;
my $fn_any_ext_regex = qr/\.[^.]*/;
-# Flyweight support for table_info
-# The functions file2table, init_table_meta, default_table_meta and
-# get_table_meta are using $self arguments for polymorphism only. The
-# must not rely on an instantiated DBD::File::Table
-sub file2table
+sub complete_table_name
{
- my ($self, $meta, $file, $file_is_table, $respect_case) = @_;
+ my ($self, $meta, $file, $respect_case, $file_is_table) = @_;
$file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir
+ # XXX now called without proving f_fqfn first ...
my ($ext, $req) = ("", 0);
if ($meta->{f_ext}) {
- ($ext, my $opt) = split m/\//, $meta->{f_ext};
+ ($ext, my $opt) = split m{/}, $meta->{f_ext};
if ($ext && $opt) {
$opt =~ m/r/i and $req = 1;
}
@@ -789,13 +535,13 @@
$basename = uc $basename;
$tbl = uc $tbl;
}
- if( !$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
+ elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
$basename = lc $basename;
$tbl = lc $tbl;
}
my $searchdir = File::Spec->file_name_is_absolute ($dir)
- ? ($dir =~ s|/$||, $dir)
+ ? ($dir =~ s{/$}{}, $dir)
: Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
-d $searchdir or
croak "-d $searchdir: $!";
@@ -811,7 +557,8 @@
if ($respect_case) {
$cmpsub = sub {
my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
- $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension turns up as a dot
+ $^O eq "VMS" && $sfx eq "." and
+ $sfx = ""; # no extension turns up as a dot
$fn eq $basename and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
@@ -820,19 +567,24 @@
else {
$cmpsub = sub {
my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
- $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension turns up as a dot
+ $^O eq "VMS" && $sfx eq "." and
+ $sfx = ""; # no extension turns up as a dot
lc $fn eq lc $basename and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
}
}
- opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!";
- my @f = sort { length $b <=> length $a } grep { &$cmpsub ($_) } readdir $dh;
+ my @f;
+ { my $dh = IO::Dir->new ($searchdir) or croak "Can't open '$searchdir': $!";
+ @f = sort { length $b <=> length $a }
+ grep { &$cmpsub ($_) }
+ $dh->read ();
+ $dh->close () or croak "Can't close '$searchdir': $!";
+ }
@f > 0 && @f <= 2 and $file = $f[0];
!$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
($tbl = $file) =~ s/$ext$//i;
- closedir $dh or croak "Can't close '$searchdir': $!";
my $tmpfn = $file;
if ($ext && $req) {
@@ -853,127 +605,9 @@
$meta->{table_name} = $tbl;
return $tbl;
- } # file2table
-
-sub bootstrap_table_meta
-{
- my ($self, $dbh, $meta, $table) = @_;
-
- exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir};
- defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext};
- defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding};
- exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock};
- exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile};
- defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema};
- defined $meta->{sql_identifier_case} or
- $meta->{sql_identifier_case} = $dbh->{sql_identifier_case};
- } # bootstrap_table_meta
-
-sub init_table_meta
-{
- my ($self, $dbh, $meta, $table) = @_;
-
- return;
- } # init_table_meta
-
-sub get_table_meta ($$$$;$)
-{
- my ($self, $dbh, $table, $file_is_table, $respect_case) = @_;
- unless (defined $respect_case) {
- $respect_case = 0;
- $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers
- $table =~ s/\"$//;
- }
-
- unless ($respect_case) {
- defined $dbh->{f_meta_map}{$table} and $table = $dbh->{f_meta_map}{$table};
- }
-
- my $meta = {};
- defined $dbh->{f_meta}{$table} and $meta = $dbh->{f_meta}{$table};
-
- unless ($meta->{initialized}) {
- $self->bootstrap_table_meta ($dbh, $meta, $table);
-
- unless (defined $meta->{f_fqfn}) {
- $self->file2table ($meta, $table, $file_is_table, $respect_case) or return;
- }
+ } # complete_table_name
- if (defined $meta->{table_name} and $table ne $meta->{table_name}) {
- $dbh->{f_meta_map}{$table} = $meta->{table_name};
- $table = $meta->{table_name};
- }
-
- # now we know a bit more - let's check if user can't use consequent spelling
- # XXX add know issue about reset sql_identifier_case here ...
- if (defined $dbh->{f_meta}{$table} && defined $dbh->{f_meta}{$table}{initialized}) {
- $meta = $dbh->{f_meta}{$table};
- $self->file2table ($meta, $table, $file_is_table, $respect_case) or
- return unless $dbh->{f_meta}{$table}{initialized};
- }
- unless ($dbh->{f_meta}{$table}{initialized}) {
- $self->init_table_meta ($dbh, $meta, $table);
- $meta->{initialized} = 1;
- $dbh->{f_meta}{$table} = $meta;
- }
- }
-
- return ($table, $meta);
- } # get_table_meta
-
-my %reset_on_modify = (
- f_file => "f_fqfn",
- f_dir => "f_fqfn",
- f_ext => "f_fqfn",
- f_lockfile => "f_fqfn", # forces new file2table call
- );
-
-my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile );
-
-sub register_reset_on_modify
-{
- my ($proto, $extra_resets) = @_;
- %reset_on_modify = (%reset_on_modify, %$extra_resets);
- return;
- } # register_reset_on_modify
-
-sub register_compat_map
-{
- my ($proto, $extra_compat_map) = @_;
- %compat_map = (%compat_map, %$extra_compat_map);
- return;
- } # register_compat_map
-
-sub get_table_meta_attr
-{
- my ($class, $meta, $attrib) = @_;
- exists $compat_map{$attrib} and
- $attrib = $compat_map{$attrib};
- exists $meta->{$attrib} and
- return $meta->{$attrib};
- return;
- } # get_table_meta_attr
-
-sub set_table_meta_attr
-{
- my ($class, $meta, $attrib, $value) = @_;
- exists $compat_map{$attrib} and
- $attrib = $compat_map{$attrib};
- $class->table_meta_attr_changed ($meta, $attrib, $value);
- $meta->{$attrib} = $value;
- } # set_table_meta_attr
-
-sub table_meta_attr_changed
-{
- my ($class, $meta, $attrib, $value) = @_;
- defined $reset_on_modify{$attrib} and
- delete $meta->{$reset_on_modify{$attrib}} and
- $meta->{initialized} = 0;
- } # table_meta_attr_changed
-
-# ====== FILE OPEN =============================================================
-
-sub open_file ($$$)
+sub open_data
{
my ($self, $meta, $attrs, $flags) = @_;
@@ -994,25 +628,20 @@
}
}
+ $meta->{fh} = $fh;
+
if ($fh) {
$fh->seek (0, 0) or
croak "Error while seeking back: $!";
- if (my $enc = $meta->{f_encoding}) {
- binmode $fh, ":encoding($enc)" or
- croak "Failed to set encoding layer '$enc' on $fn: $!";
- }
- else {
- binmode $fh or croak "Failed to set binary mode on $fn: $!";
- }
- }
- $meta->{fh} = $fh;
+ $self->apply_encoding ($meta);
+ }
}
if ($meta->{f_fqln}) {
$fn = $meta->{f_fqln};
if ($flags->{createMode}) {
-f $fn and
- croak "Cannot create table lock for $attrs->{table}: Already exists";
+ croak "Cannot create table lock at '$fn' for $attrs->{table}: Already exists";
$fh = IO::File->new ($fn, "a+") or
croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
}
@@ -1025,7 +654,7 @@
$meta->{lockfh} = $fh;
}
- if ($locking && $fh) {
+ if ($self->can_flock && $fh) {
my $lm = defined $flags->{f_lock}
&& $flags->{f_lock} =~ m/^[012]$/
? $flags->{f_lock}
@@ -1038,35 +667,155 @@
}
# $lm = 0 is forced no locking at all
}
- } # open_file
+ } # open_data
-# ====== SQL::Eval API =========================================================
+# ====== SQL::STATEMENT ========================================================
-sub new
-{
- my ($className, $data, $attrs, $flags) = @_;
- my $dbh = $data->{Database};
+package DBD::File::Statement;
+
+use strict;
+use warnings;
+
+@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement );
+
+# ====== SQL::TABLE ============================================================
+
+package DBD::File::Table;
- my ($tblnm, $meta) = $className->get_table_meta ($dbh, $attrs->{table}, 1) or
- croak "Cannot find appropriate file for table '$attrs->{table}'";
- $attrs->{table} = $tblnm;
-
- # Being a bit dirty here, as SQL::Statement::Structure does not offer
- # me an interface to the data I want
- $flags->{createMode} && $data->{sql_stmt}{table_defs} and
- $meta->{table_defs} = $data->{sql_stmt}{table_defs};
-
- $className->open_file ($meta, $attrs, $flags);
-
- my $columns = {};
- my $array = [];
- my $tbl = {
- %{$attrs},
- meta => $meta,
- col_names => $meta->{col_names} || [],
+use strict;
+use warnings;
+
+use Carp;
+require IO::File;
+require File::Basename;
+require File::Spec;
+require Cwd;
+require Scalar::Util;
+
+@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table );
+
+# ====== UTILITIES ============================================================
+
+if (eval { require Params::Util; }) {
+ Params::Util->import ("_HANDLE");
+ }
+else {
+ # taken but modified from Params::Util ...
+ *_HANDLE = sub {
+ # It has to be defined, of course
+ defined $_[0] or return;
+
+ # Normal globs are considered to be file handles
+ ref $_[0] eq "GLOB" and return $_[0];
+
+ # Check for a normal tied filehandle
+ # Side Note: 5.5.4's tied () and can () doesn't like getting undef
+ tied ($_[0]) and tied ($_[0])->can ("TIEHANDLE") and return $_[0];
+
+ # There are no other non-object handles that we support
+ Scalar::Util::blessed ($_[0]) or return;
+
+ # Check for a common base classes for conventional IO::Handle object
+ $_[0]->isa ("IO::Handle") and return $_[0];
+
+ # Check for tied file handles using Tie::Handle
+ $_[0]->isa ("Tie::Handle") and return $_[0];
+
+ # IO::Scalar is not a proper seekable, but it is valid is a
+ # regular file handle
+ $_[0]->isa ("IO::Scalar") and return $_[0];
+
+ # Yet another special case for IO::String, which refuses (for now
+ # anyway) to become a subclass of IO::Handle.
+ $_[0]->isa ("IO::String") and return $_[0];
+
+ # This is not any sort of object we know about
+ return;
};
- return $className->SUPER::new ($tbl);
- } # new
+ }
+
+# ====== FLYWEIGHT SUPPORT =====================================================
+
+# Flyweight support for table_info
+# The functions file2table, init_table_meta, default_table_meta and
+# get_table_meta are using $self arguments for polymorphism only. The
+# must not rely on an instantiated DBD::File::Table
+sub file2table
+{
+ my ($self, $meta, $file, $file_is_table, $respect_case) = @_;
+
+ return $meta->{sql_data_source}->complete_table_name ($meta, $file, $respect_case, $file_is_table);
+ } # file2table
+
+sub bootstrap_table_meta
+{
+ my ($self, $dbh, $meta, $table, @other) = @_;
+
+ $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table, @other);
+
+ exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir};
+ defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext};
+ defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding};
+ exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock};
+ exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile};
+ defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema};
+
+ defined $meta->{f_open_file_needed} or
+ $meta->{f_open_file_needed} = $self->can ("open_file") != DBD::File::Table->can ("open_file");
+
+ defined ($meta->{sql_data_source}) or
+ $meta->{sql_data_source} = _HANDLE ($meta->{f_file})
+ ? "DBD::File::DataSource::Stream"
+ : "DBD::File::DataSource::File";
+ } # bootstrap_table_meta
+
+sub get_table_meta ($$$$;$)
+{
+ my ($self, $dbh, $table, $file_is_table, $respect_case) = @_;
+
+ my $meta = $self->SUPER::get_table_meta ($dbh, $table, $respect_case, $file_is_table);
+ $table = $meta->{table_name};
+ return unless $table;
+
+ return ($table, $meta);
+ } # get_table_meta
+
+my %reset_on_modify = (
+ f_file => [ "f_fqfn", "sql_data_source" ],
+ f_dir => "f_fqfn",
+ f_ext => "f_fqfn",
+ f_lockfile => "f_fqfn", # forces new file2table call
+ );
+
+__PACKAGE__->register_reset_on_modify (\%reset_on_modify);
+
+my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile );
+
+__PACKAGE__->register_compat_map (\%compat_map);
+
+# ====== DBD::File <= 0.40 compat stuff ========================================
+
+# compat to 0.38 .. 0.40 API
+sub open_file
+{
+ my ($className, $meta, $attrs, $flags) = @_;
+
+ return $className->SUPER::open_data ($meta, $attrs, $flags);
+ } # open_file
+
+sub open_data
+{
+ my ($className, $meta, $attrs, $flags) = @_;
+
+ # compat to 0.38 .. 0.40 API
+ $meta->{f_open_file_needed}
+ ? $className->open_file ($meta, $attrs, $flags)
+ : $className->SUPER::open_data ($meta, $attrs, $flags);
+
+ return;
+ } # open_data
+
+# ====== SQL::Eval API =========================================================
sub drop ($)
{
@@ -1078,9 +827,9 @@
$meta->{lockfh} and $meta->{lockfh}->close ();
undef $meta->{fh};
undef $meta->{lockfh};
- $meta->{f_fqfn} and unlink $meta->{f_fqfn};
- $meta->{f_fqln} and unlink $meta->{f_fqln};
- delete $data->{Database}{f_meta}{$self->{table}};
+ $meta->{f_fqfn} and unlink $meta->{f_fqfn}; # XXX ==> sql_data_source
+ $meta->{f_fqln} and unlink $meta->{f_fqln}; # XXX ==> sql_data_source
+ delete $data->{Database}{sql_meta}{$self->{table}};
return 1;
} # drop
@@ -1189,19 +938,15 @@
affected table has been created in this session. 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
+=head3 Unsupported DBI attributes and methods
-=item CursorName
+=head4 bind_param_inout
-=item LongReadLen
+=head4 CursorName
-=item LongTruncOk
+=head4 LongReadLen
-=back
+=head4 LongTruncOk
=head3 DBD::File specific attributes
@@ -1316,13 +1061,13 @@
$dbh = DBI->connect ("dbi:DBM:f_lockfile=.foo");
$dbh->{f_lockfile} = ".foo";
- $dbh->{f_meta}{qux}{f_lockfile} = ".foo";
+ $dbh->{dbm_tables}{qux}{f_lockfile} = ".foo";
If you wish to disable locking, set the C<f_lockfile> to C<0>.
$dbh = DBI->connect ("dbi:DBM:f_lockfile=0");
$dbh->{f_lockfile} = 0;
- $dbh->{f_meta}{qux}{f_lockfile} = 0;
+ $dbh->{dbm_tables}{qux}{f_lockfile} = 0;
=head4 f_encoding
@@ -1331,17 +1076,17 @@
=head4 f_meta
-Private data area which contains information about the tables this
-module handles. Table meta data might not be available until the
-table has been accessed for the first time e.g., by issuing a select
-on it however it is possible to pre-initialize attributes for each table
-you use.
+Private data area aliasing L<DBI::DBD::SqlEngine/sql_meta> which
+contains information about the tables this module handles. Table meta
+data might not be available until the table has been accessed for the
+first time e.g., by issuing a select on it however it is possible to
+pre-initialize attributes for each table you use.
DBD::File recognizes the (public) attributes C<f_ext>, C<f_dir>,
C<f_file>, C<f_encoding>, C<f_lock>, C<f_lockfile>, C<f_schema>,
-C<col_names>, C<table_name> and C<sql_identifier_case>. Be very careful
-when modifying attributes you do not know, the consequence might be a
-destroyed or corrupted table.
+in addition to the attributes L<DBI::DBD::SqlEngine/sql_meta> already
+supports. Be very careful when modifying attributes you do not know,
+the consequence might be a destroyed or corrupted table.
C<f_file> is an attribute applicable to table meta data only and you
will not find a corresponding attribute in the dbh. Whilst it may be
@@ -1365,7 +1110,37 @@
C<csv_tables> for L<DBD::CSV>, C<ad_tables> for L<DBD::AnyData> and
C<dbm_tables> for L<DBD::DBM>.
-=head3 Internally private attributes to deal with SQL backends:
+=head3 New opportunities for attributes from DBI::DBD::SqlEngine
+
+=head4 sql_table_source
+
+C<< $dbh->{sql_table_source} >> can be set to
+I<DBD::File::TableSource::FileSystem> (and is the default setting
+of DBD::File). This provides usual behaviour of previous DBD::File
+releases on
+
+ @ary = DBI->data_sources ($driver);
+ @ary = DBI->data_sources ($driver, \%attr);
+
+ @ary = $dbh->data_sources ();
+ @ary = $dbh->data_sources (\%attr);
+
+ @names = $dbh->tables ($catalog, $schema, $table, $type);
+
+ $sth = $dbh->table_info ($catalog, $schema, $table, $type);
+ $sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr);
+
+ $dbh->func ("list_tables");
+
+=head4 sql_data_source
+
+C<< $dbh->{sql_data_source} >> can be set to either
+I<DBD::File::DataSource::File>, which is default and provides the
+well known behavior of DBD::File releases prior to 0.41, or
+I<DBD::File::DataSource::Stream>, which reuses already opened
+file-handle for operations.
+
+=head3 Internally private attributes to deal with SQL backends
Do not modify any of these private attributes unless you understand
the implications of doing so. The behavior of DBD::File and derived
@@ -1408,17 +1183,6 @@
my ($drh) = DBI->install_driver ("CSV");
my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data");
-=head4 list_tables
-
-This method returns a list of file names inside $dbh->{f_dir}.
-Example:
-
- my ($dbh) = DBI->connect ("dbi:CSV:f_dir=/usr/local/csv_data");
- my (@list) = $dbh->func ("list_tables");
-
-Note that the list includes all files contained in the directory, even
-those that have non-valid table names, from the view of SQL.
-
=head3 Additional methods
The following methods are only available via their documented name when
@@ -1430,11 +1194,11 @@
Signature:
- sub f_versions (;$)
- {
- my ($table_name) = @_;
- $table_name ||= ".";
- ...
+ sub f_versions (;$)
+ {
+ my ($table_name) = @_;
+ $table_name ||= ".";
+ ...
}
Returns the versions of the driver, including the DBI version, the Perl
@@ -1442,13 +1206,14 @@
of the SQL engine in use.
my $dbh = DBI->connect ("dbi:File:");
- my $f_versions = $dbh->f_versions ();
+ my $f_versions = $dbh->func ("f_versions");
print "$f_versions\n";
__END__
- # DBD::File 0.39 using SQL::Statement 1.28
- # DBI 1.612
- # OS netbsd (5.99.24)
- # Perl 5.010001 (x86_64-netbsd-thread-multi)
+ # DBD::File 0.41 using IO::File (1.16)
+ # DBI::DBD::SqlEngine 0.05 using SQL::Statement 1.406
+ # DBI 1.623
+ # OS darwin (12.2.1)
+ # Perl 5.017006 (darwin-thread-multi-ld-2level)
Called in list context, f_versions will return an array containing each
line as single entry.
@@ -1457,65 +1222,6 @@
version information related to the table (e.g. DBD::DBM provides storage
backend information for the requested table, when it has a table name).
-=head4 f_get_meta
-
-Signature:
-
- sub f_get_meta ($$)
- {
- my ($table_name, $attrib) = @_;
- ...
- }
-
-Returns the value of a meta attribute set for a specific table, if any.
-See L<f_meta> for the possible attributes.
-
-A table name of C<"."> (single dot) is interpreted as the default table.
-This will retrieve the appropriate attribute globally from the dbh.
-This has the same restrictions as C<< $dbh->{$attrib} >>.
-
-=head4 f_set_meta
-
-Signature:
-
- sub f_set_meta ($$$)
- {
- my ($table_name, $attrib, $value) = @_;
- ...
- }
-
-Sets the value of a meta attribute set for a specific table.
-See L<f_meta> for the possible attributes.
-
-A table name of C<"."> (single dot) is interpreted as the default table
-which will set the specified attribute globally for the dbh.
-This has the same restrictions as C<< $dbh->{$attrib} = $value >>.
-
-=head4 f_clear_meta
-
-Signature:
-
- sub f_clear_meta ($)
- {
- my ($table_name) = @_;
- ...
- }
-
-Clears the table specific meta information in the private storage of the
-dbh.
-
-=head1 SQL ENGINES
-
-DBD::File currently supports two SQL engines: L<SQL::Statement|SQL::Statement>
-and L<DBI::SQL::Nano::Statement_|DBI::SQL::Nano>. DBI::SQL::Nano supports a
-I<very> limited subset of SQL statements, but it might be faster for some
-very simple tasks. SQL::Statement in contrast supports a much larger subset
-of ANSI SQL.
-
-To use SQL::Statement, you need at least version 1.28 of
-SQL::Statement and the environment variable C<DBI_SQL_NANO> must not
-be set to a true value.
-
=head1 KNOWN BUGS AND LIMITATIONS
=over 4
@@ -1612,13 +1318,13 @@
This module is currently maintained by
H.Merijn Brand < h.m.brand at xs4all.nl > and
-Jens Rehsack < rehsack at googlemail.com >
+Jens Rehsack < rehsack at googlemail.com >
The original author is Jochen Wiedmann.
=head1 COPYRIGHT AND LICENSE
- Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack
+ Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack
Copyright (C) 2004-2009 by Jeff Zucker
Copyright (C) 1998-2004 by Jochen Wiedmann
Modified: dbi/trunk/lib/DBD/File/Developers.pod
==============================================================================
--- dbi/trunk/lib/DBD/File/Developers.pod (original)
+++ dbi/trunk/lib/DBD/File/Developers.pod Fri Dec 21 09:11:32 2012
@@ -6,12 +6,12 @@
package DBD::myDriver;
- use base qw(DBD::File);
+ use base qw( DBD::File );
sub driver
{
...
- my $drh = $proto->SUPER::driver($attr);
+ my $drh = $proto->SUPER::driver ($attr);
...
return $drh->{class};
}
@@ -20,14 +20,14 @@
package DBD::myDriver::dr;
- @ISA = qw(DBD::File::dr);
+ @ISA = qw( DBD::File::dr );
sub data_sources { ... }
...
package DBD::myDriver::db;
- @ISA = qw(DBD::File::db);
+ @ISA = qw( DBD::File::db );
sub init_valid_attributes { ... }
sub init_default_attributes { ... }
@@ -38,34 +38,34 @@
package DBD::myDriver::st;
- @ISA = qw(DBD::File::st);
+ @ISA = qw( DBD::File::st );
sub FETCH { ... }
sub STORE { ... }
package DBD::myDriver::Statement;
- @ISA = qw(DBD::File::Statement);
+ @ISA = qw( DBD::File::Statement );
package DBD::myDriver::Table;
- @ISA = qw(DBD::File::Table);
+ @ISA = qw( DBD::File::Table );
my %reset_on_modify = (
- myd_abc => "myd_foo",
- myd_mno => "myd_bar",
- );
- __PACKAGE__->register_reset_on_modify( \%reset_on_modify );
+ myd_abc => "myd_foo",
+ myd_mno => "myd_bar",
+ );
+ __PACKAGE__->register_reset_on_modify (\%reset_on_modify);
my %compat_map = (
- abc => 'foo_abc',
- xyz => 'foo_xyz',
- );
- __PACKAGE__->register_compat_map( \%compat_map );
+ abc => 'foo_abc',
+ xyz => 'foo_xyz',
+ );
+ __PACKAGE__->register_compat_map (\%compat_map);
sub bootstrap_table_meta { ... }
sub init_table_meta { ... }
sub table_meta_attr_changed { ... }
- sub open_file { ... }
+ sub open_data { ... }
sub fetch_row { ... }
sub push_row { ... }
@@ -106,14 +106,14 @@
# invokes
package DBD::DBM::dr;
- @DBD::DBM::dr::ISA = qw(DBD::File::dr);
+ @DBD::DBM::dr::ISA = qw( DBD::File::dr );
sub connect ($$;$$$)
{
...
- }
+ }
-Similar for C<< data_sources () >> and C<< disconnect_all() >>.
+Similar for C<< data_sources >> and C<< disconnect_all >>.
Pure Perl DBI drivers derived from DBD::File do not usually need to
override any of the methods provided through the DBD::XXX::dr package
@@ -154,12 +154,12 @@
sub driver
{
- my ( $class, $attr ) = @_;
+ my ($class, $attr) = @_;
...
- my $drh = $class->SUPER::driver( $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
@@ -209,7 +209,7 @@
(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
+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
@@ -269,11 +269,11 @@
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>,
-C<drv_version> and C<drv_meta> are added (when available) to the list of
-valid and immutable attributes (where C<drv_> is interpreted as the driver
-prefix).
+containing the immutable attributes (e.g.
+C<< $dbh->{dbm_readonly_attrs} = {...}; >>), the attributes
+C<drv_valid_attrs>, C<drv_readonly_attrs>, C<drv_version> and C<drv_meta>
+are added (when available) to the list of valid and immutable attributes
+(where C<drv_> is interpreted as the driver prefix).
If C<drv_meta> is set, an attribute with the name in C<drv_meta> is
initialized providing restricted read/write access to the meta data of the
@@ -291,8 +291,7 @@
Retrieve an attribute from a table's meta information. The method
signature is C<< get_file_meta ($dbh, $table, $attr) >>. This method
-is called by the injected db handle method C<< ${drv_prefix}get_meta
->>.
+is called by the injected db handle method C<< ${drv_prefix}get_meta >>.
While get_file_meta allows C<$table> or C<$attr> to be a list of tables or
attributes to retrieve, get_single_table_meta allows only one table name
@@ -357,6 +356,129 @@
=back
+=head2 DBD::File::TableSource::FileSystem
+
+Provides data sources and table information on database driver and database
+handle level.
+
+ package DBD::File::TableSource::FileSystem;
+
+ sub data_sources ($;$)
+ {
+ my ($class, $drh, $attrs) = @_;
+ ...
+ }
+
+ sub avail_tables
+ {
+ my ($class, $drh) = @_;
+ ...
+ }
+
+The C<data_sources> method is called when the user invokes any of the
+following:
+
+ @ary = DBI->data_sources ($driver);
+ @ary = DBI->data_sources ($driver, \%attr);
+
+ @ary = $dbh->data_sources ();
+ @ary = $dbh->data_sources (\%attr);
+
+The C<avail_tables> method is called when the user invokes any of the
+following:
+
+ @names = $dbh->tables ($catalog, $schema, $table, $type);
+
+ $sth = $dbh->table_info ($catalog, $schema, $table, $type);
+ $sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr);
+
+ $dbh->func ("list_tables");
+
+Every time where an C<\%attr> argument can be specified, this C<\%attr>
+object's C<sql_table_source> attribute is preferred over the C<$dbh>
+attribute or the driver default.
+
+=head2 DBD::File::DataSource::Stream
+
+ package DBD::File::DataSource::Stream;
+
+ @DBD::File::DataSource::Stream::ISA = 'DBI::DBD::SqlEngine::DataSource';
+
+ sub complete_table_name
+ {
+ my ($self, $meta, $file, $respect_case) = @_;
+ ...
+ }
+
+Clears all meta attributes identifying a file: C<f_fqfn>, C<f_fqbn> and
+C<f_fqln>. The table name is set according to C<$respect_case> and
+C<< $meta->{sql_identifier_case} >> (SQL_IC_LOWER, SQL_IC_UPPER).
+
+ package DBD::File::DataSource::Stream;
+
+ sub apply_encoding
+ {
+ my ($self, $meta, $fn) = @_;
+ ...
+ }
+
+Applies the encoding from I<meta information> (C<< $meta->{f_encoding} >>)
+to the file handled opened in C<open_data>.
+
+ package DBD::File::DataSource::Stream;
+
+ sub open_data
+ {
+ my ($self, $meta, $attrs, $flags) = @_;
+ ...
+ }
+
+Opens (C<dup (2)>) the file handle provided in C<< $meta->{f_file} >>.
+
+ package DBD::File::DataSource::Stream;
+
+ sub can_flock { ... }
+
+Returns whether C<flock (2)> is available or not (avoids retesting in
+subclasses).
+
+=head2 DBD::File::DataSource::File
+
+ package DBD::File::DataSource::File;
+
+ sub complete_table_name ($$;$)
+ {
+ my ($self, $meta, $table, $respect_case) = @_;
+ ...
+ }
+
+The method C<complete_table_name> tries to map a filename to the associated
+table name. It is called with a partially filled meta structure for the
+resulting table containing at least the following attributes:
+C<< f_ext >>, C<< f_dir >>, C<< f_lockfile >> and C<< sql_identifier_case >>.
+
+If a file/table map can be found then this method sets the C<< f_fqfn
+>>, C<< f_fqbn >>, C<< f_fqln >> and C<< table_name >> attributes in
+the meta structure. If a map cannot be found the table name will be
+undef.
+
+ package DBD::File::DataSource::File;
+
+ sub open_data ($)
+ {
+ my ($self, $meta, $attrs, $flags) = @_;
+ ...
+ }
+
+Depending on the attributes set in the table's meta data, the
+following steps are performed. Unless C<< f_dontopen >> is set to a
+true value, C<< f_fqfn >> must contain the full qualified file name
+for the table to work on (file2table ensures this). The encoding in
+C<< f_encoding >> is applied if set and the file is opened. If
+C<<f_fqln >> (full qualified lock name) is set, this file is opened,
+too. Depending on the value in C<< f_lock >>, the appropriate lock is
+set on the opened data file or lock file.
+
=head2 DBD::File::Statement
Derives from DBI::SQL::Nano::Statement to provide following method:
@@ -367,7 +489,7 @@
Implements the open_table method required by L<SQL::Statement> and
L<DBI::SQL::Nano>. All the work for opening the file(s) belonging to the
-table is handled and parameterized in DBD::File::Table. Unless you intend
+table is handled and parametrized in DBD::File::Table. Unless you intend
to add anything to the following implementation, an empty DBD::XXX::Statement
package satisfies DBD::File.
@@ -379,8 +501,8 @@
$class =~ s/::Statement/::Table/;
my $flags = {
- createMode => $createMode,
- lockMode => $lockMode,
+ createMode => $createMode,
+ lockMode => $lockMode,
};
$self->{command} eq "DROP" and $flags->{dropMode} = 1;
@@ -396,18 +518,6 @@
=over 4
-=item file2table
-
-This method tries to map a filename to the associated table
-name. It is called with a partially filled meta structure for the
-resulting table containing at least the following attributes:
-C<< f_ext >>, C<< f_dir >>, C<< f_lockfile >> and C<< sql_identifier_case >>.
-
-If a file/table map can be found then this method sets the C<< f_fqfn
->>, C<< f_fqbn >>, C<< f_fqln >> and C<< table_name >> attributes in
-the meta structure. If a map cannot be found the table name will be
-undef.
-
=item bootstrap_table_meta
Initializes a table meta structure. Can be safely overridden in a
@@ -415,9 +525,8 @@
of the overridden method.
It copies the following attributes from the database into the table meta data
-C<< f_dir >>, C<< f_ext >>, C<< f_encoding >>, C<< f_lock >>, C<< f_schema >>,
-C<< f_lockfile >> and C<< sql_identifier_case >> and makes them sticky to the
-table.
+C<< f_dir >>, C<< f_ext >>, C<< f_encoding >>, C<< f_lock >>, C<< f_schema >>
+and C<< f_lockfile >> and makes them sticky to the table.
This method should be called before you attempt to map between file
name and table name to ensure the correct directory, extension etc. are
@@ -467,17 +576,17 @@
If your DBD has calculated values in the meta data area, then call
C<register_reset_on_modify>:
- my %reset_on_modify = ( "xxx_foo" => "xxx_bar" );
- __PACKAGE__->register_reset_on_modify( \%reset_on_modify );
+ my %reset_on_modify = (xxx_foo => "xxx_bar");
+ __PACKAGE__->register_reset_on_modify (\%reset_on_modify);
=item register_compat_map
Allows C<get_table_meta_attr> and C<set_table_meta_attr> to update the
attribute name to the current favored one:
- # from DBD::DBM
- my %compat_map = ( "dbm_ext" => "f_ext" );
- __PACKAGE__->register_compat_map( \%compat_map );
+ # from DBD::DBM
+ my %compat_map = (dbm_ext => "f_ext");
+ __PACKAGE__->register_compat_map (\%compat_map);
=item open_file
@@ -545,7 +654,7 @@
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack
+Copyright (C) 2010-2013 by H.Merijn Brand & Jens Rehsack
All rights reserved.
Modified: dbi/trunk/lib/DBD/File/HowTo.pod
==============================================================================
--- dbi/trunk/lib/DBD/File/HowTo.pod (original)
+++ dbi/trunk/lib/DBD/File/HowTo.pod Fri Dec 21 09:11:32 2012
@@ -140,32 +140,11 @@
=head2 User comfort
C<DBD::File> since C<0.39> consolidates all persistent meta data of a table
-into a single structure stored in C<< $dbh->{f_meta} >>. While DBD::File
-provides only readonly access to this structure, modifications are still
-allowed.
-
-Primarily DBD::File provides access via setters C<get_file_meta>,
-C<set_file_meta> and C<clear_file_meta>. Those methods are easily
-accessible by the users via the C<< $dbh->func () >> interface provided
-by DBI. Well, many users don't feel comfortize when calling
-
- # don't require extension for tables cars
- $dbh->func ("cars", "f_ext", ".csv", "set_file_meta");
-
-DBD::File will inject a method into your driver to increase the user
-comfort to allow:
-
- # don't require extension for tables cars
- $dbh->foo_set_meta ("cars", "f_ext", ".csv");
-
-Better, but here and there users likes to do:
-
- # don't require extension for tables cars
- $dbh->{foo_tables}->{cars}->{f_ext} = ".csv";
-
-This interface is provided when derived DBD's define following in
-C<init_valid_attributes> (please compare carefully with the example in
-DBI::DBD::SqlEngine::HowTo):
+into a single structure stored in C<< $dbh->{f_meta} >>. With C<DBD::File>
+version C<0.41> and C<DBI::DBD::SqlEngine> version C<0.05>, this
+consolidation moves to L<DBI::DBD::SqlEngine>. It's still the
+C<< $dbh->{$drv_prefix . "_meta"} >> attribute which cares, so what you
+learned at this place before, is still valid.
sub init_valid_attributes
{
@@ -173,73 +152,15 @@
$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
- foo_meta => 1, # contains the public interface to modify table meta attributes
- };
- $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
- foo_meta => 1, # ensure public interface to modify table meta attributes are immutable
- };
+ $dbh->{foo_valid_attrs} = { ... };
+ $dbh->{foo_readonly_attrs} = { ... };
$dbh->{foo_meta} = "foo_tables";
return $dbh;
}
-This provides a tied hash in C<< $dbh->{foo_tables} >> and a tied hash for
-each table's meta data in C<< $dbh->{foo_tables}->{$table_name} >>.
-Modifications on the table meta attributes are done using the table
-methods:
-
- sub get_table_meta_attr { ... }
- sub set_table_meta_attr { ... }
-
-Both methods can adjust the attribute name for compatibility reasons, e.g.
-when former versions of the DBD allowed different names to be used for the
-same flag:
-
- my %compat_map = (
- abc => 'foo_abc',
- xyz => 'foo_xyz',
- );
- __PACKAGE__->register_compat_map( \%compat_map );
-
-If any user modification on a meta attribute needs reinitialization of
-the meta structure (in case of C<DBD::File> these are the attributes
-C<f_file>, C<f_dir>, C<f_ext> and C<f_lockfile>), inform DBD::File by
-doing
-
- my %reset_on_modify = (
- foo_xyz => "foo_bar",
- foo_abc => "foo_bar",
- );
- __PACKAGE__->register_reset_on_modify( \%reset_on_modify );
-
-The next access to the table meta data will force DBD::File to re-do the
-entire meta initialization process.
-
-Any further action which needs to be taken can handled in
-C<table_meta_attr_changed>:
-
- sub table_meta_attr_changed
- {
- my ($class, $meta, $attrib, $value) = @_;
- ...
- $class->SUPER::table_meta_attr_changed ($meta, $attrib, $value);
- }
-
-This is done before the new value is set in C<$meta>, so the attribute
-changed handler can act depending on the old value.
+See updates at L<DBI::DBD::SqlEngine::HowTo/User comfort>.
=head2 Testing
Modified: dbi/trunk/lib/DBD/File/Roadmap.pod
==============================================================================
--- dbi/trunk/lib/DBD/File/Roadmap.pod (original)
+++ dbi/trunk/lib/DBD/File/Roadmap.pod Fri Dec 21 09:11:32 2012
@@ -71,7 +71,7 @@
DBD::RAM or DBD::PO etc.
To improve the performance of the underlying SQL engines, a clean
-reimplementation seems to be required. Currently both engines are
+re-implementation seems to be required. Currently both engines are
prematurely optimized and therefore it is not trivial to provide
further optimization without the risk of breaking existing features.
@@ -142,7 +142,7 @@
=head1 PRIORITIES
-Our priorities are focussed on current issues. Initially many new test
+Our priorities are focused on current issues. Initially many new test
cases for DBD::File and DBD::DBM should be added to the DBI test
suite. After that some additional documentation on how to use the
DBD::File API will be provided.
Modified: dbi/trunk/lib/DBI/DBD/SqlEngine.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD/SqlEngine.pm (original)
+++ dbi/trunk/lib/DBI/DBD/SqlEngine.pm Fri Dec 21 09:11:32 2012
@@ -9,7 +9,7 @@
#
# The original author is Jochen Wiedmann.
#
-# Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack
+# Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack
# Copyright (C) 2004 by Jeff Zucker
# Copyright (C) 1998 by Jochen Wiedmann
#
@@ -33,13 +33,18 @@
use Carp;
use vars qw( @ISA $VERSION $drh %methods_installed);
-$VERSION = "0.03";
+$VERSION = "0.05";
$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", );
+my %accessors = (
+ versions => "get_driver_versions",
+ get_meta => "get_sql_engine_meta",
+ set_meta => "set_sql_engine_meta",
+ clear_meta => "clear_sql_engine_meta",
+ );
sub driver ($;$)
{
@@ -94,7 +99,7 @@
# XXX inject DBD::XXX::Statement unless exists
my $stclass = $class . "::st";
- $stclass->install_method("sql_get_colnames") unless ( $methods_installed{$class}++ );
+ $stclass->install_method("sql_get_colnames") unless ( $methods_installed{__PACKAGE__}++ );
return $drh->{$class};
} # driver
@@ -113,6 +118,8 @@
use vars qw(@ISA $imp_data_size);
+use Carp qw/carp/;
+
$imp_data_size = 0;
sub connect ($$;$$$)
@@ -134,8 +141,9 @@
# 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};
+ defined $dbh->{sql_init_phase} and $two_phased_init = ++$dbh->{sql_init_phase};
my %second_phase_attrs;
+ my @func_inits;
my ( $var, $val );
while ( length $dbname )
@@ -149,51 +157,71 @@
$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 );
- }
+ exists $attr->{$var} and carp("$var is given in DSN *and* \$attr during DBI->connect()") if($^W);
+ exists $attr->{$var} or $attr->{$var} = $val;
}
elsif ( $var =~ m/^(.+?)=>(.*)/s )
{
$var = $1;
( $val = $2 ) =~ s/\\(.)/$1/g;
my $ref = eval $val;
- $dbh->$var($ref);
+ # $dbh->$var($ref);
+ push(@func_inits, $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;
- }
+ # The attributes need to be sorted in a specific way as the
+ # assignment is through tied hashes and calls STORE on each
+ # attribute. Some attributes require to be called prior to
+ # others
+ # e.g. f_dir *must* be done before xx_tables in DBD::File
+ # The dbh attribute sql_init_order is a hash with the order
+ # as key (low is first, 0 .. 100) and the attributes that
+ # are set to that oreder as anon-list as value:
+ # { 0 => [qw( AutoCommit PrintError RaiseError Profile ... )],
+ # 10 => [ list of attr to be dealt with immediately after first ],
+ # 50 => [ all fields that are unspecified or default sort order ],
+ # 90 => [ all fields that are needed after other initialisation ],
+ # }
+
+ my %order = map {
+ my $order = $_;
+ map { ( $_ => $order ) } @{ $dbh->{sql_init_order}{$order} };
+ } sort { $a <=> $b } keys %{ $dbh->{sql_init_order} || {} };
+ my @ordered_attr =
+ map { $_->[0] }
+ sort { $a->[1] <=> $b->[1] }
+ map { [ $_, defined $order{$_} ? $order{$_} : 50 ] }
+ keys %$attr;
+
+ # initialize given attributes ... lower weighted before higher weighted
+ foreach my $a (@ordered_attr)
+ {
+ exists $attr->{$a} or next;
+ $two_phased_init and eval {
+ $dbh->{$a} = $attr->{$a};
+ delete $attr->{$a};
+ };
+ $@ and $second_phase_attrs{$a} = delete $attr->{$a};
+ $two_phased_init or $dbh->STORE($a, delete $attr->{$a});
+ }
- $dbh->func( 1, "init_default_attributes" );
- %$attr = %second_phase_attrs;
- }
+ $two_phased_init and $dbh->func( 1, "init_default_attributes" );
+ %$attr = %second_phase_attrs;
+
+ for( my $i = 0; $i < scalar(@func_inits); $i += 2 )
+ {
+ my $func = $func_inits[$i];
+ my $arg = $func_inits[$i+1];
+ $dbh->$func($arg);
+ }
- $dbh->func("init_done");
+ $dbh->func("init_done");
$dbh->STORE( Active => 1 );
}
@@ -201,6 +229,24 @@
return $dbh;
} # connect
+sub data_sources ($;$)
+{
+ my ( $drh, $attr ) = @_;
+
+ my $tbl_src;
+ $attr
+ and defined $attr->{sql_table_source}
+ and $attr->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource')
+ and $tbl_src = $attr->{sql_table_source};
+
+ !defined($tbl_src)
+ and $drh->{ImplementorClass}->can('default_table_source')
+ and $tbl_src = $drh->{ImplementorClass}->default_table_source();
+ defined($tbl_src) or return;
+
+ $tbl_src->data_sources( $drh, $attr );
+} # data_sources
+
sub disconnect_all
{
} # disconnect_all
@@ -238,6 +284,15 @@
( $_[0]->FETCH("Active") ) ? 1 : 0;
} # ping
+sub data_sources
+{
+ my ( $dbh, $attr, @other ) = @_;
+ my $drh = $dbh->{Driver}; # XXX proxy issues?
+ ref($attr) eq 'HASH' or $attr = {};
+ defined( $attr->{sql_table_source} ) or $attr->{sql_table_source} = $dbh->{sql_table_source};
+ return $drh->data_sources( $attr, @other );
+}
+
sub prepare ($$;@)
{
my ( $dbh, $statement, @attribs ) = @_;
@@ -272,7 +327,7 @@
{
$stmt = eval { $class->new($statement) };
}
- if ($@ || $stmt->{errstr})
+ if ( $@ || $stmt->{errstr} )
{
$dbh->set_err( $DBI::stderr, $@ || $stmt->{errstr} );
undef $sth;
@@ -311,19 +366,21 @@
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
+ 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
+ sql_meta => 1, # meta data for tables
+ sql_meta_map => 1, # mapping table for identifier case
};
$dbh->{sql_readonly_attrs} = {
sql_engine_version => 1, # DBI::DBD::SqlEngine version
@@ -349,7 +406,7 @@
{
# we have an "old" driver here
$phase = defined $dbh->{sql_init_phase};
- $phase and $phase = $dbh->{sql_init_phase};
+ $phase and $phase = $dbh->{sql_init_phase};
}
if ( 0 == $phase )
@@ -362,7 +419,7 @@
$dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER
$dbh->{sql_quoted_identifier_case} = 3; # SQL_IC_SENSITIVE
- $dbh->{sql_dialect} = "CSV";
+ $dbh->{sql_dialect} = "CSV";
$dbh->{sql_init_phase} = $given_phase;
@@ -372,8 +429,46 @@
my $valid_attrs = $drv_prefix . "valid_attrs";
my $ro_attrs = $drv_prefix . "readonly_attrs";
+ # check whether we're running in a Gofer server or not (see
+ # validate_FETCH_attr for details)
+ $dbh->{sql_engine_in_gofer} =
+ ( defined $INC{"DBD/Gofer.pm"} && ( caller(5) )[0] eq "DBI::Gofer::Execute" );
+ $dbh->{sql_meta} = {};
+ $dbh->{sql_meta_map} = {}; # choose new name because it contains other keys
+
+ # init_default_attributes calls inherited routine before derived DBD's
+ # init their default attributes, so we don't override something here
+ #
+ # defining an order of attribute initialization from connect time
+ # specified ones with a magic baarier (see next statement)
+ my $drv_pfx_meta = $drv_prefix . "meta";
+ $dbh->{sql_init_order} = {
+ 0 => [qw( Profile RaiseError PrintError AutoCommit )],
+ 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ],
+ };
+ # ensuring Profile, RaiseError, PrintError, AutoCommit are initialized
+ # first when initializing attributes from connect time specified
+ # attributes
+ # further, initializations to predefined tables are happens after any
+ # unspecified attribute initialization (that default to order 50)
+
my @comp_attrs = qw(valid_attrs version readonly_attrs);
+ if ( exists $dbh->{$drv_pfx_meta} and !$dbh->{sql_engine_in_gofer} )
+ {
+ my $attr = $dbh->{$drv_pfx_meta};
+ defined $attr
+ and defined $dbh->{$valid_attrs}
+ and !defined $dbh->{$valid_attrs}{$attr}
+ and $dbh->{$valid_attrs}{$attr} = 1;
+
+ my %h;
+ tie %h, "DBI::DBD::SqlEngine::TieTables", $dbh;
+ $dbh->{$attr} = \%h;
+
+ push @comp_attrs, "meta";
+ }
+
foreach my $comp_attr (@comp_attrs)
{
my $attr = $drv_prefix . $comp_attr;
@@ -428,6 +523,8 @@
sub disconnect ($)
{
+ %{ $_[0]->{sql_meta} } = ();
+ %{ $_[0]->{sql_meta_map} } = ();
$_[0]->STORE( Active => 0 );
return 1;
} # disconnect
@@ -436,6 +533,21 @@
{
my ( $dbh, $attrib ) = @_;
+ # If running in a Gofer server, access to our tied compatibility hash
+ # would force Gofer to serialize the tieing object including it's
+ # private $dbh reference used to do the driver function calls.
+ # This will result in nasty exceptions. So return a copy of the
+ # sql_meta structure instead, which is the source of for the compatibility
+ # tie-hash. It's not as good as liked, but the best we can do in this
+ # situation.
+ if ( $dbh->{sql_engine_in_gofer} )
+ {
+ ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//;
+ my $drv_prefix = DBI->driver_prefix($drv_class);
+ exists $dbh->{ $drv_prefix . "meta" } && $attrib eq $dbh->{ $drv_prefix . "meta" }
+ and $attrib = "sql_meta";
+ }
+
return $attrib;
}
@@ -448,8 +560,8 @@
# 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
+ # 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;
@@ -486,9 +598,16 @@
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
+ # XXX correctly a remap of all entries in sql_meta/sql_meta_map is required here
}
+ ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//;
+ my $drv_prefix = DBI->driver_prefix($drv_class);
+
+ exists $dbh->{ $drv_prefix . "meta" }
+ and $attrib eq $dbh->{ $drv_prefix . "meta" }
+ and $attrib = "sql_meta";
+
return ( $attrib, $value );
}
@@ -537,7 +656,18 @@
and return $dbh->set_err( $DBI::stderr,
"attribute '$attrib' is readonly and must not be modified" );
- $dbh->{$attrib} = $value;
+ if ( $attrib eq "sql_meta" )
+ {
+ while ( my ( $k, $v ) = each %$value )
+ {
+ $dbh->{$attrib}{$k} = $v;
+ }
+ }
+ else
+ {
+ $dbh->{$attrib} = $value;
+ }
+
return 1;
}
@@ -575,7 +705,8 @@
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
+ $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;
@@ -599,6 +730,125 @@
return wantarray ? @versions : join "\n", @versions;
} # get_versions
+sub get_single_table_meta
+{
+ my ( $dbh, $table, $attr ) = @_;
+ my $meta;
+
+ $table eq "."
+ and return $dbh->FETCH($attr);
+
+ ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/;
+ ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta or croak "No such table '$table'";
+
+ # prevent creation of undef attributes
+ return $class->get_table_meta_attr( $meta, $attr );
+} # get_single_table_meta
+
+sub get_sql_engine_meta
+{
+ my ( $dbh, $table, $attr ) = @_;
+
+ my $gstm = $dbh->{ImplementorClass}->can("get_single_table_meta");
+
+ $table eq "*"
+ and $table = [ ".", keys %{ $dbh->{sql_meta} } ];
+ $table eq "+"
+ and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ];
+ ref $table eq "Regexp"
+ and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_meta} } ];
+
+ ref $table || ref $attr
+ or return &$gstm( $dbh, $table, $attr );
+
+ ref $table or $table = [$table];
+ ref $attr or $attr = [$attr];
+ "ARRAY" eq ref $table
+ or return
+ $dbh->set_err( $DBI::stderr,
+ "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table );
+ "ARRAY" eq ref $attr
+ or return $dbh->set_err(
+ "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr );
+
+ my %results;
+ foreach my $tname ( @{$table} )
+ {
+ my %tattrs;
+ foreach my $aname ( @{$attr} )
+ {
+ $tattrs{$aname} = &$gstm( $dbh, $tname, $aname );
+ }
+ $results{$tname} = \%tattrs;
+ }
+
+ return \%results;
+} # get_sql_engine_meta
+
+sub set_single_table_meta
+{
+ my ( $dbh, $table, $attr, $value ) = @_;
+ my $meta;
+
+ $table eq "."
+ and return $dbh->STORE( $attr, $value );
+
+ ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/;
+ ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta or croak "No such table '$table'";
+ $class->set_table_meta_attr( $meta, $attr, $value );
+
+ return $dbh;
+} # set_single_table_meta
+
+sub set_sql_engine_meta
+{
+ my ( $dbh, $table, $attr, $value ) = @_;
+
+ my $sstm = $dbh->{ImplementorClass}->can("set_single_table_meta");
+
+ $table eq "*"
+ and $table = [ ".", keys %{ $dbh->{sql_meta} } ];
+ $table eq "+"
+ and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ];
+ ref($table) eq "Regexp"
+ and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_meta} } ];
+
+ ref $table || ref $attr
+ or return &$sstm( $dbh, $table, $attr, $value );
+
+ ref $table or $table = [$table];
+ ref $attr or $attr = { $attr => $value };
+ "ARRAY" eq ref $table
+ or croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got "
+ . ref $table;
+ "HASH" eq ref $attr
+ or croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr;
+
+ foreach my $tname ( @{$table} )
+ {
+ my %tattrs;
+ while ( my ( $aname, $aval ) = each %$attr )
+ {
+ &$sstm( $dbh, $tname, $aname, $aval );
+ }
+ }
+
+ return $dbh;
+} # set_file_meta
+
+sub clear_sql_engine_meta
+{
+ my ( $dbh, $table ) = @_;
+
+ ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/;
+ my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta and %{$meta} = ();
+
+ return;
+} # clear_file_meta
+
sub DESTROY ($)
{
my $dbh = shift;
@@ -626,13 +876,24 @@
MINIMUM_SCALE => 13,
MAXIMUM_SCALE => 14,
},
- [ "VARCHAR", DBI::SQL_VARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ],
+ [
+ "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, ],
+ [
+ "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
@@ -643,12 +904,23 @@
if ( $dbh->{sql_handler} eq "SQL::Statement" and $dbh->{sql_ram_tables} )
{
+ # XXX map +[ undef, undef, $_, "TABLE", "TEMP" ], keys %{...}
foreach my $table ( keys %{ $dbh->{sql_ram_tables} } )
{
push @tables, [ undef, undef, $table, "TABLE", "TEMP" ];
}
}
+ my $tbl_src;
+ defined $dbh->{sql_table_source}
+ and $dbh->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource')
+ and $tbl_src = $dbh->{sql_table_source};
+
+ !defined($tbl_src)
+ and $dbh->{Driver}->{ImplementorClass}->can('default_table_source')
+ and $tbl_src = $dbh->{Driver}->{ImplementorClass}->default_table_source();
+ defined($tbl_src) and push( @tables, $tbl_src->avail_tables($dbh) );
+
return @tables;
} # get_avail_tables
@@ -662,17 +934,18 @@
my @tables = $dbh->func("get_avail_tables");
# Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
- @tables or return;
+ # this no longer seems to be true @tables or return;
my $dbh2 = $dbh->func("sql_sponge_driver");
my $sth = $dbh2->prepare(
"TABLE_INFO",
{
- rows => \@tables,
- NAMES => $names,
+ rows => \@tables,
+ NAME => $names,
}
);
- $sth or $dbh->set_err( $DBI::stderr, $dbh2->errstr );
+ $sth or return $dbh->set_err( $DBI::stderr, $dbh2->errstr );
+ $sth->execute or return;
return $sth;
} # table_info
}
@@ -730,6 +1003,167 @@
return 0;
} # rollback
+# ====== Tie-Meta ==============================================================
+
+package DBI::DBD::SqlEngine::TieMeta;
+
+use Carp qw(croak);
+require Tie::Hash;
+@DBI::DBD::SqlEngine::TieMeta::ISA = qw(Tie::Hash);
+
+sub TIEHASH
+{
+ my ( $class, $tblClass, $tblMeta ) = @_;
+
+ my $self = bless(
+ {
+ tblClass => $tblClass,
+ tblMeta => $tblMeta,
+ },
+ $class
+ );
+ return $self;
+} # new
+
+sub STORE
+{
+ my ( $self, $meta_attr, $meta_val ) = @_;
+
+ $self->{tblClass}->set_table_meta_attr( $self->{tblMeta}, $meta_attr, $meta_val );
+
+ return;
+} # STORE
+
+sub FETCH
+{
+ my ( $self, $meta_attr ) = @_;
+
+ return $self->{tblClass}->get_table_meta_attr( $self->{tblMeta}, $meta_attr );
+} # FETCH
+
+sub FIRSTKEY
+{
+ my $a = scalar keys %{ $_[0]->{tblMeta} };
+ each %{ $_[0]->{tblMeta} };
+} # FIRSTKEY
+
+sub NEXTKEY
+{
+ each %{ $_[0]->{tblMeta} };
+} # NEXTKEY
+
+sub EXISTS
+{
+ exists $_[0]->{tblMeta}{ $_[1] };
+} # EXISTS
+
+sub DELETE
+{
+ croak "Can't delete single attributes from table meta structure";
+} # DELETE
+
+sub CLEAR
+{
+ %{ $_[0]->{tblMeta} } = ();
+} # CLEAR
+
+sub SCALAR
+{
+ scalar %{ $_[0]->{tblMeta} };
+} # SCALAR
+
+# ====== Tie-Tables ============================================================
+
+package DBI::DBD::SqlEngine::TieTables;
+
+use Carp qw(croak);
+require Tie::Hash;
+@DBI::DBD::SqlEngine::TieTables::ISA = qw(Tie::Hash);
+
+sub TIEHASH
+{
+ my ( $class, $dbh ) = @_;
+
+ ( my $tbl_class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/;
+ my $self = bless(
+ {
+ dbh => $dbh,
+ tblClass => $tbl_class,
+ },
+ $class
+ );
+ return $self;
+} # new
+
+sub STORE
+{
+ my ( $self, $table, $tbl_meta ) = @_;
+
+ "HASH" eq ref $tbl_meta
+ or croak "Invalid data for storing as table meta data (must be hash)";
+
+ ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 );
+ $meta or croak "Invalid table name '$table'";
+
+ while ( my ( $meta_attr, $meta_val ) = each %$tbl_meta )
+ {
+ $self->{tblClass}->set_table_meta_attr( $meta, $meta_attr, $meta_val );
+ }
+
+ return;
+} # STORE
+
+sub FETCH
+{
+ my ( $self, $table ) = @_;
+
+ ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 );
+ $meta or croak "Invalid table name '$table'";
+
+ my %h;
+ tie %h, "DBI::DBD::SqlEngine::TieMeta", $self->{tblClass}, $meta;
+
+ return \%h;
+} # FETCH
+
+sub FIRSTKEY
+{
+ my $a = scalar keys %{ $_[0]->{dbh}->{sql_meta} };
+ each %{ $_[0]->{dbh}->{sql_meta} };
+} # FIRSTKEY
+
+sub NEXTKEY
+{
+ each %{ $_[0]->{dbh}->{sql_meta} };
+} # NEXTKEY
+
+sub EXISTS
+{
+ exists $_[0]->{dbh}->{sql_meta}->{ $_[1] }
+ or exists $_[0]->{dbh}->{sql_meta_map}->{ $_[1] };
+} # EXISTS
+
+sub DELETE
+{
+ my ( $self, $table ) = @_;
+
+ ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 );
+ $meta or croak "Invalid table name '$table'";
+
+ delete $_[0]->{dbh}->{sql_meta}->{ $meta->{table_name} };
+} # DELETE
+
+sub CLEAR
+{
+ %{ $_[0]->{dbh}->{sql_meta} } = ();
+ %{ $_[0]->{dbh}->{sql_meta_map} } = ();
+} # CLEAR
+
+sub SCALAR
+{
+ scalar %{ $_[0]->{dbh}->{sql_meta} };
+} # SCALAR
+
# ====== STATEMENT =============================================================
package DBI::DBD::SqlEngine::st;
@@ -778,17 +1212,21 @@
$sth->finish;
my $stmt = $sth->{sql_stmt};
+
+ # must not proved when already executed - SQL::Statement modifies
+ # received params
unless ( $sth->{sql_params_checked}++ )
{
- # bug in SQL::Statement 1.20 and below causes breakage
- # on all but the first call
+ # SQL::Statement and DBI::SQL::Nano will return the list of required params
+ # when called in list context. Do not look into the several items, they're
+ # implementation specific and may change without warning
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;
+ return $sth->set_err( $DBI::stderr, $msg );
}
}
+
my @err;
my $result;
eval {
@@ -878,7 +1316,7 @@
$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" 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() ];
@@ -917,6 +1355,48 @@
return $_[0]->{sql_stmt}{NUM_OF_ROWS};
} # rows
+# ====== TableSource ===========================================================
+
+package DBI::DBD::SqlEngine::TableSource;
+
+use strict;
+use warnings;
+
+use Carp;
+
+sub data_sources ($;$)
+{
+ my ( $class, $drh, $attrs ) = @_;
+ croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement data_sources" );
+}
+
+sub avail_tables
+{
+ my ( $self, $dbh ) = @_;
+ croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement avail_tables" );
+}
+
+# ====== DataSource ============================================================
+
+package DBI::DBD::SqlEngine::DataSource;
+
+use strict;
+use warnings;
+
+use Carp;
+
+sub complete_table_name ($$;$)
+{
+ my ( $self, $meta, $table, $respect_case ) = @_;
+ croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement complete_table_name" );
+}
+
+sub open_data ($)
+{
+ my ( $self, $meta, $attrs, $flags ) = @_;
+ croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement open_data" );
+}
+
# ====== SQL::STATEMENT ========================================================
package DBI::DBD::SqlEngine::Statement;
@@ -928,6 +1408,38 @@
@DBI::DBD::SqlEngine::Statement::ISA = qw(DBI::SQL::Nano::Statement);
+sub open_table ($$$$$)
+{
+ my ( $self, $data, $table, $createMode, $lockMode ) = @_;
+
+ my $class = ref $self;
+ $class =~ s/::Statement/::Table/;
+
+ my $flags = {
+ createMode => $createMode,
+ lockMode => $lockMode,
+ };
+ $self->{command} eq "DROP" and $flags->{dropMode} = 1;
+
+ # because column name mapping is initialized in constructor ...
+ # and therefore specific opening operations might be done before
+ # reaching DBI::DBD::SqlEngine::Table->new(), we need to intercept
+ # ReadOnly here
+ my $write_op = $createMode || $lockMode || $flags->{dropMode};
+ if ($write_op)
+ {
+ my ( $tblnm, $table_meta ) = $class->get_table_meta( $data->{Database}, $table, 1 )
+ or croak "Cannot find appropriate file for table '$table'";
+ $table_meta->{readonly}
+ and croak "Table '$table' is marked readonly - "
+ . $self->{command}
+ . ( $lockMode ? " with locking" : "" )
+ . " command forbidden";
+ }
+
+ return $class->new( $data, { table => $table }, $flags );
+} # open_table
+
# ====== SQL::TABLE ============================================================
package DBI::DBD::SqlEngine::Table;
@@ -935,8 +1447,175 @@
use strict;
use warnings;
+use Carp;
+
@DBI::DBD::SqlEngine::Table::ISA = qw(DBI::SQL::Nano::Table);
+sub bootstrap_table_meta
+{
+ my ( $self, $dbh, $meta, $table ) = @_;
+
+ defined $dbh->{ReadOnly}
+ and !defined( $meta->{readonly} )
+ and $meta->{readonly} = $dbh->{ReadOnly};
+ defined $meta->{sql_identifier_case}
+ or $meta->{sql_identifier_case} = $dbh->{sql_identifier_case};
+
+ exists $meta->{sql_data_source} or $meta->{sql_data_source} = $dbh->{sql_data_source};
+
+ $meta;
+}
+
+sub init_table_meta
+{
+ my ( $self, $dbh, $meta, $table ) = @_ if (0);
+
+ return;
+} # init_table_meta
+
+sub get_table_meta ($$$;$)
+{
+ my ( $self, $dbh, $table, $respect_case, @other ) = @_;
+ unless ( defined $respect_case )
+ {
+ $respect_case = 0;
+ $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers
+ $table =~ s/\"$//;
+ }
+
+ unless ($respect_case)
+ {
+ defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table};
+ }
+
+ my $meta = {};
+ defined $dbh->{sql_meta}{$table} and $meta = $dbh->{sql_meta}{$table};
+
+ do_initialize:
+ unless ( $meta->{initialized} )
+ {
+ $self->bootstrap_table_meta( $dbh, $meta, $table, @other );
+ $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other )
+ or return;
+
+ if ( defined $meta->{table_name} and $table ne $meta->{table_name} )
+ {
+ $dbh->{sql_meta_map}{$table} = $meta->{table_name};
+ $table = $meta->{table_name};
+ }
+
+ # now we know a bit more - let's check if user can't use consequent spelling
+ # XXX add know issue about reset sql_identifier_case here ...
+ if ( defined $dbh->{sql_meta}{$table} )
+ {
+ $meta = delete $dbh->{sql_meta}{$table}; # avoid endless loop
+ $meta->{initialized}
+ or goto do_initialize;
+ #or $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other )
+ #or return;
+ }
+
+ unless ( $dbh->{sql_meta}{$table}{initialized} )
+ {
+ $self->init_table_meta( $dbh, $meta, $table );
+ $meta->{initialized} = 1;
+ $dbh->{sql_meta}{$table} = $meta;
+ }
+ }
+
+ return ( $table, $meta );
+} # get_table_meta
+
+my %reset_on_modify = ();
+my %compat_map = ();
+
+sub register_reset_on_modify
+{
+ my ( $proto, $extra_resets ) = @_;
+ foreach my $cv ( keys %$extra_resets )
+ {
+ #%reset_on_modify = ( %reset_on_modify, %$extra_resets );
+ push @{ $reset_on_modify{$cv} },
+ ref $extra_resets->{$cv} ? @{ $extra_resets->{$cv} } : ( $extra_resets->{$cv} );
+ }
+ return;
+} # register_reset_on_modify
+
+sub register_compat_map
+{
+ my ( $proto, $extra_compat_map ) = @_;
+ %compat_map = ( %compat_map, %$extra_compat_map );
+ return;
+} # register_compat_map
+
+sub get_table_meta_attr
+{
+ my ( $class, $meta, $attrib ) = @_;
+ exists $compat_map{$attrib}
+ and $attrib = $compat_map{$attrib};
+ exists $meta->{$attrib}
+ and return $meta->{$attrib};
+ return;
+} # get_table_meta_attr
+
+sub set_table_meta_attr
+{
+ my ( $class, $meta, $attrib, $value ) = @_;
+ exists $compat_map{$attrib}
+ and $attrib = $compat_map{$attrib};
+ $class->table_meta_attr_changed( $meta, $attrib, $value );
+ $meta->{$attrib} = $value;
+} # set_table_meta_attr
+
+sub table_meta_attr_changed
+{
+ my ( $class, $meta, $attrib, $value ) = @_;
+ defined $reset_on_modify{$attrib}
+ and delete @$meta{ @{ $reset_on_modify{$attrib} } }
+ and $meta->{initialized} = 0;
+} # table_meta_attr_changed
+
+sub open_data
+{
+ my ( $self, $meta, $attrs, $flags ) = @_;
+
+ $meta->{sql_data_source}
+ or croak "Table " . $meta->{table_name} . " not completely initialized";
+ $meta->{sql_data_source}->open_data( $meta, $attrs, $flags );
+
+ return;
+} # open_data
+
+# ====== SQL::Eval API =========================================================
+
+sub new
+{
+ my ( $className, $data, $attrs, $flags ) = @_;
+ my $dbh = $data->{Database};
+
+ my ( $tblnm, $meta ) = $className->get_table_meta( $dbh, $attrs->{table}, 1 )
+ or croak "Cannot find appropriate table '$attrs->{table}'";
+ $attrs->{table} = $tblnm;
+
+ # Being a bit dirty here, as SQL::Statement::Structure does not offer
+ # me an interface to the data I want
+ $flags->{createMode} && $data->{sql_stmt}{table_defs}
+ and $meta->{table_defs} = $data->{sql_stmt}{table_defs};
+
+ # open_file must be called before inherited new is invoked
+ # because column name mapping is initialized in constructor ...
+ $className->open_data( $meta, $attrs, $flags );
+
+ my $tbl = {
+ %{$attrs},
+ meta => $meta,
+ col_names => $meta->{col_names} || [],
+ };
+ return $className->SUPER::new($tbl);
+} # new
+
+1;
+
=pod
=head1 NAME
@@ -1151,6 +1830,277 @@
it's strongly recommended to set this flag before any statement is
executed (best place is connect attribute hash).
+=head4 sql_engine_in_gofer
+
+This value has a true value in case of this driver is operated via
+L<DBD::Gofer>. The impact of being operated via Gofer is a read-only
+driver (not read-only databases!), so you cannot modify any attributes
+later - neither any table settings. B<But> you won't get an error in
+cases you modify table attributes, so please carefully watch
+C<sql_engine_in_gofer>.
+
+=head4 sql_meta
+
+Private data area which contains information about the tables this
+module handles. Table meta data might not be available until the
+table has been accessed for the first time e.g., by issuing a select
+on it however it is possible to pre-initialize attributes for each table
+you use.
+
+DBI::DBD::SqlEngine recognizes the (public) attributes C<col_names>,
+C<table_name>, C<readonly>, C<sql_data_source> and C<sql_identifier_case>.
+Be very careful when modifying attributes you do not know, the consequence
+might be a destroyed or corrupted table.
+
+While C<sql_meta> is a private and readonly attribute (which means, you
+cannot modify it's values), derived drivers might provide restricted
+write access through another attribute. Well known accessors are
+C<csv_tables> for L<DBD::CSV>, C<ad_tables> for L<DBD::AnyData> and
+C<dbm_tables> for L<DBD::DBM>.
+
+=head4 sql_table_source
+
+Controls the class which will be used for fetching available tables.
+
+See L</DBI::DBD::SqlEngine::TableSource> for details.
+
+=head4 sql_data_source
+
+Contains the class name to be used for opening tables.
+
+See L</DBI::DBD::SqlEngine::DataSource> for details.
+
+=head2 Driver private methods
+
+=head3 Default DBI methods
+
+=head4 data_sources
+
+The C<data_sources> method returns a list of subdirectories of the current
+directory in the form "dbi:CSV:f_dir=$dirname".
+
+If you want to read the subdirectories of another directory, use
+
+ my ($drh) = DBI->install_driver ("CSV");
+ my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data");
+
+=head4 list_tables
+
+This method returns a list of file names inside $dbh->{f_dir}.
+Example:
+
+ my ($dbh) = DBI->connect ("dbi:CSV:f_dir=/usr/local/csv_data");
+ my (@list) = $dbh->func ("list_tables");
+
+Note that the list includes all files contained in the directory, even
+those that have non-valid table names, from the view of SQL.
+
+=head3 Additional methods
+
+The following methods are only available via their documented name when
+DBI::DBD::SQlEngine is used directly. Because this is only reasonable for
+testing purposes, the real names must be used instead. Those names can be
+computed by replacing the C<sql_> in the method name with the driver prefix.
+
+=head4 sql_versions
+
+Signature:
+
+ sub sql_versions (;$) {
+ my ($table_name) = @_;
+ $table_name ||= ".";
+ ...
+ }
+
+Returns the versions of the driver, including the DBI version, the Perl
+version, DBI::PurePerl version (if DBI::PurePerl is active) and the version
+of the SQL engine in use.
+
+ my $dbh = DBI->connect ("dbi:File:");
+ my $sql_versions = $dbh->func( "sql_versions" );
+ print "$sql_versions\n";
+ __END__
+ # DBI::DBD::SqlEngine 0.05 using SQL::Statement 1.402
+ # DBI 1.623
+ # OS netbsd (6.99.12)
+ # Perl 5.016002 (x86_64-netbsd-thread-multi)
+
+Called in list context, sql_versions will return an array containing each
+line as single entry.
+
+Some drivers might use the optional (table name) argument and modify
+version information related to the table (e.g. DBD::DBM provides storage
+backend information for the requested table, when it has a table name).
+
+=head4 sql_get_meta
+
+Signature:
+
+ sub sql_get_meta ($$)
+ {
+ my ($table_name, $attrib) = @_;
+ ...
+ }
+
+Returns the value of a meta attribute set for a specific table, if any.
+See L<sql_meta> for the possible attributes.
+
+A table name of C<"."> (single dot) is interpreted as the default table.
+This will retrieve the appropriate attribute globally from the dbh.
+This has the same restrictions as C<< $dbh->{$attrib} >>.
+
+=head4 sql_set_meta
+
+Signature:
+
+ sub sql_set_meta ($$$)
+ {
+ my ($table_name, $attrib, $value) = @_;
+ ...
+ }
+
+Sets the value of a meta attribute set for a specific table.
+See L<sql_meta> for the possible attributes.
+
+A table name of C<"."> (single dot) is interpreted as the default table
+which will set the specified attribute globally for the dbh.
+This has the same restrictions as C<< $dbh->{$attrib} = $value >>.
+
+=head4 sql_clear_meta
+
+Signature:
+
+ sub sql_clear_meta ($)
+ {
+ my ($table_name) = @_;
+ ...
+ }
+
+Clears the table specific meta information in the private storage of the
+dbh.
+
+=head2 Extensibility
+
+=head3 DBI::DBD::SqlEngine::TableSource
+
+Provides data sources and table information on database driver and database
+handle level.
+
+ package DBI::DBD::SqlEngine::TableSource;
+
+ sub data_sources ($;$)
+ {
+ my ( $class, $drh, $attrs ) = @_;
+ ...
+ }
+
+ sub avail_tables
+ {
+ my ( $class, $drh ) = @_;
+ ...
+ }
+
+The C<data_sources> method is called when the user invokes any of the
+following:
+
+ @ary = DBI->data_sources($driver);
+ @ary = DBI->data_sources($driver, \%attr);
+
+ @ary = $dbh->data_sources();
+ @ary = $dbh->data_sources(\%attr);
+
+The C<avail_tables> method is called when the user invokes any of the
+following:
+
+ @names = $dbh->tables( $catalog, $schema, $table, $type );
+
+ $sth = $dbh->table_info( $catalog, $schema, $table, $type );
+ $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr );
+
+ $dbh->func( "list_tables" );
+
+Everytime where an C<\%attr> argument can be specified, this C<\%attr>
+object's C<sql_table_source> attribute is preferred over the C<$dbh>
+attribute or the driver default, eg.
+
+ @ary = DBI->data_sources("dbi:CSV:", {
+ f_dir => "/your/csv/tables",
+ # note: this class doesn't comes with DBI
+ sql_table_source => "DBD::File::Archive::Tar::TableSource",
+ # scan tarballs instead of directories
+ });
+
+When you're going to implement such a DBD::File::Archive::Tar::TableSource
+class, remember to add correct attributes (including C<sql_table_source>
+and C<sql_data_source>) to the returned DSN's.
+
+=head3 DBI::DBD::SqlEngine::DataSource
+
+Provides base functionality for dealing with tables. It is primarily
+designed for allowing transparent access to files on disk or already
+opened (file-)streams (eg. for DBD::CSV).
+
+Derived classes shall be restricted to similar functionality, too (eg.
+opening streams from an archive, transparently compress/uncompress
+log files before parsing them,
+
+ package DBI::DBD::SqlEngine::DataSource;
+
+ sub complete_table_name ($$;$)
+ {
+ my ( $self, $meta, $table, $respect_case ) = @_;
+ ...
+ }
+
+The method C<complete_table_name> is called when first setting up the
+I<meta information> for a table:
+
+ "SELECT user.id, user.name, user.shell FROM user WHERE ..."
+
+results in opening the table C<user>. First step of the table open
+process is completing the name. Let's imagine you're having a L<DBD::CSV>
+handle with following settings:
+
+ $dbh->{sql_identifier_case} = SQL_IC_LOWER;
+ $dbh->{f_ext} = '.lst';
+ $dbh->{f_dir} = '/data/web/adrmgr';
+
+Those settings will result in looking for files matching
+C<[Uu][Ss][Ee][Rr](\.lst)?$> in C</data/web/adrmgr/>. The scanning of the
+directory C</data/web/adrmgr/> and the pattern match check will be done
+in C<DBD::File::DataSource::File> by the C<complete_table_name> method.
+
+If you intend to provide other sources of data streams than files, in
+addition to provide an appropriate C<complete_table_name> method, a method
+to open the resource is required:
+
+ package DBI::DBD::SqlEngine::DataSource;
+
+ sub open_data ($)
+ {
+ my ( $self, $meta, $attrs, $flags ) = @_;
+ ...
+ }
+
+After the method C<open_data> has been run successfully, the table's meta
+information are in a state which allowes the table's data accessor methods
+will be able to fetch/store row information. Implementation details heavily
+depends on the table implementation, whereby the most famous is surely
+L<DBD::File/DBD::File::Table|DBD::File::Table>.
+
+=head1 SQL ENGINES
+
+DBI::DBD::SqlEngine currently supports two SQL engines:
+L<SQL::Statement|SQL::Statement> and
+L<DBI::SQL::Nano::Statement_|DBI::SQL::Nano>. DBI::SQL::Nano supports a
+I<very> limited subset of SQL statements, but it might be faster for some
+very simple tasks. SQL::Statement in contrast supports a much larger subset
+of ANSI SQL.
+
+To use SQL::Statement, you need at least version 1.401 of
+SQL::Statement and the environment variable C<DBI_SQL_NANO> must not
+be set to a true value.
+
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
@@ -1215,7 +2165,7 @@
=head1 COPYRIGHT AND LICENSE
- Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack
+ Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack
Copyright (C) 2004-2009 by Jeff Zucker
Copyright (C) 1998-2004 by Jochen Wiedmann
Modified: dbi/trunk/lib/DBI/DBD/SqlEngine/Developers.pod
==============================================================================
--- dbi/trunk/lib/DBI/DBD/SqlEngine/Developers.pod (original)
+++ dbi/trunk/lib/DBI/DBD/SqlEngine/Developers.pod Fri Dec 21 09:11:32 2012
@@ -54,6 +54,22 @@
@ISA = qw(DBI::DBD::SqlEngine::Table);
+ my %reset_on_modify = (
+ myd_abc => "myd_foo",
+ myd_mno => "myd_bar",
+ );
+ __PACKAGE__->register_reset_on_modify( \%reset_on_modify );
+ my %compat_map = (
+ abc => 'foo_abc',
+ xyz => 'foo_xyz',
+ );
+ __PACKAGE__->register_compat_map( \%compat_map );
+
+ sub bootstrap_table_meta { ... }
+ sub init_table_meta { ... }
+ sub table_meta_attr_changed { ... }
+ sub open_data { ... }
+
sub new { ... }
sub fetch_row { ... }
@@ -105,12 +121,13 @@
...
}
-Similar for C<< data_sources () >> and C<< disconnect_all() >>.
+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.
+Pure Perl DBI drivers derived from DBI::DBD::SqlEngine usually don't need to
+override any of the methods provided through the DBD::XXX::dr package.
+However if you need additional initialization not fitting in
+C<init_valid_attributes()> and C<init_default_attributes()> of you're ::db
+class, the connect method might be the final place to be modified.
=item DBI::DBD::SqlEngine::db
@@ -125,12 +142,51 @@
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::TieMeta;
+
+Provides the tie-magic for C<< $dbh->{$drv_pfx . "_meta"} >>. Routes
+C<STORE> through C<< $drv->set_sql_engine_meta() >> and C<FETCH> through
+C<< $drv->get_sql_engine_meta() >>. C<DELETE> is not supported, you have
+to execute a C<DROP TABLE> statement, where applicable.
+
+=item DBI::DBD::SqlEngine::TieTables;
+
+Provides the tie-magic for tables in C<< $dbh->{$drv_pfx . "_meta"} >>.
+Routes C<STORE> though C<< $tblClass->set_table_meta_attr() >> and C<FETCH>
+though C<< $tblClass->get_table_meta_attr() >>. C<DELETE> removes an
+attribute from the I<meta object> retrieved by
+C<< $tblClass->get_table_meta() >>.
+
=item DBI::DBD::SqlEngine::st
Contains the methods to deal with prepared statement handles. e.g.,
$sth->execute () or die $sth->errstr;
+=item DBI::DBD::SqlEngine::TableSource;
+
+Base class for 3rd party table sources:
+
+ $dbh->{sql_table_source} = "DBD::Foo::TableSource";
+
+=item DBI::DBD::SqlEngine::DataSource;
+
+Base class for 3rd party data sources:
+
+ $dbh->{sql_data_source} = "DBD::Foo::DataSource";
+
+=item DBI::DBD::SqlEngine::Statement;
+
+Base class for derived drivers statement engine. Implements C<open_table>.
+
+=item DBI::DBD::SqlEngine::Table;
+
+Contains tailoring between SQL engine's requirements and
+C<DBI::DBD::SqlEngine> magic for finding the right tables and storage.
+Builds bridges between C<sql_meta> handling of C<DBI::DBD::SqlEngine::db>,
+table initialization for SQL engines and I<meta object>'s attribute
+management for derived drivers.
+
=back
=head2 DBI::DBD::SqlEngine
@@ -173,12 +229,66 @@
$DBD::XXX::dr::data_sources_attr = undef;
$DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann";
+=head3 Methods provided by C<< DBI::DBD::SqlEngine::dr >>:
+
+=over 4
+
+=item connect
+
+Supervises the driver bootstrap when calling
+
+ DBI->connect( "dbi:Foo", , , { ... } );
+
+First it instantiates a new driver using C<DBI::_new_dbh>. After that,
+initial bootstrap of the newly instantiated driver is done by
+
+ $dbh->func( 0, "init_default_attributes" );
+
+The first argument (C<0>) signals that this is the very first call to
+C<init_default_attributes>. Modern drivers understand that and do early
+stage setup here after calling
+
+ package DBD::Foo::db;
+ our @DBD::Foo::db::ISA = qw(DBI::DBD::SqlEngine::db);
+
+ sub init_default_attributes
+ {
+ my ($dbh, $phase) = @_;
+ $dbh->SUPER::init_default_attributes($phase);
+ ...; # own setup code, maybe separated by phases
+ }
+
+When the C<$phase> argument is passed down until
+C<DBI::DBD::SqlEngine::db::init_default_attributes>, C<connect()> recognizes
+a I<modern> driver and initializes the attributes from I<DSN> and I<$attr>
+arguments passed via C<< DBI->connect( $dsn, $user, $pass, \%attr ) >>.
+
+At the end of the attribute initialization after I<phase 0>, C<connect()>
+invoked C<init_default_attributes> again for I<phase 1>:
+
+ $dbh->func( 1, "init_default_attributes" );
+
+=item data_sources
+
+Returns a list of I<DSN>'s using the C<data_sources> method of the
+class specified in C<< $dbh->{sql_table_source} >> or via C<\%attr>:
+
+ @ary = DBI->data_sources($driver);
+ @ary = DBI->data_sources($driver, \%attr);
+
+=item disconnect_all
+
+C<DBI::DBD::SqlEngine> doesn't have an overall driver cache, so nothing
+happens here at all.
+
+=back
+
=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:
+=head3 Methods provided by C<< DBI::DBD::SqlEngine::db >>:
=over 4
@@ -193,6 +303,17 @@
C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor
recommended to override this method.
+=item validate_FETCH_attr
+
+Called by C<FETCH> to allow inherited drivers do their own attribute
+name validation. Calling convention is similar to C<FETCH> and the
+return value is the approved attribute name.
+
+ return $validated_attribute_name;
+
+In case of validation fails (e.g. accessing private attribute or similar),
+C<validate_FETCH_attr> is permitted to throw an exception.
+
=item FETCH
Fetches an attribute of a DBI database object. Private handle attributes
@@ -208,6 +329,22 @@
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 validate_STORE_attr
+
+Called by C<STORE> to allow inherited drivers do their own attribute
+name validation. Calling convention is similar to C<STORE> and the
+return value is the approved attribute name followed by the approved
+new value.
+
+ return ($validated_attribute_name, $validated_attribute_value);
+
+In case of validation fails (e.g. accessing private attribute or similar),
+C<validate_STORE_attr> is permitted to throw an exception
+(C<DBI::DBD::SqlEngine::db::validate_STORE_attr> throws an exception when
+someone tries to assign value other than C<SQL_IC_UPPER .. SQL_IC_MIXED>
+to C<< $dbh->{sql_identifier_case} >> or
+C<< $dbh->{sql_quoted_identifier_case} >>).
+
=item STORE
Stores a database private attribute. Private handle attributes must have a
@@ -247,12 +384,18 @@
=item init_default_attributes
This method is called after the database handle is instantiated to
-initialize the default attributes.
+initialize the default attributes. It expects one argument: C<$phase>.
+If C<$phase> is not given, C<connect> of C<DBI::DBD::SqlEngine::dr>
+expects this is an old-fashioned driver which isn't capable of multi-phased
+initialization.
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.
+C<sql_handler>, C<sql_init_order>, C<sql_meta>, C<sql_engine_version>,
+C<sql_nano_version> and C<sql_statement_version> when L<SQL::Statement>
+is available.
+
+It sets C<sql_init_order> to the given C<$phase>.
When the derived implementor class provides the attribute to validate
attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute
@@ -321,14 +464,105 @@
=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.
+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.
+DBI::DBD::SqlEngine is typically a driver which commits every action
+instantly when executed.
+
+=back
+
+=head3 Attributes used by C<< DBI::DBD::SqlEngine::db >>:
+
+This section describes attributes which are important to developers of DBI
+Database Drivers derived from C<DBI::DBD::SqlEngine>.
+
+=over 4
+
+=item sql_init_order
+
+This attribute contains a hash with priorities as key and an array
+containing the C<$dbh> attributes to be initialized during before/after
+other attributes.
+
+C<DBI::DBD::SqlEngine> initializes following attributes:
+
+ $dbh->{sql_init_order} = {
+ 0 => [qw( Profile RaiseError PrintError AutoCommit )],
+ 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ]
+ }
+
+The default priority of not listed attribute keys is C<50>. It is well
+known that a lot of attributes needed to be set before some table settings
+are initialized. For example, for L<DBD::DBM>, when using
+
+ my $dbh = DBI->connect( "dbi:DBM:", undef, undef, {
+ f_dir => "/path/to/dbm/databases",
+ dbm_type => "BerkeleyDB",
+ dbm_mldbm => "JSON", # use MLDBM::Serializer::JSON
+ dbm_tables => {
+ quick => {
+ dbm_type => "GDBM_File",
+ dbm_MLDBM => "FreezeThaw"
+ }
+ }
+ });
+
+This defines a known table C<quick> which uses the L<GDBM_File> backend and
+L<FreezeThaw> as serializer instead of the overall default L<BerkeleyDB> and
+L<JSON>. B<But> all files containing the table data have to be searched in
+C<< $dbh->{f_dir} >>, which requires C<< $dbh->{f_dir} >> must be initialized
+before C<< $dbh->{sql_meta}->{quick} >> is initialized by
+C<bootstrap_table_meta> method of L</DBI::DBD::SqlEngine::Table> to get
+C<< $dbh->{sql_meta}->{quick}->{f_dir} >> being initialized properly.
+
+=item sql_init_phase
+
+This attribute is only set during the initialization steps of the DBI
+Database Driver. It contains the value of the currently run initialization
+phase. Currently supported phases are I<phase 0> and I<phase 1>. This
+attribute is set in C<init_default_attributes> and removed in C<init_done>.
+
+=item sql_engine_in_gofer
+
+This value has a true value in case of this driver is operated via
+L<DBD::Gofer>. The impact of being operated via Gofer is a read-only
+driver (not read-only databases!), so you cannot modify any attributes
+later - neither any table settings. B<But> you won't get an error in
+cases you modify table attributes, so please carefully watch
+C<sql_engine_in_gofer>.
+
+=item sql_table_source
+
+Names a class which is responsible for delivering I<data sources> and
+I<available tables> (Database Driver related). I<data sources> here
+refers to L<DBI/data_sources>, not C<sql_data_source>.
+
+See L</DBI::DBD::SqlEngine::TableSource> for details.
+
+=item sql_data_source
+
+Name a class which is responsible for handling table resources open
+and completing table names requested via SQL statements.
+
+See L</DBI::DBD::SqlEngine::DataSource> for details.
+
+=item 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).
=back
@@ -387,6 +621,102 @@
=back
+=head2 DBI::DBD::SqlEngine::TableSource
+
+Provides data sources and table information on database driver and database
+handle level.
+
+ package DBI::DBD::SqlEngine::TableSource;
+
+ sub data_sources ($;$)
+ {
+ my ( $class, $drh, $attrs ) = @_;
+ ...
+ }
+
+ sub avail_tables
+ {
+ my ( $class, $drh ) = @_;
+ ...
+ }
+
+The C<data_sources> method is called when the user invokes any of the
+following:
+
+ @ary = DBI->data_sources($driver);
+ @ary = DBI->data_sources($driver, \%attr);
+
+ @ary = $dbh->data_sources();
+ @ary = $dbh->data_sources(\%attr);
+
+The C<avail_tables> method is called when the user invokes any of the
+following:
+
+ @names = $dbh->tables( $catalog, $schema, $table, $type );
+
+ $sth = $dbh->table_info( $catalog, $schema, $table, $type );
+ $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr );
+
+ $dbh->func( "list_tables" );
+
+Every time where an C<\%attr> argument can be specified, this C<\%attr>
+object's C<sql_table_source> attribute is preferred over the C<$dbh>
+attribute or the driver default.
+
+=head2 DBI::DBD::SqlEngine::DataSource
+
+Provides base functionality for dealing with tables. It is primarily
+designed for allowing transparent access to files on disk or already
+opened (file-)streams (e.g. for DBD::CSV).
+
+Derived classes shall be restricted to similar functionality, too (e.g.
+opening streams from an archive, transparently compress/uncompress
+log files before parsing them,
+
+ package DBI::DBD::SqlEngine::DataSource;
+
+ sub complete_table_name ($$;$)
+ {
+ my ( $self, $meta, $table, $respect_case ) = @_;
+ ...
+ }
+
+The method C<complete_table_name> is called when first setting up the
+I<meta information> for a table:
+
+ "SELECT user.id, user.name, user.shell FROM user WHERE ..."
+
+results in opening the table C<user>. First step of the table open
+process is completing the name. Let's imagine you're having a L<DBD::CSV>
+handle with following settings:
+
+ $dbh->{sql_identifier_case} = SQL_IC_LOWER;
+ $dbh->{f_ext} = '.lst';
+ $dbh->{f_dir} = '/data/web/adrmgr';
+
+Those settings will result in looking for files matching
+C<[Uu][Ss][Ee][Rr](\.lst)?$> in C</data/web/adrmgr/>. The scanning of the
+directory C</data/web/adrmgr/> and the pattern match check will be done
+in C<DBD::File::DataSource::File> by the C<complete_table_name> method.
+
+If you intend to provide other sources of data streams than files, in
+addition to provide an appropriate C<complete_table_name> method, a method
+to open the resource is required:
+
+ package DBI::DBD::SqlEngine::DataSource;
+
+ sub open_data ($)
+ {
+ my ( $self, $meta, $attrs, $flags ) = @_;
+ ...
+ }
+
+After the method C<open_data> has been run successfully, the table's meta
+information are in a state which allows the table's data accessor methods
+will be able to fetch/store row information. Implementation details heavily
+depends on the table implementation, whereby the most famous is surely
+L<DBD::File/DBD::File::Table|DBD::File::Table>.
+
=head2 DBI::DBD::SqlEngine::Statement
Derives from DBI::SQL::Nano::Statement for unified naming when deriving
@@ -395,13 +725,112 @@
=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.
+new drivers.
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.
+=over 4
+
+=item bootstrap_table_meta
+
+Initializes a table meta structure. Can be safely overridden in a
+derived class, as long as the C<< SUPER >> method is called at the end
+of the overridden method.
+
+It copies the following attributes from the database into the table meta data
+C<< $dbh->{ReadOnly} >> into C<< $meta->{readonly} >>, C<sql_identifier_case>
+and C<sql_data_source> and makes them sticky to the table.
+
+This method should be called before you attempt to map between file
+name and table name to ensure the correct directory, extension etc. are
+used.
+
+=item init_table_meta
+
+Initializes more attributes of the table meta data - usually more
+expensive ones (e.g. those which require class instantiations) - when
+the file name and the table name could mapped.
+
+=item get_table_meta
+
+Returns the table meta data. If there are none for the required table,
+a new one is initialized. When after bootstrapping a new I<table_meta>
+and L</DBI::DBD::SqlEngine::DataSource|completing the table name> a
+mapping can be established between an existing I<table_meta> and the
+new bootstrapped one, the already existing is used and a mapping
+shortcut between the recent used table name and the already known
+table name is hold in C<< $dbh->{sql_meta_map} >>. When it fails,
+nothing is returned. On success, the name of the table and the meta data
+structure is returned.
+
+=item get_table_meta_attr
+
+Returns a single attribute from the table meta data. If the attribute
+name appears in C<%compat_map>, the attribute name is updated from
+there.
+
+=item set_table_meta_attr
+
+Sets a single attribute in the table meta data. If the attribute
+name appears in C<%compat_map>, the attribute name is updated from
+there.
+
+=item table_meta_attr_changed
+
+Called when an attribute of the meta data is modified.
+
+If the modified attribute requires to reset a calculated attribute, the
+calculated attribute is reset (deleted from meta data structure) and
+the I<initialized> flag is removed, too. The decision is made based on
+C<%register_reset_on_modify>.
+
+=item register_reset_on_modify
+
+Allows C<set_table_meta_attr> to reset meta attributes when special
+attributes are modified. For DBD::File, modifying one of C<f_file>, C<f_dir>,
+C<f_ext> or C<f_lockfile> will reset C<f_fqfn>. DBD::DBM extends the
+list for C<dbm_type> and C<dbm_mldbm> to reset the value of C<dbm_tietype>.
+
+If your DBD has calculated values in the meta data area, then call
+C<register_reset_on_modify>:
+
+ my %reset_on_modify = ( "xxx_foo" => "xxx_bar" );
+ __PACKAGE__->register_reset_on_modify( \%reset_on_modify );
+
+=item register_compat_map
+
+Allows C<get_table_meta_attr> and C<set_table_meta_attr> to update the
+attribute name to the current favored one:
+
+ # from DBD::DBM
+ my %compat_map = ( "dbm_ext" => "f_ext" );
+ __PACKAGE__->register_compat_map( \%compat_map );
+
+=item open_data
+
+Called to open the table's data storage. This is silently forwarded
+to C<< $meta->{sql_data_source}->open_data() >>.
+
+After this is done, a derived class might add more steps in an overridden
+C<< open_file >> method.
+
+=item new
+
+Instantiates the table. This is done in 3 steps:
+
+ 1. get the table meta data
+ 2. open the data file
+ 3. bless the table data structure using inherited constructor new
+
+It is not recommended to override the constructor of the table class.
+Find a reasonable place to add you extensions in one of the above four
+methods.
+
+=back
+
=head1 AUTHOR
The module DBI::DBD::SqlEngine is currently maintained by
Modified: dbi/trunk/lib/DBI/DBD/SqlEngine/HowTo.pod
==============================================================================
--- dbi/trunk/lib/DBI/DBD/SqlEngine/HowTo.pod (original)
+++ dbi/trunk/lib/DBI/DBD/SqlEngine/HowTo.pod Fri Dec 21 09:11:32 2012
@@ -179,6 +179,110 @@
still can't do anything. It can do less than nothing - meanwhile it's
not a stupid storage area anymore.
+=head2 User comfort
+
+C<DBI::DBD::SqlEngine> since C<0.05> consolidates all persistent meta data
+of a table into a single structure stored in C<< $dbh->{sql_meta} >>. While
+DBI::DBD::SqlEngine provides only readonly access to this structure,
+modifications are still allowed.
+
+Primarily DBI::DBD::SqlEngine provides access via the setters
+C<get_sql_engine_meta>, C<get_single_table_meta>, C<set_single_table_meta>,
+C<set_sql_engine_meta> and C<clear_sql_engine_meta>. Those methods are
+easily accessible by the users via the C<< $dbh->func () >> interface
+provided by DBI. Well, many users don't feel comfortize when calling
+
+ # don't require extension for tables cars
+ $dbh->func ("cars", "f_ext", ".csv", "set_sql_engine_meta");
+
+DBI::DBD::SqlEngine will inject a method into your driver to increase the
+user comfort to allow:
+
+ # don't require extension for tables cars
+ $dbh->foo_set_meta ("cars", "f_ext", ".csv");
+
+Better, but here and there users likes to do:
+
+ # don't require extension for tables cars
+ $dbh->{foo_tables}->{cars}->{f_ext} = ".csv";
+
+This interface is provided when derived DBD's define following in
+C<init_valid_attributes> (re-capture L</Deal with own attributes>):
+
+ 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
+ foo_meta => 1, # contains the public interface to modify table meta attributes
+ };
+ $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
+ foo_meta => 1, # ensure public interface to modify table meta attributes are immutable
+ };
+
+ $dbh->{foo_meta} = "foo_tables";
+
+ return $dbh;
+ }
+
+This provides a tied hash in C<< $dbh->{foo_tables} >> and a tied hash for
+each table's meta data in C<< $dbh->{foo_tables}->{$table_name} >>.
+Modifications on the table meta attributes are done using the table
+methods:
+
+ sub get_table_meta_attr { ... }
+ sub set_table_meta_attr { ... }
+
+Both methods can adjust the attribute name for compatibility reasons, e.g.
+when former versions of the DBD allowed different names to be used for the
+same flag:
+
+ my %compat_map = (
+ abc => 'foo_abc',
+ xyz => 'foo_xyz',
+ );
+ __PACKAGE__->register_compat_map( \%compat_map );
+
+If any user modification on a meta attribute needs reinitialization of
+the meta structure (in case of C<DBI::DBD::SqlEngine> these are the attributes
+C<f_file>, C<f_dir>, C<f_ext> and C<f_lockfile>), inform DBI::DBD::SqlEngine by
+doing
+
+ my %reset_on_modify = (
+ foo_xyz => "foo_bar",
+ foo_abc => "foo_bar",
+ );
+ __PACKAGE__->register_reset_on_modify( \%reset_on_modify );
+
+The next access to the table meta data will force DBI::DBD::SqlEngine to re-do the
+entire meta initialization process.
+
+Any further action which needs to be taken can handled in
+C<table_meta_attr_changed>:
+
+ sub table_meta_attr_changed
+ {
+ my ($class, $meta, $attrib, $value) = @_;
+ ...
+ $class->SUPER::table_meta_attr_changed ($meta, $attrib, $value);
+ }
+
+This is done before the new value is set in C<$meta>, so the attribute
+changed handler can act depending on the old value.
+
=head2 Dealing with Tables
Let's put some life into it - it's going to be time for it.
@@ -188,6 +292,10 @@
SQL::Statement::Embed regarding embedding in own DBD's works pretty
fine with SQL::Statement and DBI::SQL::Nano.
+Second look should go to L<DBI::DBD::SqlEngine::Developers> to get a
+picture over the driver part of the table API. Usually there isn't much
+to do for an easy driver.
+
=head2 Testing
Now you should have your first own DBD. Was easy, wasn't it? But does
Modified: dbi/trunk/lib/DBI/SQL/Nano.pm
==============================================================================
--- dbi/trunk/lib/DBI/SQL/Nano.pm (original)
+++ dbi/trunk/lib/DBI/SQL/Nano.pm Fri Dec 21 09:11:32 2012
@@ -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.28' } )
+ if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.400' } )
{
@DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
@DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_);
@@ -695,15 +695,8 @@
{
return $self->{"params"}->[$val_num];
}
- if (wantarray)
- {
- return @{ $self->{"params"} };
- }
- else
- {
- return scalar @{ $self->{"params"} };
- }
+ return wantarray ? @{ $self->{"params"} } : scalar @{ $self->{"params"} };
}
sub open_tables
Modified: dbi/trunk/t/49dbd_file.t
==============================================================================
--- dbi/trunk/t/49dbd_file.t (original)
+++ dbi/trunk/t/49dbd_file.t Fri Dec 21 09:11:32 2012
@@ -99,7 +99,7 @@
my @tfhl;
# Now test some basic SQL statements
-my $tbl_file = File::Spec->catfile (Cwd::abs_path( $dir ), "$tbl.txt");
+my $tbl_file = File::Spec->catfile (Cwd::abs_path ($dir), "$tbl.txt");
ok ($dbh->do ("create table $tbl (txt varchar (20))"), "Create table $tbl") or diag $dbh->errstr;
ok (-f $tbl_file, "Test table exists");
@@ -122,6 +122,13 @@
my @layer = grep { $_ eq "encoding($encoding)" } @tfhl;
is (scalar @layer, 1, "encoding shows in layer");
+my @tables = sort $dbh->func ("list_tables");
+is_deeply (\@tables, [sort "000_just_testing", $tbl], "Listing tables gives test table");
+
+ok ($sth = $dbh->table_info (), "table_info");
+@tables = sort { $a->[2] cmp $b->[2] } @{$sth->fetchall_arrayref};
+is_deeply (\@tables, [ map { [ undef, undef, $_, 'TABLE', 'FILE' ] } sort "000_just_testing", $tbl ], "table_info gives test table");
+
SKIP: {
$using_dbd_gofer and skip "modifying meta data doesn't work with Gofer-AutoProxy", 4;
ok ($dbh->f_set_meta ($tbl, "f_dir", $dir), "set single meta datum");
@@ -135,20 +142,70 @@
SKIP: {
$using_dbd_gofer and skip "method intrusion didn't work with proxying", 1;
ok ($sth->execute, "execute on $tbl");
- $dbh->errstr and diag;
+ $dbh->errstr and diag $dbh->errstr;
}
-my $uctbl = uc($tbl);
+my $uctbl = uc ($tbl);
ok ($sth = $dbh->prepare ("select * from $uctbl"), "Prepare select * from $uctbl");
$rowidx = 0;
SKIP: {
$using_dbd_gofer and skip "method intrusion didn't work with proxying", 1;
ok ($sth->execute, "execute on $uctbl");
- $dbh->errstr and diag;
+ $dbh->errstr and diag $dbh->errstr;
}
+# ==================== ReadOnly tests =============================
+ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
+ f_ext => ".txt",
+ f_dir => $dir,
+ f_schema => undef,
+ f_encoding => $encoding,
+ f_lock => 0,
+
+ sql_meta => {
+ $tbl => {
+ col_names => [qw(txt)],
+ }
+ },
+
+ RaiseError => 0,
+ PrintError => 0,
+ ReadOnly => 1,
+ }), "ReadOnly connect with driver attributes in hash");
+
+ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl");
+$rowidx = 0;
+SKIP: {
+ $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1;
+ ok ($sth->execute, "execute on $tbl");
+ $dbh->errstr and diag $dbh->errstr;
+ }
+
+ok ($sth = $dbh->prepare ("insert into $tbl (txt) values (?)"), "prepare 'insert into $tbl'");
+is ($sth->execute ("Perl rules"), undef, "insert failed intensionally");
+
+ok ($sth = $dbh->prepare ("delete from $tbl"), "prepare 'delete from $tbl'");
+is ($sth->execute (), undef, "delete failed intensionally");
+
+is ($dbh->do ("drop table $tbl"), undef, "table drop failed intensionally");
+is (-f $tbl_file, 1, "Test table not removed");
+
+# ==================== ReadWrite again tests ======================
+ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
+ f_ext => ".txt",
+ f_dir => $dir,
+ f_schema => undef,
+ f_encoding => $encoding,
+ f_lock => 0,
+
+ RaiseError => 0,
+ PrintError => 0,
+ }), "ReadWrite for drop connect with driver attributes in hash");
+
+# XXX add a truncate test
+
ok ($dbh->do ("drop table $tbl"), "table drop");
-is (-s "$tbl.txt", undef, "Test table removed");
+is (-s $tbl_file, undef, "Test table removed"); # -s => size test
done_testing ();
Modified: dbi/trunk/t/50dbm_simple.t
==============================================================================
--- dbi/trunk/t/50dbm_simple.t (original)
+++ dbi/trunk/t/50dbm_simple.t Fri Dec 21 09:11:32 2012
@@ -175,7 +175,7 @@
# (This test script doesn't test that locking actually works anyway.)
# use f_lockfile in next release - use it here as test case only
- my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;dbm_lockfile=.lck";
+ my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;f_lockfile=.lck";
if ($using_dbd_gofer) {
$dsn .= ";f_dir=$dir";
@@ -258,6 +258,12 @@
is( $sth->rows, scalar( @{$expected_rows} ), $sql );
is_deeply( $allrows, $expected_rows, 'SELECT results' );
}
+
+ my $sth = $dbh->table_info();
+ ok ($sth, "prepare table_info (without tables)");
+ my @tables = $sth->fetchall_arrayref;
+ is_deeply( \@tables, [ [] ], "No tables delivered by table_info" );
+
$dbh->disconnect;
return 1;
}
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Fri Dec 21 09:11:32 2012
@@ -50,7 +50,7 @@
my @remote_dsns = DBI->data_sources( "dbi:DBM:", {
dbm_type => $opt_dbm,
- f_lockfile => 0,
+ f_lock => 0,
f_dir => test_dir() } );
my $remote_dsn = $remote_dsns[0];
( my $remote_driver_dsn = $remote_dsn ) =~ s/dbi:dbm://i;
@@ -215,8 +215,9 @@
# tests go_request_count, caching, and skip_default_methods policy
my $use_remote = ($policy->skip_default_methods) ? 0 : 1;
+ $use_remote = 1; # XXX since DBI::DBD::SqlEngine::db implements own data_sources this is always done remotely
note sprintf "use_remote=%s (policy=%s, transport=%s) %s",
- $use_remote, $policy_name, $transport, $dbh->{dbi_default_methods}||'';
+ $use_remote, $policy_name, $transport, DBI::neat($dbh->{dbi_default_methods})||'';
SKIP: {
skip "skip_default_methods checking doesn't work with Gofer over Gofer", 3
-
[svn:dbi] r15542 - in dbi/trunk: . lib/DBD lib/DBD/File lib/DBI/DBD lib/DBI/DBD/SqlEngine lib/DBI/SQL t
by REHSACK