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