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