Author: REHSACK
Date: Fri Jun 4 04:12:18 2010
New Revision: 14096
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
Log:
- introduce general accessors to table meta information
(including some code injections into derived DBD's)
- allow extended initialization via DSN (for DBD::AnyData)
- fix issue described in RT59038
- fix meta guessing
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Fri Jun 4 04:12:18 2010
@@ -45,7 +45,7 @@
# but you can write private methods before official registration
# by hacking the $dbd_prefix_registry in a private copy of DBI.pm
#
- if ( $DBI::VERSION >= 1.37 and !$methods_already_installed++ )
+ unless ( $methods_already_installed++ )
{
DBD::DBM::db->install_method('dbm_versions');
DBD::DBM::st->install_method('dbm_schema');
@@ -215,35 +215,32 @@
#
sub dbm_versions
{
- my $dbh = shift;
- my $table = shift || '';
- my $dtype =
- $dbh->{f_meta}->{$table}->{dbm_type}
- || $dbh->{dbm_type}
- || 'SDBM_File';
- my $mldbm =
- $dbh->{f_meta}->{$table}->{dbm_mldbm}
- || $dbh->{dbm_mldbm}
- || '';
- $dtype .= ' + MLDBM + ' . $mldbm if ($mldbm);
-
- my %version = ( DBI => $DBI::VERSION );
- $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if ($DBI::PurePerl);
- $version{OS} = "$^O ($Config::Config{osvers})";
- $version{Perl} = "$] ($Config::Config{archname})";
- my $str = sprintf( "%-16s %s\n%-16s %s\n%-16s %s\n",
- 'DBD::DBM', $dbh->{Driver}->{Version} . " using $dtype",
- ' DBD::File', $dbh->{f_version},
- ' DBI::SQL::Nano',
- $dbh->{sql_nano_version} );
- $str .= sprintf( "%-16s %s\n", ' SQL::Statement', $dbh->{sql_statement_version} )
- if ( $dbh->{sql_handler} eq 'SQL::Statement' );
+ my $class = $_[0]->FETCH ("ImplementorClass");
+ my $get_versions = $class->can( 'get_versions' );
+ goto &$get_versions;
+}
- for ( sort keys %version )
- {
- $str .= sprintf( "%-16s %s\n", $_, $version{$_} );
- }
- return "$str\n";
+sub get_versions
+{
+ my ($dbh, $table) = @_;
+ $table ||= '';
+ my @versions = $dbh->SUPER::get_versions( $table );
+
+ # update first line (optical)
+ my $dbdfv = shift @versions;
+ my ($pkg, $info) = split( /\s+/, $dbdfv, 2 );
+ unshift (@versions, sprintf ("%-16s %s", ' ' . $pkg, $info ));
+
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ s/::db$/::Table/;
+ my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta or $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table );
+
+ my $dtype = $meta->{dbm_type};
+ $dtype .= ' + MLDBM + ' . $meta->{dbm_mldbm} if( $meta->{dbm_mldbm} );
+ unshift( @versions, sprintf( "%-16s %s using %s", 'DBD::DBM', $dbh->{dbm_version}, $dtype ) );
+
+ return wantarray ? @versions : join ("\n", @versions);
}
# you may need to over-ride some DBD::File::db methods here
@@ -1343,6 +1340,18 @@
them in Perl. Obviously, this can present dangers, so if you don't know
what's in a file, be careful before you access it with MLDBM turned on!
+This modules uses hash interfaces of two column file databases. While
+none of supported SQL engines have a support for indeces, following
+statements really do the same (even if they mean something completely
+different):
+
+ $sth->do( "insert into foo values (1, 'hello')" );
+
+ # this statement does ...
+ $sth->do( "update foo set v='world' where k=1" );
+ # ... the same as this statement
+ $sth->do( "insert into foo values (1, 'world')" );
+
See the entire section on L<Table locking and flock()> for gotchas and
warnings about the use of flock().
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Fri Jun 4 04:12:18 2010
@@ -31,12 +31,21 @@
use strict;
use Carp;
-use vars qw( @ISA $VERSION $drh $valid_attrs );
+use vars qw( @ISA $VERSION $drh );
$VERSION = "0.39";
$drh = undef; # holds driver handle(s) once initialized
+DBI->setup_driver ("DBD::File"); # only needed once but harmless to repeat
+
+my %accessors = (
+ versions => 'get_file_versions',
+ get_meta => 'get_file_meta',
+ set_meta => 'set_file_meta',
+ clear_meta => 'clear_file_meta',
+ );
+
sub driver ($;$)
{
my ($class, $attr) = @_;
@@ -50,7 +59,6 @@
# their own caching, so caching here just provides extra safety.
$drh->{$class} and return $drh->{$class};
- DBI->setup_driver ("DBD::File"); # only needed once but harmless to repeat
$attr ||= {};
{ no strict "refs";
unless ($attr->{Attribution}) {
@@ -65,6 +73,23 @@
$drh->{$class} = DBI::_new_drh ($class . "::dr", $attr);
$drh->{$class}->STORE (ShowErrorStatement => 1);
+
+ my $prefix = DBI->driver_prefix ($class);
+ my $dbclass = $class . "::db";
+ while (my ($accessor, $funcname) = each %accessors) {
+ my $method = $prefix . $accessor;
+ $dbclass->can ($method) and next;
+ my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname;
+sub %s::%s
+{
+ my $func = %s->can( '%s' );
+ goto &$func;
+ }
+EOI
+ eval $inject;
+ $dbclass->install_method ($method);
+ }
+
return $drh->{$class};
} # driver
@@ -95,10 +120,16 @@
if ($this) {
# must be done first, because setting flags implicitly calls $dbdname::st->STORE
$this->func ("init_valid_attributes");
+
+ #$this->{f_ext} = "";
+ $this->{f_dir} = File::Spec->curdir ();
+ $this->{f_meta} = {};
+ #$this->{f_map} = {};
+ $this->{f_meta_map} = {}; # choose new name because it contains other keys
+ $this->STORE (sql_identifier_case => 2); # SQL_IC_LOWER
+ $this->STORE (sql_quoted_identifier_case => 3); # SQL_IC_SENSITIVE
+
my ($var, $val);
- $this->{f_dir} = File::Spec->curdir ();
- $this->{f_ext} = "";
- $this->{f_map} = {};
while (length $dbname) {
if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) {
$var = $1;
@@ -112,12 +143,18 @@
($val = $2) =~ s/\\(.)/$1/g;
$this->{$var} = $val;
}
+ elsif ($var =~ m/^(.+?)=>(.*)/s) {
+ $var = $1;
+ ($val = $2) =~ s/\\(.)/$1/g;
+ my $ref = eval($val);
+ $this->$var ($ref);
+ }
}
+
+ $this->STORE (Active => 1);
+ $this->func ("set_versions");
}
- $this->STORE (Active => 1);
- $this->STORE (sql_identifier_case => 2); # SQL_IC_LOWER
- $this->STORE (sql_quoted_identifier_case => 3); # SQL_IC_SENSITIVE
- $this->func ("set_versions");
+
return $this;
} # connect
@@ -234,6 +271,7 @@
$this->{sql_handler} = $this->{sql_statement_version}
? "SQL::Statement"
: "DBI::SQL::Nano";
+
return $this;
} # set_versions
@@ -296,6 +334,7 @@
sub disconnect ($)
{
$_[0]->STORE (Active => 0);
+ $_[0]->STORE (f_meta => {});
return 1;
} # disconnect
@@ -374,11 +413,71 @@
return $dbh->SUPER::STORE ($attrib, $value);
} # STORE
+sub get_versions
+{
+ my $dbh = $_[0];
+ my %version;
+ $version{'DBD::File'} = $dbh->{f_version} . " using " . $dbh->{sql_handler} . " ";
+ $version{'DBD::File'} .= $dbh->{sql_handler} eq "SQL::Statement"
+ ? $dbh->{sql_statement_version}
+ : $dbh->{sql_nano_version};
+ $version{'DBI'} = $DBI::VERSION;
+ $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if ($DBI::PurePerl);
+ $version{OS} = "$^O ($Config::Config{osvers})";
+ $version{Perl} = "$] ($Config::Config{archname})";
+
+ my @versions;
+ foreach my $vk (sort keys %version) {
+ push (@versions, sprintf ("%-16s %s", $vk, $version{$vk} ));
+ }
+
+ return wantarray ? @versions : join ("\n", @versions);
+ } # get_file_versions
+
+sub get_file_meta
+{
+ my ($dbh, $table, $attr) = @_;
+
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ s/::db$/::Table/;
+ my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta or croak "No such table '$table'";
+
+ # prevent creation of undef attributes
+ exists $meta->{$attr} and return $meta->{$attr};
+ return;
+ } # get_file_meta
+
+sub set_file_meta
+{
+ my ($dbh, $table, $attr, $value) = @_;
+
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ s/::db$/::Table/;
+ my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
+ $meta or croak "No such table '$table'";
+
+ $meta->{$attr} = $value;
+ return;
+ } # set_file_meta
+
+sub clear_file_meta
+{
+ my ($dbh, $table, $attr, $value) = @_;
+
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ 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;
$dbh->SUPER::FETCH ("Active") and $dbh->disconnect ;
- undef $dbh->{csv_sql_parser_object};
+ undef $dbh->{sql_parser_object};
} # DESTROY
sub type_info_all ($)
@@ -744,7 +843,7 @@
# (my $tbl = $file) =~ s/$ext$//i;
my ($tbl, $dir, undef) = File::Basename::fileparse ($file, $ext);
- Cwd::abs_path ($dir) eq $meta->{f_dir} and
+ (Cwd::abs_path ($dir) eq $meta->{f_dir} or $dir eq "./") and
$dir = "";
!$respect_case and $meta->{sql_identifier_case} == 1 and # XXX SQL_IC_UPPER
$tbl = uc $tbl;
@@ -756,19 +855,35 @@
: File::Spec->catdir ($meta->{f_dir}, $dir);
# Fully Qualified File Name
- unless ($respect_case) { # table names are case insensitive in SQL
- opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!";
- my @f = grep { lc $_ eq lc $file } readdir $dh;
- @f == 1 and $file = $f[0];
- !$respect_case and $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
- ($tbl = $file) =~ s/$ext$//i;
- closedir $dh or croak "Can't close '$searchdir': $!";
+ my $cmpsub;
+ if ($respect_case) {
+ $cmpsub = sub {
+ my ( $fn, undef, $sfx ) = File::Basename::fileparse( $_, qr/\.[^.]*/ );
+ return ( lc $sfx eq lc $ext or (!$req and !$sfx) ) if $fn eq $tbl;
+ return 0;
+ }
}
+ else {
+ $cmpsub = sub {
+ my ( $fn, undef, $sfx ) = File::Basename::fileparse( $_, qr/\.[^.]*/ );
+ return ( lc $sfx eq lc $ext or (!$req and !$sfx) ) if lc $fn eq lc $tbl;
+ return 0;
+ }
+ }
+
+ opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!";
+ my @f = sort { length $b <=> length $a } ( grep { &$cmpsub($_) } readdir $dh );
+ @f > 0 and @f <= 2 and $file = $f[0];
+ !$respect_case and $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
+ ($tbl = $file) =~ s/$ext$//i;
+ closedir $dh or croak "Can't close '$searchdir': $!";
+
my $fqfn = Cwd::abs_path (File::Spec->catfile ($searchdir, $file));
my $fqbn = File::Spec->catfile ($searchdir, $tbl);
- (my $tdir = $dir) =~ s{^\./}{}; # We do not want all tables to start with ./
- $tdir and $tbl = File::Spec->catfile ($tdir, $tbl);
+ #(my $tdir = $dir) =~ s{^\./}{}; # XXX We do not want all tables to start with ./
+ #$tdir and $tbl = File::Spec->catfile ($tdir, $tbl);
+ $dir and $tbl = File::Spec->catfile ($dir, $tbl);
$file = $fqfn;
if ($ext) {
@@ -776,25 +891,24 @@
# File extension required
$file =~ s/$ext$//i or return;
}
- else {
- # File extension optional, skip if file with extension exists
- grep m/$ext$/i, glob "$fqfn.*" and return;
- $file =~ s/$ext$//i;
- }
+# else {
+# # File extension optional, skip if file with extension exists
+# grep m/$ext$/i, glob "$fqfn.*" and return;
+# $file =~ s/$ext$//i;
+# }
}
$meta->{f_fqfn} = $fqfn;
- $meta->{f_fqbn} = $file;
+ $meta->{f_fqbn} = $fqbn;
!defined $meta->{f_lockfile} && $meta->{f_lockfile} and
$meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile};
$meta->{table_name} = $tbl;
- $respect_case or $tbl = lc $tbl; # for internal storage
return $tbl;
} # file2table
-sub bootstrap_table_meta ($$$$$)
+sub bootstrap_table_meta
{
my ($self, $dbh, $meta, $table) = @_;
@@ -808,7 +922,7 @@
$meta->{sql_identifier_case} = $dbh->{sql_identifier_case};
} # bootstrap_table_meta
-sub init_table_meta ($$$$$)
+sub init_table_meta
{
my ($self, $dbh, $meta, $table) = @_;
@@ -824,15 +938,23 @@
$table =~ s/\"$//;
}
- my $meta = $dbh->{f_meta}{$table} || {};
+ 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}) {
- $table = $self->file2table ($meta, $table, $file_is_table, $respect_case);
- $table or return;
+ $self->file2table ($meta, $table, $file_is_table, $respect_case) or return;
+ }
+
+ if( defined $meta->{table_name} and $table ne $meta->{table_name} ) {
+ $dbh->{f_meta_map}{$table} = $meta->{table_name};
+ $table = $meta->{table_name};
}
+ # XXX check $dbh->{f_meta}{ $meta->{table_name} }
$self->init_table_meta ($dbh, $meta, $table);
$meta->{initialized} = 1;
$dbh->{f_meta}{$table} = $meta;
@@ -917,8 +1039,9 @@
my ($className, $data, $attrs, $flags) = @_;
my $dbh = $data->{Database};
- my $meta;
- ($attrs->{table}, $meta) = $className->get_table_meta ($dbh, $attrs->{table}, 1);
+ my ($tblnm, $meta) = $className->get_table_meta ($dbh, $attrs->{table}, 1) or
+ croak "Cannot find appropriate file for table '$attrs->{table}'";
+ $attrs->{table} = $tblnm;
$className->open_file ($meta, $attrs, $flags);
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.