Author: REHSACK
Date: Fri May 21 11:58:07 2010
New Revision: 14002
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
Log:
Refactor DBD::File::Table and heavily use new attribute f_meta in $dbh
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Fri May 21 11:58:07 2010
@@ -25,7 +25,7 @@
use base qw( DBD::File );
use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed);
$VERSION = '0.05';
-$ATTRIBUTION = 'DBD::DBM by Jeff Zucker';
+$ATTRIBUTION = 'DBD::DBM by Jens Rehsack';
# no need to have driver() unless you need private methods
#
@@ -36,7 +36,7 @@
# do the real work in DBD::File
#
- $attr->{Attribution} = 'DBD::DBM by Jeff Zucker';
+ $attr->{Attribution} = 'DBD::DBM by Jens Rehsack';
my $this = $class->SUPER::driver($attr);
# install private methods
@@ -186,12 +186,10 @@
# 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
@@ -209,11 +207,11 @@
my $dbh = shift;
my $table = shift || '';
my $dtype =
- $dbh->{dbm_tables}->{$table}->{type}
+ $dbh->{f_meta}->{$table}->{dbm_type}
|| $dbh->{dbm_type}
|| 'SDBM_File';
my $mldbm =
- $dbh->{dbm_tables}->{$table}->{mldbm}
+ $dbh->{f_meta}->{$table}->{dbm_mldbm}
|| $dbh->{dbm_mldbm}
|| '';
$dtype .= ' + MLDBM + ' . $mldbm if ($mldbm);
@@ -252,9 +250,9 @@
my ( $sth, $tname ) = @_;
return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless
$tname;
return $sth->set_err( $DBI::stderr, "Unknown table '$tname'!" )
- unless ( $sth->{Database}->{dbm_tables}
- and $sth->{Database}->{dbm_tables}->{$tname} );
- return $sth->{Database}->{dbm_tables}->{$tname}->{schema};
+ unless ( $sth->{Database}->{f_meta}
+ and $sth->{Database}->{f_meta}->{$tname} );
+ return $sth->{Database}->{f_meta}->{$tname}->{schema};
}
# you could put some :st private methods here
@@ -265,231 +263,190 @@
############################
package DBD::DBM::Statement;
############################
-use base qw( DBD::File::Statement );
-use Carp qw(croak);
-use IO::File; # for locking only
-use Fcntl;
-my $HAS_FLOCK = eval { flock STDOUT, 0; 1 };
+...@dbd::DBM::Statement::ISA = qw(DBD::File::Statement);
-sub get_table_meta ($$$)
-{
- my ( $self, $data, $table ) = @_;
- ( $table, my $meta ) = $self->SUPER::get_table_meta( $data, $table );
+########################
+package DBD::DBM::Table;
+########################
+use Carp;
+use Fcntl;
- return ( $table, $meta );
-}
+...@dbd::DBM::Table::ISA = qw(DBD::File::Table);
-# you must define open_table;
-# it is done at the start of all executes;
-# it doesn't necessarily have to "open" anything;
-# you must define the $tbl and at least the col_names and col_nums;
-# anything else you put in depends on what you need in your
-# ::Table methods below; you must bless the $tbl into the
-# appropriate class as shown
-#
-# see also the comments inside open_table() showing the difference
-# between global, per-table, and default settings
-#
-sub open_table ($$$$$)
+sub file2table
{
- my ( $self, $data, $table, $createMode, $lockMode ) = @_;
- my $dbh = $data->{Database};
+ my ( $self, $meta, $file, $file_is_table, $quoted ) = @_;
- 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
- # if none is found, it looks for a global setting
- # if none is found, it sets a default
- #
- # your DBD may not need this, globals and defaults may be enough
- #
- my $dbm_type =
- $dbh->{dbm_tables}->{$table}->{type}
- || $dbh->{dbm_type}
- || 'SDBM_File';
- $dbh->{dbm_tables}->{$table}->{type} = $dbm_type;
+ my $tbl = $self->SUPER::file2table( $meta, $file, $file_is_table, $quoted
) or return;
- my $serializer =
- $dbh->{dbm_tables}->{$table}->{mldbm}
- || $dbh->{dbm_mldbm}
- || '';
- $dbh->{dbm_tables}->{$table}->{mldbm} = $serializer if $serializer;
+ $meta->{f_fqln} = $meta->{f_fqbn} . '.lck';
+ $meta->{f_dontopen} = 1;
- 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}->{$table}->{ext} if ( defined
$dbh->{dbm_tables}->{$table}->{ext} );
- $ext = '' unless ( defined $ext );
-
- my $open_mode = O_RDONLY;
- $open_mode = O_RDWR if ($lockMode);
- $open_mode = O_RDWR | O_CREAT | O_TRUNC if ($createMode);
+ return $tbl;
+}
- my ($tie_type);
+sub init_table_meta ($$$$$)
+{
+ my ( $self, $dbh, $table, $file_is_table, $quoted ) = @_;
+ defined $dbh->{f_meta}->{$table} and "HASH" eq ref
$dbh->{f_meta}->{$table} or
+ $dbh->{f_meta}->{$table} = {};
+ my $meta = $dbh->{f_meta}->{$table};
+
+ $meta->{dbm_type} ||= $dbh->{dbm_type} || 'SDBM_File';
+ $meta->{dbm_mldbm} ||= $dbh->{dbm_mldbm} if ( $dbh->{dbm_mldbm} );
+ $meta->{dbm_berkeley_flags} ||= $dbh->{dbm_berkeley_flags};
- if ($serializer)
+ unless ( defined( $meta->{f_ext} ) )
{
- require 'MLDBM.pm';
- $MLDBM::UseDB = $dbm_type;
- $MLDBM::UseDB = 'BerkeleyDB::Hash' if ( $dbm_type eq 'BerkeleyDB'
);
- $MLDBM::Serializer = $serializer;
- $tie_type = 'MLDBM';
+ my $ext;
+ if ( $meta->{dbm_type} eq 'SDBM_File' or $meta->{dbm_type} eq
'ODBM_File' )
+ {
+ $ext = '.pag/r';
+ }
+ elsif ( $meta->{dbm_type} eq 'NDBM_File' )
+ {
+ # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be
Berkeley
+ # behind the scenes and so create a single .db file.
+ if ( $^O =~ /bsd/i or lc($^O) eq 'darwin' )
+ {
+ $ext = '.db/r';
+ }
+ elsif ( $^O eq 'SunOS' or $^O eq 'Solaris' or $^O eq 'AIX' )
+ {
+ $ext = '.pag/r'; # here it's implemented like dbm - just a
bit improved
+ }
+ # else wrapped GDBM
+ }
+ $meta->{f_ext} = $ext if ( defined($ext) );
}
- else
+
+ unless ( defined( $meta->{dbm_tietype} ) )
{
- require "$dbm_type.pm";
- $tie_type = $dbm_type;
- }
+ my $tie_type = $meta->{dbm_type};
+ require "$tie_type.pm" unless ( $INC{"$tie_type.pm"} );
+ $tie_type = 'BerkeleyDB::Hash' if ( $tie_type eq 'BerkeleyDB' );
- # Second-guessing the file extension isn't great here (or in general)
- # could replace this by trying to open the file in non-create mode
- # first and dieing if that succeeds.
- # Currently this test doesn't work where NDBM is actually Berkeley (.db)
- croak "Cannot CREATE '$file$ext' because it already exists"
- if ( $createMode and ( -e "$file$ext" ) );
+ if ( $meta->{dbm_mldbm} )
+ {
+ require "MLDBM.pm" unless ( $INC{"MLDBM.pm"} );
+ $meta->{dbm_usedb} = $tie_type;
+ $tie_type = 'MLDBM';
+ }
- # LOCKING
- #
- my ( $nolock, $lockext, $lock_table );
- $lockext = $dbh->{dbm_tables}->{$table}->{lockfile};
- $lockext = $dbh->{dbm_lockfile} if !defined $lockext;
- if ( ( defined $lockext and $lockext == 0 ) or !$HAS_FLOCK )
- {
- undef $lockext;
- $nolock = 1;
+ $meta->{dbm_tietype} = $tie_type;
}
- else
+
+ unless ( defined( $meta->{dbm_store_metadata} ) )
{
- $lockext ||= '.lck';
+ my $store = $dbh->{dbm_store_metadata};
+ $store = 1 unless ( defined($store) );
+ $meta->{dbm_store_metadata} = $store;
}
- # open and flock the lockfile, creating it if necessary
- #
- if ( !$nolock )
+
+ unless ( defined( $meta->{col_names} ) )
{
- $lock_table = $self->SUPER::open_table( $data, "$table$lockext",
$createMode, $lockMode );
+ $meta->{col_names} = $dbh->{dbm_cols} if ( defined( $dbh->{dbm_cols} )
);
}
- my %h;
- if ( $self->{command} ne 'DROP' )
+ $self->SUPER::init_table_meta( $dbh, $table, $file_is_table, $quoted );
+}
+
+sub default_table_meta ($$$)
+{
+ my ( $self, $dbh, $table ) = @_;
+ my $meta = $self->SUPER::default_table_meta( $dbh, $table );
+
+ $meta->{dbm_type} = $dbh->{dbm_type} || 'SDBM_File';
+ $meta->{dbm_mldbm} = $dbh->{dbm_mldbm} if ( $dbh->{dbm_mldbm} );
+
+ return $meta;
+}
+
+sub open_file
+{
+ my ( $self, $meta, $attrs, $flags ) = @_;
+ $self->SUPER::open_file( $meta, $attrs, $flags );
+ unless ( $flags->{dropMode} )
{
# TIEING
#
- # allow users to pass in a pre-created tied object
+ # XXX allow users to pass in a pre-created tied object
#
my @tie_args;
- if ( $dbm_type eq 'BerkeleyDB' )
+ if ( $meta->{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} )
+ my %tie_flags;
+ if ( my $f = $meta->{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;
+ %tie_flags = %$f;
}
- $flags{'-Flags'} = $DB_RDONLY;
- $flags{'-Flags'} = $DB_CREATE if ( $lockMode or $createMode );
- my $t = 'BerkeleyDB::Hash';
- $t = 'MLDBM' if ($serializer);
+ $tie_flags{'-Flags'} = $DB_RDONLY;
+ $tie_flags{'-Flags'} = $DB_CREATE if ( $flags->{lockMode} or
$flags->{createMode} );
@tie_args = (
- $t,
- -Filename => $file,
- %flags
+ -Filename => $meta->{f_fqbn},
+ %tie_flags
);
}
else
{
- @tie_args = ( $tie_type, $file, $open_mode, 0666 );
+ my $open_mode = O_RDONLY;
+ $open_mode = O_RDWR if ( $flags->{lockMode} );
+ $open_mode = O_RDWR | O_CREAT | O_TRUNC if ( $flags->{createMode}
);
+
+ @tie_args = ( $meta->{f_fqbn}, $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 ($@);
- }
+ if ( $meta->{dbm_mldbm} )
+ {
+ $MLDBM::UseDB = $meta->{dbm_usedb};
+ $MLDBM::Serializer = $meta->{dbm_mldbm};
+ }
- my $store = $dbh->{dbm_tables}->{$table}->{store_metadata};
- $store = $dbh->{dbm_store_metadata} unless ( defined $store );
- $store = 1 unless ( defined $store );
- $dbh->{dbm_tables}->{$table}->{store_metadata} = $store;
-
- my $tbl = {
- table_name => $table,
- file => $file,
- ext => $ext,
- hash => \%h,
- dbm_type => $dbm_type,
- store_metadata => $store,
- mldbm => $serializer,
- lock_fh => $lock_table->{fh},
- lock_ext => $lockext,
- nolock => $nolock,
- col_names => [],
- col_nums => {},
- };
+ $meta->{hash} = {};
+ my $tie_class = $meta->{dbm_tietype};
+ eval { tie %{ $meta->{hash} }, $tie_class, @tie_args };
+ croak "Cannot tie(\%h $tie_class @tie_args): $@" if ($@);
+ }
- # COLUMN NAMES
- #
- unless ($createMode)
+ unless ( $flags->{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 )
+ if ( $meta->{dbm_store_metadata} )
{
- $schema = $col_names = $1;
- $schema =~ s~.*<schema>(.+)</schema>.*~$1~is;
- $col_names =~ s~.*<col_names>(.+)</col_names>.*~$1~is;
+ $meta_data = $col_names = $meta->{hash}->{"_metadata \0"};
+ 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 ||= $meta->{col_names} || [ '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;
+ $meta->{schema} = $schema;
- my $i;
- my %col_nums = map { $_ => $i++ } @$col_names;
-
- $tbl->{col_nums} = \%col_nums;
- $tbl->{col_names} = $col_names;
+ $meta->{col_names} = $col_names;
}
-
- my $class = ref($self);
- $class =~ s/::Statement/::Table/;
- bless( $tbl, $class );
- $tbl;
}
-########################
-package DBD::DBM::Table;
-########################
-use base qw( DBD::File::Table );
-
# you must define drop
# it is called from execute of a SQL DROP statement
#
sub drop ($$)
{
my ( $self, $data ) = @_;
- untie %{ $self->{hash} } if ( $self->{hash} );
- my $ext = $self->{ext};
- unlink $self->{file} . $ext if ( -f $self->{file} . $ext );
- unlink $self->{file} . '.dir' if ( -f $self->{file} . '.dir' and $ext eq
'.pag' );
- if ( !$self->{nolock} )
- {
- $self->{lock_fh}->close if ( $self->{lock_fh} );
- unlink $self->{file} . $self->{lock_ext} if ( -f $self->{file} .
$self->{lock_ext} );
- }
+ my $meta = $self->{meta};
+ untie %{ $meta->{hash} } if ( $meta->{hash} );
+ $self->SUPER::drop($data);
+ # XXX extra_files
+ unlink $meta->{f_fqbn} . '.dir' if ( -f $meta->{f_fqbn} . '.dir' and
$meta->{f_ext} eq '.pag/r' );
return 1;
}
@@ -503,10 +460,11 @@
sub fetch_row ($$$)
{
my ( $self, $data, $row ) = @_;
+ my $meta = $self->{meta};
# fetch with %each
#
- my @ary = each %{ $self->{hash} };
- @ary = each %{ $self->{hash} } if ( $self->{store_metadata} and $ary[0]
and $ary[0] eq "_metadata \0" );
+ my @ary = each %{ $meta->{hash} };
+ @ary = each %{ $meta->{hash} } if ( $meta->{dbm_store_metadata} and
$ary[0] and $ary[0] eq "_metadata \0" );
my ( $key, $val ) = @ary;
unless ($key)
@@ -525,14 +483,15 @@
sub push_row ($$$)
{
my ( $self, $data, $row_aryref ) = @_;
+ my $meta = $self->{meta};
my $key = shift @$row_aryref;
- if ( $self->{mldbm} )
+ if ( $meta->{dbm_mldbm} )
{
- $self->{hash}->{$key} = $row_aryref;
+ $meta->{hash}->{$key} = $row_aryref;
}
else
{
- $self->{hash}->{$key} = $row_aryref->[0];
+ $meta->{hash}->{$key} = $row_aryref->[0];
}
1;
}
@@ -543,14 +502,15 @@
sub push_names ($$$)
{
my ( $self, $data, $row_aryref ) = @_;
- $data->{Database}->{dbm_tables}->{ $self->{table_name} }->{c_cols} =
$row_aryref;
- return unless $self->{store_metadata};
+ my $meta = $self->{meta};
+ $meta->{col_names} = $row_aryref;
+ return unless $meta->{dbm_store_metadata};
my $stmt = $data->{f_stmt};
my $col_names = join( ',', @{$row_aryref} );
my $schema = $data->{Database}->{Statement};
$schema =~ s/^[^\(]+\((.+)\)$/$1/s;
$schema = $stmt->schema_str() if ( $stmt->can('schema_str') );
- $self->{hash}->{"_metadata \0"} =
+ $meta->{hash}->{"_metadata \0"} =
"<dbd_metadata>" . "<schema>$schema</schema>" .
"<col_names>$col_names</col_names>" . "</dbd_metadata>";
}
@@ -563,9 +523,10 @@
sub fetch_one_row ($$;$)
{
my ( $self, $key_only, $key ) = @_;
- return $self->{col_names}->[0] if ($key_only);
- return undef unless ( exists $self->{hash}->{$key} );
- my $val = $self->{hash}->{$key};
+ my $meta = $self->{meta};
+ return $meta->{col_names}->[0] if ($key_only);
+ return undef unless ( exists $meta->{hash}->{$key} );
+ my $val = $meta->{hash}->{$key};
$val = ( ref($val) eq 'ARRAY' ) ? $val : [$val];
my $row = [ $key, @$val ];
return wantarray ? @{$row} : $row;
@@ -574,27 +535,30 @@
sub delete_one_row ($$$)
{
my ( $self, $data, $aryref ) = @_;
- delete $self->{hash}->{ $aryref->[0] };
+ my $meta = $self->{meta};
+ delete $meta->{hash}->{ $aryref->[0] };
}
sub update_one_row ($$$)
{
my ( $self, $data, $aryref ) = @_;
+ my $meta = $self->{meta};
my $key = shift @$aryref;
return unless ( defined $key );
my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref];
- $self->{hash}->{$key} = $self->{mldbm} ? $row : $row->[0];
+ $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row : $row->[0];
}
sub update_specific_row ($$$$)
{
my ( $self, $data, $aryref, $origary ) = @_;
+ my $meta = $self->{meta};
my $key = shift @$origary;
my $newkey = shift @$aryref;
return unless ( defined $key );
- delete $self->{hash}->{$key} unless ( $key eq $newkey );
+ delete $meta->{hash}->{$key} unless ( $key eq $newkey );
my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref];
- $self->{hash}->{$newkey} = $self->{mldbm} ? $row : $row->[0];
+ $meta->{hash}->{$newkey} = $meta->{dbm_mldbm} ? $row : $row->[0];
}
# you may not need to explicitly DESTROY the ::Table
@@ -603,9 +567,10 @@
sub DESTROY ($)
{
my $self = shift;
- untie %{ $self->{hash} } if ( $self->{hash} );
- # release the flock on the lock file
- $self->{lock_fh}->close if ( !$self->{nolock} and $self->{lock_fh} );
+ my $meta = $self->{meta};
+ untie %{ $meta->{hash} } if ( $meta->{hash} );
+
+ $self->SUPER::DESTROY();
}
# truncate() and seek() must be defined to satisfy DBI::SQL::Nano
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Fri May 21 11:58:07 2010
@@ -341,50 +341,6 @@
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,
@@ -440,13 +396,17 @@
return;
}
+ my $class = $dbh->FETCH ("ImplementorClass");
+ $class =~ s/::db$/::Table/;
my ($file, @tables, %names);
my $schema = exists $dbh->{f_schema}
? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
? $dbh->{f_schema} : undef
- : eval { getpwuid ((stat $dir)[4]) };
+ : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
while (defined ($file = readdir ($dirh))) {
- my $tbl = $dbh->func ($dir, $file, 0, 0, "file2table") or next;
+ # XXX $dbh->{f_meta} or ...
+ my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or
next; # XXX
+ # XXX collect from $dbh->{f_meta}
push @tables, [ undef, $schema, $tbl, "TABLE", undef ];
}
unless (closedir $dirh) {
@@ -673,15 +633,13 @@
return $_[0]->{f_stmt}{NUM_OF_ROWS};
} # rows
+# ====== SQL::STATEMENT
========================================================
+
package DBD::File::Statement;
use strict;
use Carp;
-# We may have a working flock () built-in but that doesn't mean that locking
-# will work on NFS (flock () may hang hard)
-my $locking = eval { flock STDOUT, 0; 1 };
-
# Jochen's old check for flock ()
#
# my $locking = $^O ne "MacOS" &&
@@ -690,111 +648,245 @@
@DBD::File::Statement::ISA = qw( DBI::SQL::Nano::Statement );
+sub open_table ($$$$$)
+{
+ my ($self, $data, $table, $createMode, $lockMode) = @_;
+
+ my $class = ref $self;
+ $class =~ s/::Statement/::Table/;
+
+ my %flags = (createMode => $createMode,
+ lockMode => $lockMode);
+ $self->{command} eq 'DROP' and $flags{dropMode} = 1;
+
+ return $class->new ($data, {table => $table}, \%flags);
+ } # open_table
+
+# ====== SQL::TABLE
============================================================
+
+package DBD::File::Table;
+
+use strict;
+use Carp;
+require IO::File;
+
+# We may have a working flock () built-in but that doesn't mean that locking
+# will work on NFS (flock () may hang hard)
+my $locking = eval { flock STDOUT, 0; 1 };
+
+...@dbd::File::Table::ISA = qw(DBI::SQL::Nano::Table);
+
+# ====== FLYWEIGHT SUPPORT
=====================================================
+
+# Flyweight support for table_info
+# The functions file2table, init_table_meta, default_table_meta and
+# get_table_meta are using $self arguments for polymorphism only. The
+# must not rely on an instantiated DBD::File::Table
+sub file2table
+{
+ my ($self, $meta, $file, $file_is_table, $quoted) = @_;
+
+ $file eq "." || $file eq ".." and return;
+
+ my ($ext, $req) = ("", 0); # XXX
+ if ($meta->{f_ext}) {
+ ($ext, my $opt) = split m/\//, $meta->{f_ext};
+ if ($ext && $opt) {
+ $opt =~ m/r/i and $req = 1;
+ }
+ }
+
+ (my $tbl = $file) =~ s/$ext$//i;
+ $file_is_table and $file = "$tbl$ext";
+
+ # Fully Qualified File Name
+ unless ($quoted) { # table names are case insensitive in SQL
+ my $dir = $meta->{f_dir};
+ opendir my $dh, $dir or croak "Can't open '$dir': $!";
+ my @f = grep { lc $_ eq lc $file } readdir $dh;
+ @f == 1 and $tbl = $file = $f[0];
+ $tbl =~ s/$ext$//i; # XXX /i flag only when not quoted?
+ closedir $dh or croak "Can't close '$dir': $!";
+ }
+ my $fqfn = File::Spec->catfile ($meta->{f_dir}, $file);
+ my $fqbn = File::Spec->catfile ($meta->{f_dir}, $tbl);
+
+ $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;
+ }
+ }
+
+ $meta->{f_fqfn} = $fqfn;
+ $meta->{f_fqbn} = $file;
+ return $tbl;
+ } # file2table
+
my $open_table_re = sprintf "(?:%s|%s|%s)",
quotemeta (File::Spec->curdir ()),
quotemeta (File::Spec->updir ()),
quotemeta (File::Spec->rootdir ());
-sub get_table_meta ($$$)
+sub init_table_meta ($$$$$)
{
- my ($self, $data, $table) = @_;
- my $quoted = 0;
- $table =~ s/^\"// and $quoted = 1; # handle quoted identifiers
- $table =~ s/\"$//;
- my $file = $table;
+ my ($self, $dbh, $table, $file_is_table, $quoted) = @_;
+ defined $dbh->{f_meta}->{$table} and "HASH" eq ref
$dbh->{f_meta}->{$table} or
+ $dbh->{f_meta}->{$table} = {};
+ my $meta = $dbh->{f_meta}->{$table};
+ defined $meta->{f_dir} or
+ $meta->{f_dir} = $dbh->{f_dir};
+ defined $meta->{f_ext} or
+ $meta->{f_ext} = $dbh->{f_ext};
+ defined $meta->{f_encoding} or
+ $meta->{f_encoding} = $dbh->{f_encoding};
+ defined $meta->{f_lock} or
+ $meta->{f_lock} = $dbh->{f_lock};
+ defined $meta->{f_fqfn} or
+ $self->file2table ($meta, $table, $file_is_table, $quoted);
+ } # init_table_meta
+
+sub default_table_meta ($$$)
+{
+ my ($self, $dbh, $table) = @_;
+ my $meta = { f_fqfn => $table, f_fqbn => $table, };
+ return $meta;
+ } # init_table_meta
+
+sub get_table_meta ($$$$;$)
+{
+ my ($self, $dbh, $table, $file_is_table, $quoted) = @_;
+ unless( defined( $quoted ) ) {
+ $quoted = 0;
+ $table =~ s/^\"// and $quoted = 1; # handle quoted identifiers
+ $table =~ s/\"$//;
+ }
my $meta;
- if ( $file !~ m/^$open_table_re/o
- and $file !~ m{^[/\\]} # root
- and $file !~ m{^[a-z]\:} # drive letter
+ if ( $table !~ m/^$open_table_re/o
+ and $table !~ m{^[/\\]} # root
+ and $table !~ m{^[a-z]\:} # drive letter
) {
- my $dbh = $data->{Database};
- exists $dbh->{f_meta}->{$table} or
- $dbh->func ($dbh->{f_dir}, $file, 1,
- $quoted, "file2table");
- $meta = $dbh->{f_meta}->{$table} || {};
+ # should be done anyway, table_info might generate incomplete f_meta
+ $self->init_table_meta ($dbh, $table, $file_is_table, $quoted);
+ $meta = $dbh->{f_meta}->{$table};
}
else {
- $meta = { f_fqfn => $file, f_fqbn => $file, };
+ $meta = $self->default_table_meta ($dbh, $table);
}
return ($table, $meta);
} # get_table_meta
-sub open_table ($$$$$)
+# ====== FILE OPEN
=============================================================
+
+sub open_file ($$$)
{
- my ($self, $data, $table, $createMode, $lockMode) = @_;
- 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;
- my $safe_drop = $self->{ignore_missing_table} ? 1 : 0;
- if ($createMode) {
- -f $file and
- croak "Cannot create table $table: Already exists";
- $fh = IO::File->new ($file, "a+") or
- croak "Cannot open $file for writing: $!";
- $fh->seek (0, 0) or
- croak "Error while seeking back: $!";
- }
- else {
- unless ($fh = IO::File->new ($file, ($lockMode ? "r+" : "r"))) {
- $safe_drop or croak "Cannot open $file: $!";
+ my ($self, $meta, $attrs, $flags) = @_;
+
+ defined $meta->{f_fqfn} && $meta->{f_fqfn} ne "" or croak "No filename
given";
+
+ my ($fh, $fn);
+ unless ($meta->{f_dontopen}) {
+ $fn = $meta->{f_fqfn};
+ if ($flags->{createMode}) {
+ -f $meta->{f_fqfn} and
+ croak "Cannot create table $attrs->{table}: Already exists";
+ $fh = IO::File->new ($fn, "a+") or
+ croak "Cannot open $fn for writing: $!";
+ $fh->seek (0, 0) or
+ croak "Error while seeking back: $!";
}
+ else {
+ unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" :
"r"))) {
+ croak "Cannot open $fn: $!";
+ }
+ }
+
+ if ($fh) {
+ if (my $enc = $meta->{f_encoding}) {
+ binmode $fh, ":encoding($enc)" or
+ croak "Failed to set encoding layer '$enc' on $fn: $!";
+ }
+ else {
+ binmode $fh or croak "Failed to set binary mode on $fn: $!";
+ }
+ }
+
+ $meta->{fh} = $fh;
}
- if ($fh) {
- if (my $enc = $data->{Database}{f_encoding}) {
- binmode $fh, ":encoding($enc)" or
- croak "Failed to set encoding layer '$enc' on $file: $!";
+ if ($meta->{f_fqln}) {
+ $fn = $meta->{f_fqln};
+ if ($flags->{createMode}) {
+ -f $fn and
+ croak "Cannot create table lock for $attrs->{table}: Already
exists";
+ $fh = IO::File->new ($fn, "a+") or
+ croak "Cannot open $fn for writing: $!";
}
else {
- binmode $fh or croak "Failed to set binary mode on $file: $!";
+ unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" :
"r"))) {
+ croak "Cannot open $fn: $!";
+ }
}
+
+ $meta->{lockfh} = $fh;
}
+
if ($locking && $fh) {
- my $lm = defined $data->{Database}{f_lock}
- && $data->{Database}{f_lock} =~ m/^[012]$/
- ? $data->{Database}{f_lock}
- : $lockMode ? 2 : 1;
+ my $lm = defined $flags->{f_lock}
+ && $flags->{f_lock} =~ m/^[012]$/
+ ? $flags->{f_lock}
+ : $flags->{lockMode} ? 2 : 1;
if ($lm == 2) {
- flock $fh, 2 or croak "Cannot obtain exclusive lock on $file: $!";
+ flock $fh, 2 or croak "Cannot obtain exclusive lock on $fn: $!";
}
elsif ($lm == 1) {
- flock $fh, 1 or croak "Cannot obtain shared lock on $file: $!";
+ flock $fh, 1 or croak "Cannot obtain shared lock on $fn: $!";
}
# $lm = 0 is forced no locking at all
}
+ } # open_file
+
+# ====== SQL::Eval API
=========================================================
+
+sub new
+{
+ my ($className, $data, $attrs, $flags) = @_;
+ my $dbh = $data->{Database};
+
+ my $meta;
+ ($attrs->{table}, $meta) = $className->get_table_meta ($dbh,
$attrs->{table}, 1);
+
+ $className->open_file ($meta, $attrs, $flags);
+
my $columns = {};
my $array = [];
- my $pos = $fh ? $fh->tell () : undef;
my $tbl = {
- file => $file,
- fh => $fh,
- col_nums => $columns,
- col_names => $array,
- first_row_pos => $pos,
+ %{$attrs},
+ meta => $meta,
+ col_names => $meta->{col_names} || [],
};
- my $class = ref $self;
- $class =~ s/::Statement/::Table/;
- return $class->new ($tbl);
- } # open_table
-
-package DBD::File::Table;
-
-use strict;
-use Carp;
-
-...@dbd::File::Table::ISA = qw(DBI::SQL::Nano::Table);
+ return $className->SUPER::new ($tbl);
+ } # new
sub drop ($)
{
- my $self = shift;
+ my ($self, $data) = @_;
+ my $meta = $self->{meta};
# We have to close the file before unlinking it: Some OS'es will
# refuse the unlink otherwise.
- $self->{fh} and $self->{fh}->close ();
- undef $self->{fh};
- unlink $self->{file};
+ $meta->{fh} and $meta->{fh}->close ();
+ $meta->{lockfh} and $meta->{lockfh}->close ();
+ undef $meta->{fh};
+ undef $meta->{lockfh};
+ $meta->{f_fqfn} and unlink $meta->{f_fqfn};
+ $meta->{f_fqln} and unlink $meta->{f_fqln};
+ delete $data->{Database}->{f_meta}->{$self->{table}};
return 1;
} # drop
@@ -802,29 +894,32 @@
{
my ($self, $data, $pos, $whence) = @_;
if ($whence == 0 && $pos == 0) {
- $pos = $self->{first_row_pos};
+ $pos = defined $self->{first_row_pos} ? $self->{first_row_pos} : 0;
}
elsif ($whence != 2 || $pos != 0) {
croak "Illegal seek position: pos = $pos, whence = $whence";
}
- $self->{fh}->seek ($pos, $whence) or
- croak "Error while seeking in " . $self->{file} . ": $!";
+ $self->{meta}->{fh}->seek ($pos, $whence) or
+ croak "Error while seeking in " . $self->{meta}->{f_fqfn} . ": $!";
} # seek
sub truncate ($$)
{
my ($self, $data) = @_;
$self->{fh}->truncate ($self->{fh}->tell ()) or
- croak "Error while truncating " . $self->{file} . ": $!";
+ croak "Error while truncating " . $self->{meta}->{f_fqfn} . ": $!";
return 1;
} # truncate
sub DESTROY
{
my $self = shift;
- $self->{fh} and $self->{fh}->close ();
- undef $self->{fh};
+ my $meta = $self->{meta};
+ $meta->{fh} and $meta->{fh}->close ();
+ $meta->{lockfh} and $meta->{lockfh}->close ();
+ undef $meta->{fh};
+ undef $meta->{lockfh};
} # DESTROY
1;
