Author: REHSACK
Date: Mon May 17 04:13:51 2010
New Revision: 13992
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
Log:
- move file2table to DBD::File::db - allow override in subclasses
- refactor DBD::File::Statement::get_file_name into *::get_table_meta
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Mon May 17 04:13:51 2010
@@ -76,7 +76,7 @@
# my $this = DBI::_new_dbh($drh, {
# Name => $dbname,
# });
- my $this = $drh->DBD::File::dr::connect ($dbname, $user, $auth, $attr);
+ my $this = $drh->SUPER::connect( $dbname, $user, $auth, $attr );
$this->STORE( 'Active', 1 );
return $this;
@@ -108,9 +108,9 @@
# use DBD::File's STORE unless its one of our own attributes
#
- if( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
+ if ( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
{
- $attrib = "dbm_" . $attrib; # backward compatibility - would like to
carp here
+ $attrib = "dbm_" . $attrib; # backward compatibility - would like
to carp here
}
return $dbh->SUPER::STORE( $attrib, $value ) unless ( 0 == index( $attrib,
'dbm_' ) );
@@ -140,9 +140,9 @@
{
my ( $dbh, $attrib ) = @_;
- if( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
+ if ( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
{
- $attrib = "dbm_" . $attrib; # backward compatibility - would like to
carp here
+ $attrib = "dbm_" . $attrib; # backward compatibility - would like
to carp here
}
return $dbh->SUPER::FETCH($attrib) unless ( 0 == index( $attrib, 'dbm_' )
);
@@ -186,16 +186,16 @@
# see the STORE methods below for how to check these attrs
#
$sth->{dbm_valid_attrs} = {
- dbm_tables => 1, # per-table
information
- dbm_type => 1, # the global DBM
type e.g. SDBM_File
- dbm_mldbm => 1, # the global MLDBM
serializer
- dbm_cols => 1, # the global
column names
- dbm_version => 1, # verbose DBD::DBM
version
- dbm_ext => 1, # file extension
- dbm_lockfile => 1, # lockfile
extension
- dbm_store_metadata => 1, # column names,
etc.
- dbm_berkeley_flags => 1, # for BerkeleyDB
- };
+ dbm_tables => 1, # per-table
information
+ dbm_type => 1, # the global DBM
type e.g. SDBM_File
+ dbm_mldbm => 1, # the global MLDBM
serializer
+ dbm_cols => 1, # the global
column names
+ dbm_version => 1, # verbose DBD::DBM
version
+ dbm_ext => 1, # file extension
+ dbm_lockfile => 1, # lockfile
extension
+ dbm_store_metadata => 1, # column names,
etc.
+ dbm_berkeley_flags => 1, # for BerkeleyDB
+ };
return $sth->SUPER::init_valid_attributes();
}
@@ -272,6 +272,14 @@
my $HAS_FLOCK = eval { flock STDOUT, 0; 1 };
+sub get_table_meta ($$$)
+{
+ my ( $self, $data, $table ) = @_;
+ ( $table, my $meta ) = $self->SUPER::get_table_meta( $data, $table );
+
+ return ( $table, $meta );
+}
+
# you must define open_table;
# it is done at the start of all executes;
# it doesn't necessarily have to "open" anything;
@@ -288,9 +296,9 @@
my ( $self, $data, $table, $createMode, $lockMode ) = @_;
my $dbh = $data->{Database};
- my $tname = $table || $self->{tables}->[0]->{name};
- my $file;
- ( $table, $file ) = $self->get_file_name( $data, $tname );
+ my ( $file, $meta );
+ ( $table, $meta ) = $self->get_table_meta( $data, $table );
+ $file = $meta->{f_fqfn};
# note the use of three levels of attribute settings below
# first it looks for a per-table setting
@@ -300,23 +308,23 @@
# your DBD may not need this, globals and defaults may be enough
#
my $dbm_type =
- $dbh->{dbm_tables}->{$tname}->{type}
+ $dbh->{dbm_tables}->{$table}->{type}
|| $dbh->{dbm_type}
|| 'SDBM_File';
- $dbh->{dbm_tables}->{$tname}->{type} = $dbm_type;
+ $dbh->{dbm_tables}->{$table}->{type} = $dbm_type;
my $serializer =
- $dbh->{dbm_tables}->{$tname}->{mldbm}
+ $dbh->{dbm_tables}->{$table}->{mldbm}
|| $dbh->{dbm_mldbm}
|| '';
- $dbh->{dbm_tables}->{$tname}->{mldbm} = $serializer if $serializer;
+ $dbh->{dbm_tables}->{$table}->{mldbm} = $serializer if $serializer;
my $ext = '' if ( $dbm_type eq 'GDBM_File' or $dbm_type eq 'DB_File' or
$dbm_type eq 'BerkeleyDB' );
# XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley
# behind the scenes and so create a single .db file.
$ext = '.pag' if ( $dbm_type eq 'NDBM_File' or $dbm_type eq 'SDBM_File' or
$dbm_type eq 'ODBM_File' );
$ext = $dbh->{dbm_ext} if ( defined $dbh->{dbm_ext} );
- $ext = $dbh->{dbm_tables}->{$tname}->{ext} if ( defined
$dbh->{dbm_tables}->{$tname}->{ext} );
+ $ext = $dbh->{dbm_tables}->{$table}->{ext} if ( defined
$dbh->{dbm_tables}->{$table}->{ext} );
$ext = '' unless ( defined $ext );
my $open_mode = O_RDONLY;
@@ -349,7 +357,7 @@
# LOCKING
#
my ( $nolock, $lockext, $lock_table );
- $lockext = $dbh->{dbm_tables}->{$tname}->{lockfile};
+ $lockext = $dbh->{dbm_tables}->{$table}->{lockfile};
$lockext = $dbh->{dbm_lockfile} if !defined $lockext;
if ( ( defined $lockext and $lockext == 0 ) or !$HAS_FLOCK )
{
@@ -370,51 +378,51 @@
my %h;
if ( $self->{command} ne 'DROP' )
{
- # TIEING
- #
- # allow users to pass in a pre-created tied object
- #
- my @tie_args;
- if ( $dbm_type eq 'BerkeleyDB' )
- {
- my $DB_CREATE = 1; # but import constants if supplied
- my $DB_RDONLY = 16; #
- my %flags;
- if ( my $f = $dbh->{dbm_berkeley_flags} )
- {
- $DB_CREATE = $f->{DB_CREATE} if ( $f->{DB_CREATE} );
- $DB_RDONLY = $f->{DB_RDONLY} if ( $f->{DB_RDONLY} );
- delete $f->{DB_CREATE};
- delete $f->{DB_RDONLY};
- %flags = %$f;
- }
- $flags{'-Flags'} = $DB_RDONLY;
- $flags{'-Flags'} = $DB_CREATE if ( $lockMode or $createMode );
- my $t = 'BerkeleyDB::Hash';
- $t = 'MLDBM' if ($serializer);
- @tie_args = (
- $t,
- -Filename => $file,
- %flags
- );
- }
- else
- {
- @tie_args = ( $tie_type, $file, $open_mode, 0666 );
- }
+ # TIEING
+ #
+ # allow users to pass in a pre-created tied object
+ #
+ my @tie_args;
+ if ( $dbm_type eq 'BerkeleyDB' )
+ {
+ my $DB_CREATE = 1; # but import constants if supplied
+ my $DB_RDONLY = 16; #
+ my %flags;
+ if ( my $f = $dbh->{dbm_berkeley_flags} )
+ {
+ $DB_CREATE = $f->{DB_CREATE} if ( $f->{DB_CREATE} );
+ $DB_RDONLY = $f->{DB_RDONLY} if ( $f->{DB_RDONLY} );
+ delete $f->{DB_CREATE};
+ delete $f->{DB_RDONLY};
+ %flags = %$f;
+ }
+ $flags{'-Flags'} = $DB_RDONLY;
+ $flags{'-Flags'} = $DB_CREATE if ( $lockMode or $createMode );
+ my $t = 'BerkeleyDB::Hash';
+ $t = 'MLDBM' if ($serializer);
+ @tie_args = (
+ $t,
+ -Filename => $file,
+ %flags
+ );
+ }
+ else
+ {
+ @tie_args = ( $tie_type, $file, $open_mode, 0666 );
+ }
my $tie_class = shift @tie_args;
eval { tie %h, $tie_class, @tie_args };
croak "Cannot tie(%h $tie_class @tie_args): $@" if ($@);
}
- my $store = $dbh->{dbm_tables}->{$tname}->{store_metadata};
+ my $store = $dbh->{dbm_tables}->{$table}->{store_metadata};
$store = $dbh->{dbm_store_metadata} unless ( defined $store );
$store = 1 unless ( defined $store );
- $dbh->{dbm_tables}->{$tname}->{store_metadata} = $store;
+ $dbh->{dbm_tables}->{$table}->{store_metadata} = $store;
my $tbl = {
- table_name => $tname,
+ table_name => $table,
file => $file,
ext => $ext,
hash => \%h,
@@ -424,36 +432,36 @@
lock_fh => $lock_table->{fh},
lock_ext => $lockext,
nolock => $nolock,
- col_names => [],
- col_nums => {},
+ col_names => [],
+ col_nums => {},
};
# COLUMN NAMES
#
- unless( $createMode )
+ unless ($createMode)
{
- my ( $meta_data, $schema, $col_names );
- $meta_data = $col_names = $h{"_metadata \0"} if $store;
- if ( $meta_data and $meta_data =~
m~<dbd_metadata>(.+)</dbd_metadata>~is )
- {
- $schema = $col_names = $1;
- $schema =~ s~.*<schema>(.+)</schema>.*~$1~is;
- $col_names =~ s~.*<col_names>(.+)</col_names>.*~$1~is;
- }
- $col_names ||=
- $dbh->{dbm_tables}->{$tname}->{c_cols}
- || $dbh->{dbm_tables}->{$tname}->{cols}
- || $dbh->{dbm_cols}
- || [ 'k', 'v' ];
- $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' );
- $dbh->{dbm_tables}->{$tname}->{cols} = $col_names;
- $dbh->{dbm_tables}->{$tname}->{schema} = $schema;
+ my ( $meta_data, $schema, $col_names );
+ $meta_data = $col_names = $h{"_metadata \0"} if $store;
+ if ( $meta_data and $meta_data =~
m~<dbd_metadata>(.+)</dbd_metadata>~is )
+ {
+ $schema = $col_names = $1;
+ $schema =~ s~.*<schema>(.+)</schema>.*~$1~is;
+ $col_names =~ s~.*<col_names>(.+)</col_names>.*~$1~is;
+ }
+ $col_names ||=
+ $dbh->{dbm_tables}->{$table}->{c_cols}
+ || $dbh->{dbm_tables}->{$table}->{cols}
+ || $dbh->{dbm_cols}
+ || [ 'k', 'v' ];
+ $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY'
);
+ $dbh->{dbm_tables}->{$table}->{cols} = $col_names;
+ $dbh->{dbm_tables}->{$table}->{schema} = $schema;
- my $i;
- my %col_nums = map { $_ => $i++ } @$col_names;
+ my $i;
+ my %col_nums = map { $_ => $i++ } @$col_names;
- $tbl->{col_nums} = \%col_nums;
- $tbl->{col_names} = $col_names;
+ $tbl->{col_nums} = \%col_nums;
+ $tbl->{col_names} = $col_names;
}
my $class = ref($self);
@@ -503,8 +511,8 @@
my ( $key, $val ) = @ary;
unless ($key)
{
- delete $self->{row};
- return;
+ delete $self->{row};
+ return;
}
my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val );
$self->{row} = @row ? \...@row : undef;
@@ -573,7 +581,7 @@
{
my ( $self, $data, $aryref ) = @_;
my $key = shift @$aryref;
- return unless(defined $key);
+ return unless ( defined $key );
my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref];
$self->{hash}->{$key} = $self->{mldbm} ? $row : $row->[0];
}
@@ -581,10 +589,10 @@
sub update_specific_row ($$$$)
{
my ( $self, $data, $aryref, $origary ) = @_;
- my $key = shift @$origary;
+ my $key = shift @$origary;
my $newkey = shift @$aryref;
- return unless(defined $key);
- delete $self->{hash}->{$key} unless( $key eq $newkey );
+ return unless ( defined $key );
+ delete $self->{hash}->{$key} unless ( $key eq $newkey );
my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref];
$self->{hash}->{$newkey} = $self->{mldbm} ? $row : $row->[0];
}
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Mon May 17 04:13:51 2010
@@ -74,50 +74,6 @@
undef $drh;
} # CLONE
-sub file2table
-{
- my ($data, $dir, $file, $file_is_tab, $quoted) = @_;
-
- $file eq "." || $file eq ".." and return;
-
- my ($ext, $req) = ("", 0);
- if ($data->{f_ext}) {
- ($ext, my $opt) = split m/\//, $data->{f_ext};
- if ($ext && $opt) {
- $opt =~ m/r/i and $req = 1;
- }
- }
-
- (my $tbl = $file) =~ s/$ext$//i;
- $file_is_tab and $file = "$tbl$ext";
-
- # Fully Qualified File Name
- my $fqfn;
- unless ($quoted) { # table names are case insensitive in SQL
- opendir my $dh, $dir or croak "Can't open '$dir': $!";
- my @f = grep { lc $_ eq lc $file } readdir $dh;
- @f == 1 and $file = $f[0];
- closedir $dh or croak "Can't close '$dir': $!";
- }
- $fqfn = File::Spec->catfile ($dir, $file);
-
- $file = $fqfn;
- if ($ext) {
- if ($req) {
- # 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;
- }
- }
-
- $data->{f_map}{$tbl} = $fqfn;
- return $tbl;
- } # file2table
-
# ====== DRIVER
================================================================
package DBD::File::dr;
@@ -240,7 +196,7 @@
if ( $dbh->{sql_handler} eq "SQL::Statement" and
$dbh->{sql_statement_version} > 1) {
my $parser = $dbh->{csv_sql_parser_object};
- $parser ||= eval { $dbh->func ("csv_cache_sql_parser_object") };
+ $parser ||= eval { $dbh->func ("cache_sql_parser_object") };
if ($@) {
$stmt = eval { $class->new ($statement) };
}
@@ -300,7 +256,7 @@
return $sth;
} # init_valid_attributes
-sub csv_cache_sql_parser_object
+sub cache_sql_parser_object
{
my $dbh = shift;
my $parser = {
@@ -313,7 +269,7 @@
$parser = SQL::Parser->new ($parser->{dialect}, $parser);
$dbh->{csv_sql_parser_object} = $parser;
return $parser;
- } # csv_cache_sql_parser_object
+ } # cache_sql_parser_object
sub disconnect ($)
{
@@ -385,6 +341,50 @@
undef $dbh->{csv_sql_parser_object};
} # DESTROY
+sub file2table
+{
+ my ($dbh, $dir, $file, $file_is_tab, $quoted) = @_;
+
+ $file eq "." || $file eq ".." and return;
+
+ my ($ext, $req) = ("", 0);
+ if ($dbh->{f_ext}) {
+ ($ext, my $opt) = split m/\//, $dbh->{f_ext};
+ if ($ext && $opt) {
+ $opt =~ m/r/i and $req = 1;
+ }
+ }
+
+ (my $tbl = $file) =~ s/$ext$//i;
+ $file_is_tab and $file = "$tbl$ext";
+
+ # Fully Qualified File Name
+ my $fqfn;
+ unless ($quoted) { # table names are case insensitive in SQL
+ opendir my $dh, $dir or croak "Can't open '$dir': $!";
+ my @f = grep { lc $_ eq lc $file } readdir $dh;
+ @f == 1 and $file = $f[0];
+ closedir $dh or croak "Can't close '$dir': $!";
+ }
+ $fqfn = File::Spec->catfile ($dir, $file);
+
+ $file = $fqfn;
+ if ($ext) {
+ if ($req) {
+ # 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;
+ }
+ }
+
+ $dbh->{f_meta}{$tbl} = { f_fqfn => $fqfn, f_fqbn => $file, };
+ return $tbl;
+ } # file2table
+
sub type_info_all ($)
{
[ { TYPE_NAME => 0,
@@ -446,7 +446,7 @@
? $dbh->{f_schema} : undef
: eval { getpwuid ((stat $dir)[4]) };
while (defined ($file = readdir ($dirh))) {
- my $tbl = DBD::File::file2table ($dbh, $dir, $file, 0, 0) or next;
+ my $tbl = $dbh->func ($dir, $file, 0, 0, 'file2table') or next;
push @tables, [ undef, $schema, $tbl, "TABLE", undef ];
}
unless (closedir $dirh) {
@@ -695,30 +695,37 @@
quotemeta (File::Spec->updir ()),
quotemeta (File::Spec->rootdir ());
-sub get_file_name ($$$)
+sub get_table_meta ($$$)
{
my ($self, $data, $table) = @_;
my $quoted = 0;
$table =~ s/^\"// and $quoted = 1; # handle quoted identifiers
$table =~ s/\"$//;
my $file = $table;
+ my $meta;
if ( $file !~ m/^$open_table_re/o
and $file !~ m{^[/\\]} # root
and $file !~ m{^[a-z]\:} # drive letter
) {
- exists $data->{Database}{f_map}{$table} or
- DBD::File::file2table ($data->{Database},
- $data->{Database}{f_dir}, $file, 1, $quoted);
- $file = $data->{Database}{f_map}{$table} || undef;
+ my $dbh = $data->{Database};
+ exists $dbh->{f_meta}->{$table} or
+ $dbh->func ($dbh->{f_dir}, $file, 1,
+ $quoted, 'file2table');
+ $meta = $dbh->{f_meta}->{$table} || {};
}
- return ($table, $file);
- } # get_file_name
+ else {
+ $meta = { f_fqfn => $file, f_fqbn => $file, };
+ }
+
+ return ($table, $meta);
+ } # get_table_meta
sub open_table ($$$$$)
{
my ($self, $data, $table, $createMode, $lockMode) = @_;
- my $file;
- ($table, $file) = $self->get_file_name ($data, $table);
+ my $meta;
+ ($table, $meta) = $self->get_table_meta ($data, $table);
+ my $file = $meta->{f_fqfn};
defined $file && $file ne "" or croak "No filename given";
require IO::File;
my $fh;
