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;
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.