Author: REHSACK
Date: Sun May 9 23:48:58 2010
New Revision: 13968
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
Log:
- Fix some issues when SQL::Statement is used as engine
- improve subclassing for DBD::File (from POV of DBD::DBM)
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Sun May 9 23:48:58 2010
@@ -76,62 +76,8 @@
# my $this = DBI::_new_dbh($drh, {
# Name => $dbname,
# });
- my $this = $drh->SUPER::connect( $dbname, $user, $auth, $attr );
+ my $this = $drh->DBD::File::dr::connect ($dbname, $user, $auth, $attr);
- # parse the connection string for name=value pairs
- if ($this)
- {
- # define valid private attributes
- #
- # attempts to set non-valid attrs in connect() or
- # with $dbh->{attr} will throw errors
- #
- # the attrs here *must* start with dbm_ or foo_
- #
- # see the STORE methods below for how to check these attrs
- #
- $this->{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
- };
-
- my ( $var, $val );
- $this->{f_dir} = $DBD::File::haveFileSpec ? File::Spec->curdir() : '.';
- while ( length($dbname) )
- {
- if ( $dbname =~ s/^((?:[^\\;]|\\.)*?);//s )
- {
- $var = $1;
- }
- else
- {
- $var = $dbname;
- $dbname = '';
- }
- if ( $var =~ /^(.+?)=(.*)/s )
- {
- $var = $1;
- ( $val = $2 ) =~ s/\\(.)/$1/g;
-
- # in the connect string the attr names
- # can either have dbm_ (or foo_) prepended or not
- # this will add the prefix if it's missing
- #
- $var = 'dbm_' . $var unless ( $var =~ /^dbm_/ or $var eq
'f_dir' );
- # XXX should pass back to DBI via $attr for connect() to STORE
- $this->{$var} = $val;
- }
- }
- $this->{f_version} = $DBD::File::VERSION;
- $this->{dbm_version} = $DBD::DBM::VERSION;
- }
$this->STORE( 'Active', 1 );
return $this;
}
@@ -162,7 +108,11 @@
# use DBD::File's STORE unless its one of our own attributes
#
- return $dbh->SUPER::STORE( $attrib, $value ) unless ( $attrib =~ /^dbm_/ );
+ if( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
+ {
+ $attrib = "dbm_" . $attrib; # backward compatibility - would like to
carp here
+ }
+ return $dbh->SUPER::STORE( $attrib, $value ) unless ( 0 == index( $attrib,
'dbm_' ) );
# throw an error if it has our prefix but isn't a valid attr name
#
@@ -190,7 +140,11 @@
{
my ( $dbh, $attrib ) = @_;
- return $dbh->SUPER::FETCH($attrib) unless $attrib =~ /^dbm_/;
+ if( ( $attrib eq lc($attrib) ) && ( -1 == index( $attrib, "_" ) ) )
+ {
+ $attrib = "dbm_" . $attrib; # backward compatibility - would like to
carp here
+ }
+ return $dbh->SUPER::FETCH($attrib) unless ( 0 == index( $attrib, 'dbm_' )
);
# throw an error if it has our prefix but isn't a valid attr name
#
@@ -211,6 +165,41 @@
}
}
+sub set_versions
+{
+ my $this = $_[0];
+ $this->{dbm_version} = $DBD::DBM::VERSION;
+ return $this->SUPER::set_versions();
+}
+
+sub init_valid_attributes
+{
+ my $sth = shift;
+
+ # define valid private attributes
+ #
+ # attempts to set non-valid attrs in connect() or
+ # with $dbh->{attr} will throw errors
+ #
+ # the attrs here *must* start with dbm_ or foo_
+ #
+ # 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
+ };
+
+ return $sth->SUPER::init_valid_attributes();
+}
+
# this is an example of a private method
# these used to be done with $dbh->func(...)
# see above in the driver() sub for how to install the method
@@ -378,41 +367,42 @@
$lock_table = $self->SUPER::open_table( $data, "$table$lockext",
$createMode, $lockMode );
}
- # 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 %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 );
+ }
+
my $tie_class = shift @tie_args;
eval { tie %h, $tie_class, @tie_args };
croak "Cannot tie(%h $tie_class @tie_args): $@" if ($@);
@@ -588,6 +578,17 @@
$self->{hash}->{$key} = $self->{mldbm} ? $row : $row->[0];
}
+sub update_specific_row ($$$$)
+{
+ my ( $self, $data, $aryref, $origary ) = @_;
+ my $key = shift @$origary;
+ my $newkey = shift @$aryref;
+ 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];
+}
+
# you may not need to explicitly DESTROY the ::Table
# put cleanup code to run when the execute is done
#
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Sun May 9 23:48:58 2010
@@ -34,7 +34,7 @@
use Carp;
use vars qw( @ISA $VERSION $drh $valid_attrs );
-$VERSION = "0.38";
+$VERSION = "0.39";
$drh = undef; # holds driver handle(s) once initialised
@@ -138,6 +138,8 @@
});
if ($this) {
+ # must be done first, because setting flags implicitely calls
$dbdname::st->STORE
+ $this->func ("init_valid_attributes");
my ($var, $val);
$this->{f_dir} = File::Spec->curdir ();
$this->{f_ext} = "";
@@ -156,38 +158,11 @@
$this->{$var} = $val;
}
}
- $this->{f_valid_attrs} = {
- f_version => 1, # DBD::File version
- f_dir => 1, # base directory
- f_ext => 1, # file extension
- f_schema => 1, # schema name
- f_tables => 1, # base directory
- f_lock => 1, # Table locking mode
- f_encoding => 1, # Encoding of the file
- };
- $this->{sql_valid_attrs} = {
- sql_handler => 1, # Nano or S:S
- sql_nano_version => 1, # Nano version
- sql_statement_version => 1, # S:S version
- };
}
$this->STORE (Active => 1);
- return set_versions ($this);
- } # connect
-
-sub set_versions
-{
- my $this = shift;
- $this->{f_version} = $DBD::File::VERSION;
- for (qw( nano_version statement_version )) {
- # strip development release version part
- ($this->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_} || "") =~
s/_[0-9]+$//;
- }
- $this->{sql_handler} = $this->{sql_statement_version}
- ? "SQL::Statement"
- : "DBI::SQL::Nano";
+ $this->func ('set_versions');
return $this;
- } # set_versions
+ } # connect
sub data_sources ($;$)
{
@@ -289,6 +264,42 @@
return $sth;
} # prepare
+sub set_versions
+{
+ my $this = shift;
+ $this->{f_version} = $DBD::File::VERSION;
+ for (qw( nano_version statement_version )) {
+ # strip development release version part
+ ($this->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_} || "") =~
s/_[0-9]+$//;
+ }
+ $this->{sql_handler} = $this->{sql_statement_version}
+ ? "SQL::Statement"
+ : "DBI::SQL::Nano";
+ return $this;
+ } # set_versions
+
+sub init_valid_attributes
+{
+ my $sth = shift;
+
+ $sth->{f_valid_attrs} = {
+ f_version => 1, # DBD::File version
+ f_dir => 1, # base directory
+ f_ext => 1, # file extension
+ f_schema => 1, # schema name
+ f_tables => 1, # base directory
+ f_lock => 1, # Table locking mode
+ f_encoding => 1, # Encoding of the file
+ };
+ $sth->{sql_valid_attrs} = {
+ sql_handler => 1, # Nano or S:S
+ sql_nano_version => 1, # Nano version
+ sql_statement_version => 1, # S:S version
+ };
+
+ return $sth;
+ } # init_valid_attributes
+
sub csv_cache_sql_parser_object
{
my $dbh = shift;
@@ -759,8 +770,7 @@
};
my $class = ref $self;
$class =~ s/::Statement/::Table/;
- bless $tbl, $class;
- return $tbl;
+ return $class->new ($tbl);
} # open_table
package DBD::File::Table;
