DBD::File - Base class for writing file based DBI drivers

    Active
    ActiveKids
    CachedKids
    CompatMode             (Not used)
    InactiveDestroy
    AutoInactiveDestroy
    Kids
    PrintError
    RaiseError
    Warn                   (Not used)

  extension{/flag}

    DBI:CSV:f_dir=data;f_ext=.csv

    DBI:CSV:f_dir=data;f_ext=.csv/r

    my $dbh = DBI->connect ("dbi:CSV:", "", "", {
        f_schema => undef,
        f_dir    => "data",
        f_ext    => ".csv/r",
        }) or die $DBI::errstr;

    my @tables = $dbh->tables ();

    # no f_schema
    "merijn".foo
    "merijn".bar

    # f_schema => "dbi"
    "dbi".foo
    "dbi".bar

    # f_schema => undef
    foo
    bar

  0: No locking at all.

  1: Shared locks will be used.

  2: Exclusive locks will be used.

  $dbh = DBI->connect ("dbi:DBM:f_lockfile=.foo");
  $dbh->{f_lockfile} = ".foo";
  $dbh->{f_meta}{qux}{f_lockfile} = ".foo";

  $dbh = DBI->connect ("dbi:DBM:f_lockfile=0");
  $dbh->{f_lockfile} = 0;
  $dbh->{f_meta}{qux}{f_lockfile} = 0;

    SELECT * FROM tbl AS t1, tbl AS t2 WHERE t1.id = t2.id

    my ($drh)  = DBI->install_driver ("CSV");
    my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data");

    my ($dbh)  = DBI->connect ("dbi:CSV:f_dir=/usr/local/csv_data");
    my (@list) = $dbh->func ("list_tables");

    sub f_versions (;$)
    {
	my ($table_name) = @_;
	$table_name ||= ".";
	...
    }

    my $dbh = DBI->connect ("dbi:File:");
    my $f_versions = $dbh->f_versions ();
    print "$f_versions\n";
    __END__
    # DBD::File        0.39 using SQL::Statement 1.28
    # DBI              1.612
    # OS               netbsd (5.99.24)
    # Perl             5.010001 (x86_64-netbsd-thread-multi)

    sub f_get_meta ($$)
    {
	my ($table_name, $attrib) = @_;
	...
    }

    sub f_set_meta ($$$)
    {
	my ($table_name, $attrib, $value) = @_;
	...
    }

    sub f_clear_meta ($)
    {
	my ($table_name) = @_;
	...
    }

 Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack
 Copyright (C) 2004-2009 by Jeff Zucker
 Copyright (C) 1998-2004 by Jochen Wiedmann

# -*- perl -*-
#
#   DBD::File - A base class for implementing DBI drivers that
#               act on plain files
#
#  This module is currently maintained by
#
#      H.Merijn Brand & Jens Rehsack
#
#  The original author is Jochen Wiedmann.
#
#  Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack
#  Copyright (C) 2004 by Jeff Zucker
#  Copyright (C) 1998 by Jochen Wiedmann
#
#  All rights reserved.
#
#  You may distribute this module under the terms of either the GNU
#  General Public License or the Artistic License, as specified in
#  the Perl README file.

require 5.008;

use strict;
use warnings;

use DBI ();

package DBD::File;

use strict;
use warnings;

use base qw(DBI::DBD::SqlEngine);
use Carp;
use vars qw(@ISA $VERSION $drh);

$VERSION = "0.40";

$drh = undef;		# holds driver handle(s) once initialized

my %accessors = (
    get_meta   => "get_file_meta",
    set_meta   => "set_file_meta",
    clear_meta => "clear_file_meta",
    );

sub driver ($;$)
{
    my ($class, $attr) = @_;

    # Drivers typically use a singleton object for the $drh
    # We use a hash here to have one singleton per subclass.
    # (Otherwise DBD::CSV and DBD::DBM, for example, would
    # share the same driver object which would cause problems.)
    # An alternative would be not not cache the $drh here at all
    # and require that subclasses do that. Subclasses should do
    # their own caching, so caching here just provides extra safety.
    $drh->{$class} and return $drh->{$class};

    $attr ||= {};
    {	no strict "refs";
	unless ($attr->{Attribution}) {
	    $class eq "DBD::File" and
		$attr->{Attribution} = "$class by Jeff Zucker";
	    $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} ||
		"oops the author of $class forgot to define this";
	    }
	$attr->{Version} ||= ${$class . "::VERSION"};
	$attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://;
	}

    $drh->{$class} = $class->SUPER::driver ($attr);

    my $prefix = DBI->driver_prefix ($class);
    if ($prefix) {
	my $dbclass = $class . "::db";
	while (my ($accessor, $funcname) = each %accessors) {
	    my $method = $prefix . $accessor;
	    $dbclass->can ($method) and next;
	    my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname;
sub %s::%s
{
    my $func = %s->can (q{%s});
    goto &$func;
    }
EOI
	    eval $inject;
	    $dbclass->install_method ($method);
	    }
	}

    # XXX inject DBD::XXX::Statement unless exists

    return $drh->{$class};
    } # driver

sub CLONE
{
    undef $drh;
    } # CLONE

# ====== DRIVER ================================================================

package DBD::File::dr;

use strict;
use warnings;

use vars qw(@ISA $imp_data_size);

@DBD::File::dr::ISA           = qw(DBI::DBD::SqlEngine::dr);
$DBD::File::dr::imp_data_size = 0;

sub dsn_quote
{
    my $str = shift;
    ref     $str and return "";
    defined $str or  return "";
    $str =~ s/([;:])/\\$1/g;
    return $str;
    } # dsn_quote

sub data_sources ($;$)
{
    my ($drh, $attr) = @_;
    my $dir = $attr && exists $attr->{f_dir}
	? $attr->{f_dir}
	: File::Spec->curdir ();
    my %attrs;
    $attr and %attrs = %$attr;
    delete $attrs{f_dir};
    my $dsnextra = join ";", map { $_ . "=" . dsn_quote ($attrs{$_}) } keys %attrs;
    my ($dirh) = Symbol::gensym ();
    unless (opendir $dirh, $dir) {
	$drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
	return;
	}

    my ($file, @dsns, %names, $driver);
    $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";

    while (defined ($file = readdir ($dirh))) {
	my $d = File::Spec->catdir ($dir, $file);
	# allow current dir ... it can be a data_source too
	$file ne File::Spec->updir () && -d $d and
	    push @dsns, "DBI:$driver:f_dir=" . dsn_quote ($d) . ($dsnextra ? ";$dsnextra" : "");
	}
    return @dsns;
    } # data_sources

sub disconnect_all
{
    } # disconnect_all

sub DESTROY
{
    undef;
    } # DESTROY

# ====== DATABASE ==============================================================

package DBD::File::db;

use strict;
use warnings;

use vars qw(@ISA $imp_data_size);

use Carp;
require File::Spec;
require Cwd;
use Scalar::Util qw(refaddr); # in CORE since 5.7.3

@DBD::File::db::ISA           = qw(DBI::DBD::SqlEngine::db);
$DBD::File::db::imp_data_size = 0;

sub set_versions
{
    my $dbh = shift;
    $dbh->{f_version} = $DBD::File::VERSION;

    return $dbh->SUPER::set_versions ();
    } # set_versions

sub init_valid_attributes
{
    my $dbh = shift;

    $dbh->{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_meta           => 1, # meta data for tables
	f_meta_map       => 1, # mapping table for identifier case
	f_lock           => 1, # Table locking mode
	f_lockfile       => 1, # Table lockfile extension
	f_encoding       => 1, # Encoding of the file
	f_valid_attrs    => 1, # File valid attributes
	f_readonly_attrs => 1, # File readonly attributes
	};
    $dbh->{f_readonly_attrs} = {
	f_version        => 1, # DBD::File version
	f_valid_attrs    => 1, # File valid attributes
	f_readonly_attrs => 1, # File readonly attributes
	};

    return $dbh->SUPER::init_valid_attributes ();
    } # init_valid_attributes

sub init_default_attributes
{
    my ($dbh, $phase) = @_;

    # must be done first, because setting flags implicitly calls $dbdname::db->STORE
    $dbh->SUPER::init_default_attributes ($phase);

    # DBI::BD::SqlEngine::dr::connect will detect old-style drivers and
    # don't call twice
    unless (defined $phase) {
        # we have an "old" driver here
        $phase = defined $dbh->{sql_init_phase};
	$phase and $phase = $dbh->{sql_init_phase};
	}

    if (0 == $phase) {
	# check whether we're running in a Gofer server or not (see
	# validate_FETCH_attr for details)
	$dbh->{f_in_gofer} = (defined $INC{"DBD/Gofer.pm"} && (caller(5))[0] eq "DBI::Gofer::Execute");
	# f_ext should not be initialized
	# f_map is deprecated (but might return)
	$dbh->{f_dir}      = Cwd::abs_path (File::Spec->curdir ());
	$dbh->{f_meta}     = {};
	$dbh->{f_meta_map} = {}; # choose new name because it contains other keys

	# complete derived attributes, if required
	(my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
	my $drv_prefix = DBI->driver_prefix ($drv_class);
	my $valid_attrs = $drv_prefix . "valid_attrs";
	my $ro_attrs = $drv_prefix . "readonly_attrs";

	my @comp_attrs = ();
	if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{f_in_gofer}) {
	    my $attr = $dbh->{$drv_prefix . "meta"};
	    defined $attr and defined $dbh->{$valid_attrs} and
		!defined $dbh->{$valid_attrs}{$attr} and
		$dbh->{$valid_attrs}{$attr} = 1;

	    my %h;
	    tie %h, "DBD::File::TieTables", $dbh;
	    $dbh->{$attr} = \%h;

	    push @comp_attrs, "meta";
	    }

	foreach my $comp_attr (@comp_attrs) {
	    my $attr = $drv_prefix . $comp_attr;
	    defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and
		$dbh->{$valid_attrs}{$attr} = 1;
	    defined $dbh->{$ro_attrs} and !defined $dbh->{$ro_attrs}{$attr} and
		$dbh->{$ro_attrs}{$attr} = 1;
	    }
	}

    return $dbh;
    } # init_default_attributes

sub disconnect ($)
{
    %{$_[0]->{f_meta}} = ();
    return $_[0]->SUPER::disconnect ();
    } # disconnect

sub validate_FETCH_attr
{
    my ($dbh, $attrib) = @_;

    # If running in a Gofer server, access to our tied compatibility hash
    # would force Gofer to serialize the tieing object including it's
    # private $dbh reference used to do the driver function calls.
    # This will result in nasty exceptions. So return a copy of the
    # f_meta structure instead, which is the source of for the compatibility
    # tie-hash. It's not as good as liked, but the best we can do in this
    # situation.
    if ($dbh->{f_in_gofer}) {
	(my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
	my $drv_prefix = DBI->driver_prefix ($drv_class);
	exists $dbh->{$drv_prefix . "meta"} && $attrib eq $dbh->{$drv_prefix . "meta"} and
	    $attrib = "f_meta";
	}

    return $attrib;
    } # validate_FETCH_attr

sub validate_STORE_attr
{
    my ($dbh, $attrib, $value) = @_;

    if ($attrib eq "f_dir") {
	-d $value or
	    return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
	File::Spec->file_name_is_absolute ($value) or
	    $value = Cwd::abs_path ($value);
	}

    if ($attrib eq "f_ext") {
	$value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or
	    carp "'$value' doesn't look like a valid file extension attribute\n";
	}

    (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
    my $drv_prefix = DBI->driver_prefix ($drv_class);

    if (exists $dbh->{$drv_prefix . "meta"}) {
	my $attr = $dbh->{$drv_prefix . "meta"};
	if ($attrib eq $attr) {
	    while (my ($k, $v) = each %$value) {
		$dbh->{$attrib}{$k} = $v;
		}
	    }
	}

    return $dbh->SUPER::validate_STORE_attr ($attrib, $value);
    } # validate_STORE_attr

sub get_f_versions
{
    my ($dbh, $table) = @_;

    my $class = $dbh->{ImplementorClass};
    $class =~ s/::db$/::Table/;
    my (undef, $meta);
    $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
    unless ($meta) {
	$meta = {};
	$class->bootstrap_table_meta ($dbh, $meta, $table);
	}

    my $dver;
    my $dtype = "IO::File";
    eval {
	$dver = IO::File->VERSION ();

	# when we're still alive here, everthing went ok - no need to check for $@
	$dtype .= " ($dver)";
	};

    $meta->{f_encoding} and $dtype .= " + " . $meta->{f_encoding} . " encoding";

    return sprintf "%s using %s", $dbh->{f_version}, $dtype;
    } # get_f_versions

sub get_single_table_meta
{
    my ($dbh, $table, $attr) = @_;
    my $meta;

    $table eq "." and
	return $dbh->FETCH ($attr);

    (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
    (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
    $meta or croak "No such table '$table'";

    # prevent creation of undef attributes
    return $class->get_table_meta_attr ($meta, $attr);
    } # get_single_table_meta

sub get_file_meta
{
    my ($dbh, $table, $attr) = @_;

    my $gstm = $dbh->{ImplementorClass}->can ("get_single_table_meta");

    $table eq "*" and
	$table = [ ".", keys %{$dbh->{f_meta}} ];
    $table eq "+" and
	$table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ];
    ref $table eq "Regexp" and
	$table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ];

    ref $table || ref $attr or
	return &$gstm ($dbh, $table, $attr);

    ref $table or $table = [ $table ];
    ref $attr  or $attr  = [ $attr  ];
    "ARRAY" eq ref $table or
	croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table;
    "ARRAY" eq ref $attr or
	croak "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr;

    my %results;
    foreach my $tname (@{$table}) {
	my %tattrs;
	foreach my $aname (@{$attr}) {
	    $tattrs{$aname} = &$gstm ($dbh, $tname, $aname);
	    }
	$results{$tname} = \%tattrs;
	}

    return \%results;
    } # get_file_meta

sub set_single_table_meta
{
    my ($dbh, $table, $attr, $value) = @_;
    my $meta;

    $table eq "." and
	return $dbh->STORE ($attr, $value);

    (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
    (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
    $meta or croak "No such table '$table'";
    $class->set_table_meta_attr ($meta, $attr, $value);

    return $dbh;
    } # set_single_table_meta

sub set_file_meta
{
    my ($dbh, $table, $attr, $value) = @_;

    my $sstm = $dbh->{ImplementorClass}->can ("set_single_table_meta");

    $table eq "*" and
	$table = [ ".", keys %{$dbh->{f_meta}} ];
    $table eq "+" and
	$table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ];
    ref ($table) eq "Regexp" and
	$table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ];

    ref $table || ref $attr or
	return &$sstm ($dbh, $table, $attr, $value);

    ref $table or $table = [ $table ];
    ref $attr  or $attr  = { $attr => $value };
    "ARRAY" eq ref $table or
	croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table;
    "HASH" eq ref $attr or
	croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr;

    foreach my $tname (@{$table}) {
	my %tattrs;
	while (my ($aname, $aval) = each %$attr) {
	    &$sstm ($dbh, $tname, $aname, $aval);
	    }
	}

    return $dbh;
    } # set_file_meta

sub clear_file_meta
{
    my ($dbh, $table) = @_;

    (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
    my (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
    $meta and %{$meta} = ();

    return;
    } # clear_file_meta

sub get_avail_tables
{
    my $dbh = shift;

    my @tables = $dbh->SUPER::get_avail_tables ();
    my $dir    = $dbh->{f_dir};
    my $dirh   = Symbol::gensym ();

    unless (opendir $dirh, $dir) {
	$dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
	return @tables;
	}

    my $class = $dbh->FETCH ("ImplementorClass");
    $class =~ s/::db$/::Table/;
    my ($file, %names);
    my $schema = exists $dbh->{f_schema}
	? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
	    ? $dbh->{f_schema} : undef
	: eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
    my %seen;
    while (defined ($file = readdir ($dirh))) {
	my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX
	# $tbl && $meta && -f $meta->{f_fqfn} or next;
	$seen{defined $schema ? $schema : "\0"}{$tbl}++ or
	    push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ];
	}
    closedir $dirh or
	$dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");

    return @tables;
    } # get_avail_tables

# ====== Tie-Meta ==============================================================

package DBD::File::TieMeta;

use Carp qw(croak);
require Tie::Hash;
@DBD::File::TieMeta::ISA = qw(Tie::Hash);

sub TIEHASH
{
    my ($class, $tblClass, $tblMeta) = @_;

    my $self = bless ({ tblClass => $tblClass, tblMeta => $tblMeta, }, $class);
    return $self;
    } # new

sub STORE
{
    my ($self, $meta_attr, $meta_val) = @_;

    $self->{tblClass}->set_table_meta_attr ($self->{tblMeta}, $meta_attr, $meta_val);

    return;
    } # STORE

sub FETCH
{
    my ($self, $meta_attr) = @_;

    return $self->{tblClass}->get_table_meta_attr ($self->{tblMeta}, $meta_attr);
    } # FETCH

sub FIRSTKEY
{
    my $a = scalar keys %{$_[0]->{tblMeta}};
    each %{$_[0]->{tblMeta}};
    } # FIRSTKEY

sub NEXTKEY
{
    each %{$_[0]->{tblMeta}};
    } # NEXTKEY

sub EXISTS
{
    exists $_[0]->{tblMeta}{$_[1]};
    } # EXISTS

sub DELETE
{
    croak "Can't delete single attributes from table meta structure";
    } # DELETE

sub CLEAR
{
    %{$_[0]->{tblMeta}} = ()
    } # CLEAR

sub SCALAR
{
    scalar %{$_[0]->{tblMeta}}
    } # SCALAR

# ====== Tie-Tables ============================================================

package DBD::File::TieTables;

use Carp qw(croak);
require Tie::Hash;
@DBD::File::TieTables::ISA = qw(Tie::Hash);

sub TIEHASH
{
    my ($class, $dbh) = @_;

    (my $tbl_class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/;
    my $self = bless ({ dbh => $dbh, tblClass => $tbl_class, }, $class);
    return $self;
    } # new

sub STORE
{
    my ($self, $table, $tbl_meta) = @_;

    "HASH" eq ref $tbl_meta or
        croak "Invalid data for storing as table meta data (must be hash)";

    (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1);
    $meta or croak "Invalid table name '$table'";

    while (my ($meta_attr, $meta_val) = each %$tbl_meta) {
	$self->{tblClass}->set_table_meta_attr ($meta, $meta_attr, $meta_val);
	}

    return;
    } # STORE

sub FETCH
{
    my ($self, $table) = @_;

    (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1);
    $meta or croak "Invalid table name '$table'";

    my %h;
    tie %h, "DBD::File::TieMeta", $self->{tblClass}, $meta;

    return \%h;
    } # FETCH

sub FIRSTKEY
{
    my $a = scalar keys %{$_[0]->{dbh}->{f_meta}};
    each %{$_[0]->{dbh}->{f_meta}};
    } # FIRSTKEY

sub NEXTKEY
{
    each %{$_[0]->{dbh}->{f_meta}};
    } # NEXTKEY

sub EXISTS
{
    exists $_[0]->{dbh}->{f_meta}->{$_[1]} or
	exists $_[0]->{dbh}->{f_meta_map}->{$_[1]};
    } # EXISTS

sub DELETE
{
    my ($self, $table) = @_;

    (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1);
    $meta or croak "Invalid table name '$table'";

    delete $_[0]->{dbh}->{f_meta}->{$meta->{table_name}};
    } # DELETE

sub CLEAR
{
    %{$_[0]->{dbh}->{f_meta}} = ();
    %{$_[0]->{dbh}->{f_meta_map}} = ();
    } # CLEAR

sub SCALAR
{
    scalar %{$_[0]->{dbh}->{f_meta}}
    } # SCALAR

# ====== STATEMENT =============================================================

package DBD::File::st;

use strict;
use warnings;

use vars qw(@ISA $imp_data_size);

@DBD::File::st::ISA           = qw(DBI::DBD::SqlEngine::st);
$DBD::File::st::imp_data_size = 0;

my %supported_attrs = (
    TYPE      => 1,
    PRECISION => 1,
    NULLABLE  => 1,
    );

sub FETCH
{
    my ($sth, $attr) = @_;

    if ($supported_attrs{$attr}) {
	my $stmt = $sth->{sql_stmt};

	if (exists $sth->{ImplementorClass} &&
	    exists $sth->{sql_stmt} &&
	    $sth->{sql_stmt}->isa ("SQL::Statement")) {

	    # fill overall_defs unless we know
	    unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) {
		my $all_meta =
		    $sth->{Database}->func ("*", "table_defs", "get_file_meta");
		while (my ($tbl, $meta) = each %$all_meta) {
		    exists $meta->{table_defs} && ref $meta->{table_defs} or next;
		    foreach (keys %{$meta->{table_defs}{columns}}) {
			$sth->{f_overall_defs}{$_} = $meta->{table_defs}{columns}{$_};
			}
		    }
		}

	    my @colnames = $sth->sql_get_colnames ();

	    $attr eq "TYPE"      and
		return [ map { $sth->{f_overall_defs}{$_}{data_type}   || "CHAR" }
			    @colnames ];

	    $attr eq "PRECISION" and
		return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 }
			    @colnames ];

	    $attr eq "NULLABLE"  and
		return [ map { ( grep m/^NOT NULL$/ =>
			    @{ $sth->{f_overall_defs}{$_}{constraints} || [] })
			       ? 0 : 1 }
			    @colnames ];
	    }
	}

    return $sth->SUPER::FETCH ($attr);
    } # FETCH

# ====== SQL::STATEMENT ========================================================

package DBD::File::Statement;

use strict;
use warnings;

@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::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 warnings;

use Carp;
require IO::File;
require File::Basename;
require File::Spec;
require Cwd;

# 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::DBD::SqlEngine::Table );

# ====== FLYWEIGHT SUPPORT =====================================================

my $fn_any_ext_regex = qr/\.[^.]*/;

# 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, $respect_case) = @_;

    $file eq "." || $file eq ".."	and return; # XXX would break a possible DBD::Dir

    my ($ext, $req) = ("", 0);
    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;
    my ($tbl, $basename, $dir, $fn_ext, $user_spec_file);
    if ($file_is_table and defined $meta->{f_file}) {
	$tbl = $file;
	($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex);
	$file = $basename . $fn_ext;
	$user_spec_file = 1;
	}
    else {
	($basename, $dir, undef) = File::Basename::fileparse ($file, $ext);
	$file = $tbl = $basename;
	$user_spec_file = 0;
	}

    if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER
        $basename = uc $basename;
        $tbl = uc $tbl;
	}
    if( !$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
        $basename = lc $basename;
        $tbl = lc $tbl;
	}

    my $searchdir = File::Spec->file_name_is_absolute ($dir)
	? ($dir =~ s|/$||, $dir)
	: Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
    -d $searchdir or
	croak "-d $searchdir: $!";

    $searchdir eq $meta->{f_dir} and
	$dir = "";

    unless ($user_spec_file) {
	$file_is_table and $file = "$basename$ext";

	# Fully Qualified File Name
	my $cmpsub;
	if ($respect_case) {
	    $cmpsub = sub {
		my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
		$sfx = '' if $^O eq 'VMS' and $sfx eq '.';  # no extension turns up as a dot
		$fn eq $basename and
		    return (lc $sfx eq lc $ext or !$req && !$sfx);
		return 0;
		}
	    }
	else {
	    $cmpsub = sub {
		my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
		$sfx = '' if $^O eq 'VMS' and $sfx eq '.';  # no extension turns up as a dot
		lc $fn eq lc $basename and
		    return (lc $sfx eq lc $ext or !$req && !$sfx);
		return 0;
		}
	    }

	opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!";
	my @f = sort { length $b <=> length $a } grep { &$cmpsub ($_) } readdir $dh;
	@f > 0 && @f <= 2 and $file = $f[0];
	!$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
	    ($tbl = $file) =~ s/$ext$//i;
	closedir $dh or croak "Can't close '$searchdir': $!";

	my $tmpfn = $file;
	if ($ext && $req) {
            # File extension required
            $tmpfn =~ s/$ext$//i or return;
            }
	}

    my $fqfn = File::Spec->catfile ($searchdir, $file);
    my $fqbn = File::Spec->catfile ($searchdir, $basename);

    $meta->{f_fqfn} = $fqfn;
    $meta->{f_fqbn} = $fqbn;
    defined $meta->{f_lockfile} && $meta->{f_lockfile} and
	$meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile};

    $dir && !$user_spec_file  and $tbl = File::Spec->catfile ($dir, $tbl);
    $meta->{table_name} = $tbl;

    return $tbl;
    } # file2table

sub bootstrap_table_meta
{
    my ($self, $dbh, $meta, $table) = @_;

    exists  $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};
    exists  $meta->{f_lock}	or $meta->{f_lock}	= $dbh->{f_lock};
    exists  $meta->{f_lockfile}	or $meta->{f_lockfile}	= $dbh->{f_lockfile};
    defined $meta->{f_schema}	or $meta->{f_schema}	= $dbh->{f_schema};
    defined $meta->{sql_identifier_case} or
        $meta->{sql_identifier_case} = $dbh->{sql_identifier_case};
    } # bootstrap_table_meta

sub init_table_meta
{
    my ($self, $dbh, $meta, $table) = @_;

    return;
    } # init_table_meta

sub get_table_meta ($$$$;$)
{
    my ($self, $dbh, $table, $file_is_table, $respect_case) = @_;
    unless (defined $respect_case) {
	$respect_case = 0;
	$table =~ s/^\"// and $respect_case = 1;    # handle quoted identifiers
	$table =~ s/\"$//;
	}

    unless ($respect_case) {
	defined $dbh->{f_meta_map}{$table} and $table = $dbh->{f_meta_map}{$table};
	}

    my $meta = {};
    defined $dbh->{f_meta}{$table} and $meta = $dbh->{f_meta}{$table};

    unless ($meta->{initialized}) {
	$self->bootstrap_table_meta ($dbh, $meta, $table);

	unless (defined $meta->{f_fqfn}) {
	    $self->file2table ($meta, $table, $file_is_table, $respect_case) or return;
	    }

	if (defined $meta->{table_name} and $table ne $meta->{table_name}) {
	    $dbh->{f_meta_map}{$table} = $meta->{table_name};
	    $table = $meta->{table_name};
	    }

	# now we know a bit more - let's check if user can't use consequent spelling
	# XXX add know issue about reset sql_identifier_case here ...
	if (defined $dbh->{f_meta}{$table} && defined $dbh->{f_meta}{$table}{initialized}) {
	    $meta = $dbh->{f_meta}{$table};
	    $self->file2table ($meta, $table, $file_is_table, $respect_case) or
		return unless $dbh->{f_meta}{$table}{initialized};
	    }
	unless ($dbh->{f_meta}{$table}{initialized}) {
	    $self->init_table_meta ($dbh, $meta, $table);
	    $meta->{initialized} = 1;
	    $dbh->{f_meta}{$table} = $meta;
	    }
	}

    return ($table, $meta);
    } # get_table_meta

my %reset_on_modify = (
    f_file     => "f_fqfn",
    f_dir      => "f_fqfn",
    f_ext      => "f_fqfn",
    f_lockfile => "f_fqfn", # forces new file2table call
    );

my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile );

sub register_reset_on_modify
{
    my ($proto, $extra_resets) = @_;
    %reset_on_modify = (%reset_on_modify, %$extra_resets);
    return;
    } # register_reset_on_modify

sub register_compat_map
{
    my ($proto, $extra_compat_map) = @_;
    %compat_map = (%compat_map, %$extra_compat_map);
    return;
    } # register_compat_map

sub get_table_meta_attr
{
    my ($class, $meta, $attrib) = @_;
    exists $compat_map{$attrib} and
	$attrib = $compat_map{$attrib};
    exists $meta->{$attrib} and
	return $meta->{$attrib};
    return;
    } # get_table_meta_attr

sub set_table_meta_attr
{
    my ($class, $meta, $attrib, $value) = @_;
    exists $compat_map{$attrib} and
	$attrib = $compat_map{$attrib};
    $class->table_meta_attr_changed ($meta, $attrib, $value);
    $meta->{$attrib} = $value;
    } # set_table_meta_attr

sub table_meta_attr_changed
{
    my ($class, $meta, $attrib, $value) = @_;
    defined $reset_on_modify{$attrib} and
	delete $meta->{$reset_on_modify{$attrib}} and
	$meta->{initialized} = 0;
    } # table_meta_attr_changed

# ====== FILE OPEN =============================================================

sub 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: $! (" . ($!+0) . ")";
	    }
	else {
	    unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) {
		croak "Cannot open $fn: $! (" . ($!+0) . ")";
		}
	    }

	if ($fh) {
	    $fh->seek (0, 0) or
		croak "Error while seeking back: $!";
	    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 ($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: $! (" . ($!+0) . ")";
	    }
	else {
	    unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) {
		croak "Cannot open $fn: $! (" . ($!+0) . ")";
		}
	    }

	$meta->{lockfh} = $fh;
	}

    if ($locking && $fh) {
	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 $fn: $!";
	    }
	elsif ($lm == 1) {
	    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 ($tblnm, $meta) = $className->get_table_meta ($dbh, $attrs->{table}, 1) or
        croak "Cannot find appropriate file for table '$attrs->{table}'";
    $attrs->{table} = $tblnm;

    # Being a bit dirty here, as SQL::Statement::Structure does not offer
    # me an interface to the data I want
    $flags->{createMode} && $data->{sql_stmt}{table_defs} and
	$meta->{table_defs} = $data->{sql_stmt}{table_defs};

    $className->open_file ($meta, $attrs, $flags);

    my $columns = {};
    my $array   = [];
    my $tbl     = {
	%{$attrs},
	meta          => $meta,
	col_names     => $meta->{col_names} || [],
	};
    return $className->SUPER::new ($tbl);
    } # new

sub drop ($)
{
    my ($self, $data) = @_;
    my $meta = $self->{meta};
    # We have to close the file before unlinking it: Some OS'es will
    # refuse the unlink otherwise.
    $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

sub seek ($$$$)
{
    my ($self, $data, $pos, $whence) = @_;
    my $meta = $self->{meta};
    if ($whence == 0 && $pos == 0) {
	$pos = defined $meta->{first_row_pos} ? $meta->{first_row_pos} : 0;
	}
    elsif ($whence != 2 || $pos != 0) {
	croak "Illegal seek position: pos = $pos, whence = $whence";
	}

    $meta->{fh}->seek ($pos, $whence) or
	croak "Error while seeking in " . $meta->{f_fqfn} . ": $!";
    } # seek

sub truncate ($$)
{
    my ($self, $data) = @_;
    my $meta = $self->{meta};
    $meta->{fh}->truncate ($meta->{fh}->tell ()) or
	croak "Error while truncating " . $meta->{f_fqfn} . ": $!";
    return 1;
    } # truncate

sub DESTROY
{
    my $self = shift;
    my $meta = $self->{meta};
    $meta->{fh} and $meta->{fh}->close ();
    $meta->{lockfh} and $meta->{lockfh}->close ();
    undef $meta->{fh};
    undef $meta->{lockfh};
    } # DESTROY

1;

__END__