Author: hmbrand
Date: Tue Apr 28 23:06:34 2009
New Revision: 12722
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBD/File.pm
Log:
Fixes to DBD::File (H.Merijn Brand)
bind_param () now honors the attribute argument
added f_ext attribute
File::Spec is always required. (CORE since 5.00405)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Apr 28 23:06:34 2009
@@ -56,6 +56,10 @@
=head2 Changes in DBI 1.608 (svn rXXX)
+ Fixes to DBD::File (H.Merijn Brand)
+ bind_param () now honors the attribute argument
+ added f_ext attribute
+ File::Spec is always required. (CORE since 5.00405)
Fixed two small memory leaks when running in mod_perl
one in DBI->connect and one in DBI::Gofer::Execute.
Both due to "local $ENV{...};" leaking memory.
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Tue Apr 28 23:06:34 2009
@@ -5,10 +5,11 @@
#
# This module is currently maintained by
#
-# Jeff Zucker < jzucker AT cpan.org >
+# H.Merijn Brand & Jens Rehsack
#
# The original author is Jochen Wiedmann.
#
+# Copyright (C) 2009 by H.Merijn Brand & Jens Rehsack
# Copyright (C) 2004 by Jeff Zucker
# Copyright (C) 1998 by Jochen Wiedmann
#
@@ -17,24 +18,28 @@
# 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.004;
+
+require 5.005;
+
use strict;
use DBI ();
require DBI::SQL::Nano;
-my $haveFileSpec = eval { require File::Spec };
+require File::Spec;
package DBD::File;
-use vars qw(@ISA $VERSION $drh $valid_attrs);
+use strict;
+
+use vars qw( @ISA $VERSION $drh $valid_attrs );
-$VERSION = '0.35';
+$VERSION = "0.36";
$drh = undef; # holds driver handle(s) once initialised
-sub driver ($;$) {
- my($class, $attr) = @_;
+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.
@@ -43,607 +48,714 @@
# 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.
- return $drh->{$class} if $drh->{$class};
+ $drh->{$class} and return $drh->{$class};
- DBI->setup_driver('DBD::File'); # only needed once but harmless to repeat
+ DBI->setup_driver ("DBD::File"); # only needed once but harmless to repeat
$attr ||= {};
- no strict qw(refs);
- if (!$attr->{Attribution}) {
- $attr->{Attribution} = "$class by Jeff Zucker"
- if $class eq 'DBD::File';
- $attr->{Attribution} ||= ${$class . '::ATTRIBUTION'}
- || "oops the author of $class forgot to define this";
- }
- $attr->{Version} ||= ${$class . '::VERSION'};
- ($attr->{Name} = $class) =~ s/^DBD\:\:// unless $attr->{Name};
+ { 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} = DBI::_new_drh($class . "::dr", $attr);
- $drh->{$class}->STORE(ShowErrorStatement => 1);
+ $drh->{$class} = DBI::_new_drh ($class . "::dr", $attr);
+ $drh->{$class}->STORE (ShowErrorStatement => 1);
return $drh->{$class};
-}
+ } # driver
-sub CLONE {
+sub CLONE
+{
undef $drh;
-}
+ } # CLONE
+
+sub file2table
+{
+ my ($data, $dir, $file, $file_is_tab) = @_;
+
+ $file eq "." || $file eq ".." and return;
+
+ # Fully Qualified File Name
+ my $fqfn = File::Spec->catfile ($dir, $file);
+
+ my ($ext, $req) = ("", 0, 0);
+ if ($data->{f_ext}) {
+ ($ext, my $opt) = split m/\//, $data->{f_ext};
+ if ($ext) {
+ $opt =~ m/r/i and $req = 1;
+ }
+ }
-package DBD::File::dr; # ====== DRIVER ======
+ (my $tbl = $file) =~ s/$ext$//i;
+
+ $file_is_tab && $file !~ m/$ext$/i and $fqfn .= $ext;
+
+ $file = $fqfn;
+ if ($ext) {
+ if ($req) {
+ # File extension required
+ $file =~ s/$ext$//i or next;
+ }
+ else {
+ # File extension optional, skip if file with extension exists
+ grep m/$ext$/i, glob "$fqfn*" and next;
+ $file =~ s/$ext$//i;
+ }
+ }
+
+ $data->{f_map}{$tbl} = $fqfn;
+ return $tbl;
+ } # file2table
+
+# ====== DRIVER
================================================================
+
+package DBD::File::dr;
+
+use strict;
$DBD::File::dr::imp_data_size = 0;
-sub connect ($$;$$$) {
- my($drh, $dbname, $user, $auth, $attr)= @_;
+sub connect ($$;$$$)
+{
+ my ($drh, $dbname, $user, $auth, $attr)= @_;
# create a 'blank' dbh
- my $this = DBI::_new_dbh($drh, {
- 'Name' => $dbname,
- 'USER' => $user,
- 'CURRENT_USER' => $user,
- });
+ my $this = DBI::_new_dbh ($drh, {
+ Name => $dbname,
+ USER => $user,
+ CURRENT_USER => $user,
+ });
if ($this) {
- my($var, $val);
- $this->{f_dir} = $haveFileSpec ? File::Spec->curdir() : '.';
- while (length($dbname)) {
+ my ($var, $val);
+ $this->{f_dir} = File::Spec->curdir ();
+ $this->{f_ext} = "";
+ $this->{f_map} = {};
+ while (length $dbname) {
if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) {
- $var = $1;
- } else {
- $var = $dbname;
- $dbname = '';
- }
- if ($var =~ /^(.+?)=(.*)/s) {
+ $var = $1;
+ }
+ else {
+ $var = $dbname;
+ $dbname = "";
+ }
+ if ($var =~ m/^(.+?)=(.*)/s) {
$var = $1;
($val = $2) =~ s/\\(.)/$1/g;
$this->{$var} = $val;
+ }
}
- }
$this->{f_valid_attrs} = {
- f_version => 1 # DBD::File version
- , f_dir => 1 # base directory
- , f_tables => 1 # base directory
- };
+ f_version => 1, # DBD::File version
+ f_dir => 1, # base directory
+ f_ext => "", # file extension
+ f_tables => 1, # base directory
+ };
$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);
-}
+ 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 {
+sub set_versions
+{
my $this = shift;
$this->{f_version} = $DBD::File::VERSION;
for (qw( nano_version statement_version)) {
- $this->{'sql_'.$_} = $DBI::SQL::Nano::versions->{$_}||'';
- }
- $this->{sql_handler} = ($this->{sql_statement_version})
- ? 'SQL::Statement'
- : 'DBI::SQL::Nano';
+ $this->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_} || "";
+ }
+ $this->{sql_handler} = $this->{sql_statement_version}
+ ? "SQL::Statement"
+ : "DBI::SQL::Nano";
return $this;
-}
+ } # set_versions
-sub data_sources ($;$) {
- my($drh, $attr) = @_;
- my($dir) = ($attr and exists($attr->{'f_dir'})) ?
- $attr->{'f_dir'} : $haveFileSpec ? File::Spec->curdir() : '.';
- my($dirh) = Symbol::gensym();
- if (!opendir($dirh, $dir)) {
- $drh->set_err($DBI::stderr, "Cannot open directory $dir: $!");
- return undef;
- }
- my($file, @dsns, %names, $driver);
- if ($drh->{'ImplementorClass'} =~ /^dbd\:\:([^\:]+)\:\:/i) {
+sub data_sources ($;$)
+{
+ my ($drh, $attr) = @_;
+ my $dir = $attr && exists $attr->{f_dir}
+ ? $attr->{f_dir}
+ : File::Spec->curdir ();
+ my ($dirh) = Symbol::gensym ();
+ unless (opendir ($dirh, $dir)) {
+ $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
+ return;
+ }
+
+ my ($file, @dsns, %names, $driver);
+ if ($drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i) {
$driver = $1;
- } else {
- $driver = 'File';
- }
- while (defined($file = readdir($dirh))) {
- if ($^O eq 'VMS') {
- # if on VMS then avoid warnings from catdir if you use a file
- # (not a dir) as the file below
- next if $file !~ /\.dir$/oi;
- }
- my $d = $haveFileSpec ?
- File::Spec->catdir($dir, $file) : "$dir/$file";
- # allow current dir ... it can be a data_source too
- if ( $file ne ($haveFileSpec ? File::Spec->updir() : '..')
- and -d $d) {
- push(@dsns, "DBI:$driver:f_dir=$d");
}
- }
+ else {
+ $driver = "File";
+ }
+
+ while (defined ($file = readdir ($dirh))) {
+ if ($^O eq "VMS") {
+ # if on VMS then avoid warnings from catdir if you use a file
+ # (not a dir) as the file below
+ $file !~ m/\.dir$/oi and next;
+ }
+ 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=$d";
+ }
@dsns;
-}
+ } # data_sources
-sub disconnect_all {
-}
+sub disconnect_all
+{
+ } # disconnect_all
-sub DESTROY {
+sub DESTROY
+{
undef;
-}
+ } # DESTROY
+
+# ====== DATABASE
==============================================================
+package DBD::File::db;
-package DBD::File::db; # ====== DATABASE ======
+use strict;
+use Carp;
$DBD::File::db::imp_data_size = 0;
-sub ping { return (shift->FETCH('Active')) ? 1 : 0 };
+sub ping
+{
+ return (shift->FETCH ("Active")) ? 1 : 0;
+ } # ping
-sub prepare ($$;@) {
- my($dbh, $statement, @attribs)= @_;
+sub prepare ($$;@)
+{
+ my ($dbh, $statement, @attribs) = @_;
# create a 'blank' sth
- my $sth = DBI::_new_sth($dbh, {'Statement' => $statement});
+ my $sth = DBI::_new_sth ($dbh, {Statement => $statement});
if ($sth) {
- my $class = $sth->FETCH('ImplementorClass');
+ my $class = $sth->FETCH ("ImplementorClass");
$class =~ s/::st$/::Statement/;
- my($stmt);
+ my $stmt;
- # if using SQL::Statement version > 1
- # cache the parser object if the DBD supports parser caching
- # SQL::Nano and older SQL::Statements don't support this
-
- if ( $dbh->{sql_handler} eq 'SQL::Statement'
- and $dbh->{sql_statement_version} > 1)
- {
- my $parser = $dbh->{csv_sql_parser_object};
- $parser ||= eval { $dbh->func('csv_cache_sql_parser_object') };
- if ($@) {
- $stmt = eval { $class->new($statement) };
- }
- else {
- $stmt = eval { $class->new($statement,$parser) };
- }
- }
- else {
- $stmt = eval { $class->new($statement) };
- }
+ # if using SQL::Statement version > 1
+ # cache the parser object if the DBD supports parser caching
+ # SQL::Nano and older SQL::Statements don't support this
+
+ if ( $dbh->{sql_handler} eq "SQL::Statement" and
+ $dbh->{sql_statement_version} > 1) {
+ my $parser = $dbh->{csv_sql_parser_object};
+ $parser ||= eval { $dbh->func ("csv_cache_sql_parser_object") };
+ if ($@) {
+ $stmt = eval { $class->new ($statement) };
+ }
+ else {
+ $stmt = eval { $class->new ($statement, $parser) };
+ }
+ }
+ else {
+ $stmt = eval { $class->new ($statement) };
+ }
if ($@) {
- $dbh->set_err($DBI::stderr, $@);
+ $dbh->set_err ($DBI::stderr, $@);
undef $sth;
- } else {
- $sth->STORE('f_stmt', $stmt);
- $sth->STORE('f_params', []);
- $sth->STORE('NUM_OF_PARAMS', scalar($stmt->params()));
+ }
+ else {
+ $sth->STORE ("f_stmt", $stmt);
+ $sth->STORE ("f_params", []);
+ $sth->STORE ("NUM_OF_PARAMS", scalar ($stmt->params ()));
+ }
}
- }
$sth;
-}
-sub csv_cache_sql_parser_object {
- my $dbh = shift;
+ } # prepare
+
+sub csv_cache_sql_parser_object
+{
+ my $dbh = shift;
my $parser = {
- dialect => 'CSV',
- RaiseError => $dbh->FETCH('RaiseError'),
- PrintError => $dbh->FETCH('PrintError'),
- };
- my $sql_flags = $dbh->FETCH('sql_flags') || {};
- %$parser = (%$parser,%$sql_flags);
- $parser = SQL::Parser->new($parser->{dialect},$parser);
+ dialect => "CSV",
+ RaiseError => $dbh->FETCH ("RaiseError"),
+ PrintError => $dbh->FETCH ("PrintError"),
+ };
+ my $sql_flags = $dbh->FETCH ("sql_flags") || {};
+ %$parser = (%$parser, %$sql_flags);
+ $parser = SQL::Parser->new ($parser->{dialect}, $parser);
$dbh->{csv_sql_parser_object} = $parser;
return $parser;
-}
-sub disconnect ($) {
- shift->STORE('Active',0);
+ } # csv_cache_sql_parser_object
+
+sub disconnect ($)
+{
+ shift->STORE ("Active", 0);
1;
-}
-sub FETCH ($$) {
+ } # disconnect
+
+sub FETCH ($$)
+{
my ($dbh, $attrib) = @_;
- if ($attrib eq 'AutoCommit') {
+ $attrib eq "AutoCommit" and
return 1;
- } elsif ($attrib eq (lc $attrib)) {
+
+ if ($attrib eq (lc $attrib)) {
# Driver private attributes are lower cased
- # Error-check for valid attributes
- # not implemented yet, see STORE
- #
- return $dbh->{$attrib};
- }
+ # Error-check for valid attributes
+ # not implemented yet, see STORE
+ #
+ return $dbh->{$attrib};
+ }
# else pass up to DBI to handle
- return $dbh->SUPER::FETCH($attrib);
-}
+ return $dbh->SUPER::FETCH ($attrib);
+ } # FETCH
-sub STORE ($$$) {
+sub STORE ($$$)
+{
my ($dbh, $attrib, $value) = @_;
- if ($attrib eq 'AutoCommit') {
- return 1 if $value; # is already set
- die("Can't disable AutoCommit");
- } elsif ($attrib eq (lc $attrib)) {
+ if ($attrib eq "AutoCommit") {
+ $value and return 1; # is already set
+ croak "Can't disable AutoCommit";
+ }
+
+ if ($attrib eq lc $attrib) {
# Driver private attributes are lower cased
- # I'm not implementing this yet becuase other drivers may be
- # setting f_ and sql_ attrs I don't know about
- # I'll investigate and publicize warnings to DBD authors
- # then implement this
- #
- # return to implementor if not f_ or sql_
- # not implemented yet
- # my $class = $dbh->FETCH('ImplementorClass');
- #
- # if ( !$dbh->{f_valid_attrs}->{$attrib}
- # and !$dbh->{sql_valid_attrs}->{$attrib}
- # ) {
- # return $dbh->set_err( $DBI::stderr,"Invalid attribute '$attrib'");
- # }
- # else {
- # $dbh->{$attrib} = $value;
- # }
-
- if ($attrib eq 'f_dir') {
- return $dbh->set_err( $DBI::stderr,"No such directory '$value'")
- unless -d $value;
- }
+ # I'm not implementing this yet becuase other drivers may be
+ # setting f_ and sql_ attrs I don't know about
+ # I'll investigate and publicize warnings to DBD authors
+ # then implement this
+
+ # return to implementor if not f_ or sql_
+ # not implemented yet
+ # my $class = $dbh->FETCH ("ImplementorClass");
+ #
+ # !$dbh->{f_valid_attrs}->{$attrib} &&
!$dbh->{sql_valid_attrs}->{$attrib} and
+ # return $dbh->set_err ($DBI::stderr, "Invalid attribute '$attrib'");
+ # $dbh->{$attrib} = $value;
+
+ if ($attrib eq "f_dir") {
+ -d $value or
+ return $dbh->set_err ($DBI::stderr, "No such directory
'$value'")
+ }
+ if ($attrib eq "f_ext") {
+ $value eq "" || $value =~ m{^\.\w+(?:/[iIrR]*)?$}
+ or carp "'$value' doesn't look like a valid file extension
attribute\n";
+ }
$dbh->{$attrib} = $value;
return 1;
- }
- return $dbh->SUPER::STORE($attrib, $value);
-}
+ }
+ return $dbh->SUPER::STORE ($attrib, $value);
+ } # STORE
-sub DESTROY ($) {
+sub DESTROY ($)
+{
my $dbh = shift;
- $dbh->disconnect if $dbh->SUPER::FETCH('Active');
-}
+ $dbh->SUPER::FETCH ("Active") and $dbh->disconnect ;
+ } # DESTROY
-sub type_info_all ($) {
- [
- { TYPE_NAME => 0,
- DATA_TYPE => 1,
- PRECISION => 2,
- LITERAL_PREFIX => 3,
- LITERAL_SUFFIX => 4,
- CREATE_PARAMS => 5,
- NULLABLE => 6,
- CASE_SENSITIVE => 7,
- SEARCHABLE => 8,
- UNSIGNED_ATTRIBUTE=> 9,
- MONEY => 10,
- AUTO_INCREMENT => 11,
- LOCAL_TYPE_NAME => 12,
- MINIMUM_SCALE => 13,
- MAXIMUM_SCALE => 14,
- },
- [ 'VARCHAR', DBI::SQL_VARCHAR(),
- undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
- ],
- [ 'CHAR', DBI::SQL_CHAR(),
- undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
- ],
- [ 'INTEGER', DBI::SQL_INTEGER(),
- undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0
- ],
- [ 'REAL', DBI::SQL_REAL(),
- undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0
- ],
- [ 'BLOB', DBI::SQL_LONGVARBINARY(),
- undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
- ],
- [ 'BLOB', DBI::SQL_LONGVARBINARY(),
- undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
- ],
- [ 'TEXT', DBI::SQL_LONGVARCHAR(),
- undef, "'","'", undef,0, 1,1,0,0,0,undef,1,999999
- ]
- ]
-}
-
-
-{
- my $names = ['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME',
- 'TABLE_TYPE', 'REMARKS'];
-
- sub table_info ($) {
- my($dbh) = @_;
- my($dir) = $dbh->{f_dir};
- my($dirh) = Symbol::gensym();
- if (!opendir($dirh, $dir)) {
- $dbh->set_err($DBI::stderr, "Cannot open directory $dir: $!");
- return undef;
- }
- my($file, @tables, %names);
- while (defined($file = readdir($dirh))) {
- if ($file ne '.' && $file ne '..' && -f "$dir/$file") {
- my $user = eval { getpwuid((stat(_))[4]) };
- push(@tables, [undef, $user, $file, "TABLE", undef]);
- }
- }
- if (!closedir($dirh)) {
- $dbh->set_err($DBI::stderr, "Cannot close directory $dir: $!");
- return undef;
- }
-
- my $dbh2 = $dbh->{'csv_sponge_driver'};
- if (!$dbh2) {
- $dbh2 = $dbh->{'csv_sponge_driver'} = DBI->connect("DBI:Sponge:");
- if (!$dbh2) {
- $dbh->set_err($DBI::stderr, $DBI::errstr);
- return undef;
+sub type_info_all ($)
+{
+ [ { TYPE_NAME => 0,
+ DATA_TYPE => 1,
+ PRECISION => 2,
+ LITERAL_PREFIX => 3,
+ LITERAL_SUFFIX => 4,
+ CREATE_PARAMS => 5,
+ NULLABLE => 6,
+ CASE_SENSITIVE => 7,
+ SEARCHABLE => 8,
+ UNSIGNED_ATTRIBUTE => 9,
+ MONEY => 10,
+ AUTO_INCREMENT => 11,
+ LOCAL_TYPE_NAME => 12,
+ MINIMUM_SCALE => 13,
+ MAXIMUM_SCALE => 14,
+ },
+ [ "VARCHAR", DBI::SQL_VARCHAR (),
+ undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
+ ],
+ [ "CHAR", DBI::SQL_CHAR (),
+ undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
+ ],
+ [ "INTEGER", DBI::SQL_INTEGER (),
+ undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0,
+ ],
+ [ "REAL", DBI::SQL_REAL (),
+ undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0,
+ ],
+ [ "BLOB", DBI::SQL_LONGVARBINARY (),
+ undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
+ ],
+ [ "BLOB", DBI::SQL_LONGVARBINARY (),
+ undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
+ ],
+ [ "TEXT", DBI::SQL_LONGVARCHAR (),
+ undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999,
+ ]];
+ } # type_info_all
+
+{ my $names = [
+ qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )];
+
+ sub table_info ($)
+ {
+ my $dbh = shift;
+ my $dir = $dbh->{f_dir};
+ my $dirh = Symbol::gensym ();
+
+ unless (opendir $dirh, $dir) {
+ $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
+ return;
+ }
+
+ my ($file, @tables, %names);
+ my $user = eval { getpwuid ((stat _)[4]) };
+ while (defined ($file = readdir ($dirh))) {
+ my $tbl = DBD::File::file2table ($dbh, $dir, $file, 0) or next;
+ push @tables, [ undef, $user, $tbl, "TABLE", undef ];
+ }
+ unless (closedir $dirh) {
+ $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
+ return;
+ }
+
+ my $dbh2 = $dbh->{csv_sponge_driver};
+ unless ($dbh2) {
+ $dbh2 = $dbh->{csv_sponge_driver} = DBI->connect ("DBI:Sponge:");
+ unless ($dbh2) {
+ $dbh->set_err ($DBI::stderr, $DBI::errstr);
+ return;
+ }
}
- }
# Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
- return undef if !...@tables;
+ @tables or return;
- my $sth = $dbh2->prepare("TABLE_INFO", { 'rows' => \...@tables,
- 'NAMES' => $names });
- if (!$sth) {
- $dbh->set_err($DBI::stderr, $dbh2->errstr);
- }
+ my $sth = $dbh2->prepare ("TABLE_INFO", {
+ rows => \...@tables,
+ NAMES => $names,
+ });
+ $sth or $dbh->set_err ($DBI::stderr, $dbh2->errstr);
$sth;
+ } # table_info
}
-}
-sub list_tables ($) {
+
+sub list_tables ($)
+{
my $dbh = shift;
- my($sth, @tables);
- if (!($sth = $dbh->table_info())) {
- return ();
- }
- while (my $ref = $sth->fetchrow_arrayref()) {
- push(@tables, $ref->[2]);
- }
+ my ($sth, @tables);
+ $sth = $dbh->table_info () or return;
+ while (my $ref = $sth->fetchrow_arrayref ()) {
+ push @tables, $ref->[2];
+ }
@tables;
-}
+ } # list_tables
+
+sub quote ($$;$)
+{
+ my ($self, $str, $type) = @_;
+ defined $str or return "NULL";
+ defined $type && (
+ $type == DBI::SQL_NUMERIC ()
+ || $type == DBI::SQL_DECIMAL ()
+ || $type == DBI::SQL_INTEGER ()
+ || $type == DBI::SQL_SMALLINT ()
+ || $type == DBI::SQL_FLOAT ()
+ || $type == DBI::SQL_REAL ()
+ || $type == DBI::SQL_DOUBLE ()
+ || $type == DBI::SQL_TINYINT ())
+ and return $str;
-sub quote ($$;$) {
- my($self, $str, $type) = @_;
- if (!defined($str)) { return "NULL" }
- if (defined($type) &&
- ($type == DBI::SQL_NUMERIC() ||
- $type == DBI::SQL_DECIMAL() ||
- $type == DBI::SQL_INTEGER() ||
- $type == DBI::SQL_SMALLINT() ||
- $type == DBI::SQL_FLOAT() ||
- $type == DBI::SQL_REAL() ||
- $type == DBI::SQL_DOUBLE() ||
- $type == DBI::SQL_TINYINT())) {
- return $str;
- }
$str =~ s/\\/\\\\/sg;
$str =~ s/\0/\\0/sg;
$str =~ s/\'/\\\'/sg;
$str =~ s/\n/\\n/sg;
$str =~ s/\r/\\r/sg;
"'$str'";
-}
+ } # quote
-sub commit ($) {
- my($dbh) = shift;
- if ($dbh->FETCH('Warn')) {
- warn("Commit ineffective while AutoCommit is on", -1);
- }
+sub commit ($)
+{
+ my $dbh = shift;
+ $dbh->FETCH ("Warn") and
+ carp "Commit ineffective while AutoCommit is on", -1;
1;
-}
+ } # commit
-sub rollback ($) {
- my($dbh) = shift;
- if ($dbh->FETCH('Warn')) {
- warn("Rollback ineffective while AutoCommit is on", -1);
- }
+sub rollback ($)
+{
+ my $dbh = shift;
+ $dbh->FETCH ("Warn") and
+ carp "Rollback ineffective while AutoCommit is on", -1;
0;
-}
+ } # rollback
+
+# ====== STATEMENT
=============================================================
-package DBD::File::st; # ====== STATEMENT ======
+package DBD::File::st;
+
+use strict;
$DBD::File::st::imp_data_size = 0;
-sub bind_param ($$$;$) {
- my($sth, $pNum, $val, $attr) = @_;
- $sth->{f_params}->[$pNum-1] = $val;
+sub bind_param ($$$;$)
+{
+ my ($sth, $pNum, $val, $attr) = @_;
+ if ($attr && defined $val) {
+ my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr;
+ if ( $attr == DBI::SQL_BIGINT ()
+ || $attr == DBI::SQL_INTEGER ()
+ || $attr == DBI::SQL_SMALLINT ()
+ || $attr == DBI::SQL_TINYINT ()
+ ) {
+ $val += 0;
+ }
+ elsif ($attr == DBI::SQL_DECIMAL ()
+ || $attr == DBI::SQL_DOUBLE ()
+ || $attr == DBI::SQL_FLOAT ()
+ || $attr == DBI::SQL_NUMERIC ()
+ || $attr == DBI::SQL_REAL ()
+ ) {
+ $val += 0.;
+ }
+ else {
+ $val = "$val";
+ }
+ }
+ $sth->{f_params}[$pNum - 1] = $val;
1;
-}
+ } # bind_param
-sub execute {
+sub execute
+{
my $sth = shift;
- my $params;
- if (@_) {
- $sth->{'f_params'} = ($params = [...@_]);
- } else {
- $params = $sth->{'f_params'};
- }
+ my $params = @_ ? ($sth->{f_params} = [ @_ ]) : $sth->{f_params};
$sth->finish;
- my $stmt = $sth->{'f_stmt'};
- my $result = eval { $stmt->execute($sth, $params); };
- return $sth->set_err($DBI::stderr,$@) if $@;
- if ($stmt->{'NUM_OF_FIELDS'}) { # is a SELECT statement
- $sth->STORE(Active => 1);
- $sth->STORE('NUM_OF_FIELDS', $stmt->{'NUM_OF_FIELDS'})
- if !$sth->FETCH('NUM_OF_FIELDS');
- }
+ my $stmt = $sth->{f_stmt};
+ my $result = eval { $stmt->execute ($sth, $params); };
+ $@ and return $sth->set_err ($DBI::stderr, $@);
+
+ if ($stmt->{NUM_OF_FIELDS}) { # is a SELECT statement
+ $sth->STORE (Active => 1);
+ $sth->FETCH ("NUM_OF_FIELDS") or
+ $sth->STORE ("NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS})
+ }
return $result;
-}
-sub finish {
+ } # execute
+
+sub finish
+{
my $sth = shift;
- $sth->SUPER::STORE(Active => 0);
+ $sth->SUPER::STORE (Active => 0);
delete $sth->{f_stmt}->{data};
return 1;
-}
-sub fetch ($) {
- my $sth = shift;
+ } # finish
+
+sub fetch ($)
+{
+ my $sth = shift;
my $data = $sth->{f_stmt}->{data};
- if (!$data || ref($data) ne 'ARRAY') {
- $sth->set_err($DBI::stderr, "Attempt to fetch row without a preceeding
execute() call or from a non-SELECT statement");
- return undef;
- }
+ if (!$data || ref $data ne "ARRAY") {
+ $sth->set_err ($DBI::stderr,
+ "Attempt to fetch row without a preceeding execute () call or from
a non-SELECT statement"
+ );
+ return
+ }
my $dav = shift @$data;
- if (!$dav) {
- $sth->finish;
- return undef;
- }
- if ($sth->FETCH('ChopBlanks')) {
- map { $_ =~ s/\s+$// if $_; $_ } @$dav;
- }
- $sth->_set_fbav($dav);
-}
+ unless ($dav) {
+ $sth->finish;
+ return
+ }
+ if ($sth->FETCH ("ChopBlanks")) {
+ $_ && $_ =~ s/\s+$// for @$dav;
+ }
+ $sth->_set_fbav ($dav);
+ } # fetch
*fetchrow_arrayref = \&fetch;
-sub FETCH ($$) {
+my %unsupported_attrib = map { $_ => 1 } qw( TYPE PRECISION );
+
+sub FETCH ($$)
+{
my ($sth, $attrib) = @_;
- return undef if ($attrib eq 'TYPE'); # Workaround for a bug in DBI 0.93
- return $sth->FETCH('f_stmt')->{'NAME'} if ($attrib eq 'NAME');
- if ($attrib eq 'NULLABLE') {
- my($meta) = $sth->FETCH('f_stmt')->{'NAME'}; # Intentional !
- if (!$meta) {
- return undef;
- }
- my($names) = [];
- my($col);
- foreach $col (@$meta) {
- push(@$names, 1);
+ exists $unsupported_attrib{$attrib}
+ and return; # Workaround for a bug in DBI 0.93
+ $attrib eq "NAME" and
+ return $sth->FETCH ("f_stmt")->{NAME};
+ if ($attrib eq "NULLABLE") {
+ my ($meta) = $sth->FETCH ("f_stmt")->{NAME}; # Intentional !
+ $meta or return;
+ return [ (1) x @$meta ];
}
- return $names;
- }
- if ($attrib eq (lc $attrib)) {
+ if ($attrib eq lc $attrib) {
# Private driver attributes are lower cased
return $sth->{$attrib};
- }
+ }
# else pass up to DBI to handle
- return $sth->SUPER::FETCH($attrib);
-}
+ return $sth->SUPER::FETCH ($attrib);
+ } # FETCH
-sub STORE ($$$) {
+sub STORE ($$$)
+{
my ($sth, $attrib, $value) = @_;
- if ($attrib eq (lc $attrib)) {
+ exists $unsupported_attrib{$attrib}
+ and return; # Workaround for a bug in DBI 0.93
+ if ($attrib eq lc $attrib) {
# Private driver attributes are lower cased
$sth->{$attrib} = $value;
return 1;
- }
- return $sth->SUPER::STORE($attrib, $value);
-}
+ }
+ return $sth->SUPER::STORE ($attrib, $value);
+ } # STORE
-sub DESTROY ($) {
+sub DESTROY ($)
+{
my $sth = shift;
- $sth->finish if $sth->SUPER::FETCH('Active');
-}
-
-sub rows ($) { shift->{'f_stmt'}->{'NUM_OF_ROWS'} };
+ $sth->SUPER::FETCH ("Active") and $sth->finish;
+ } # DESTROY
+sub rows ($)
+{
+ shift->{f_stmt}->{NUM_OF_ROWS};
+ } # rows
package DBD::File::Statement;
-# We may have a working flock() built-in but that doesn't mean that locking
-# will work on NFS (flock() may hang hard)
+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()
+# Jochen's old check for flock ()
#
-# my $locking = $^O ne 'MacOS' &&
-# ($^O ne 'MSWin32' || !Win32::IsWin95()) &&
-# $^O ne 'VMS';
-
-...@dbd::File::Statement::ISA = qw(DBI::SQL::Nano::Statement);
-
-my $open_table_re =
- $haveFileSpec ?
- sprintf('(?:%s|%s|%s)',
- quotemeta(File::Spec->curdir()),
- quotemeta(File::Spec->updir()),
- quotemeta(File::Spec->rootdir()))
- : '(?:\.?\.)?\/';
-
-sub get_file_name($$$) {
- my($self,$data,$table)=...@_;
- $table =~ s/^\"//; # handle quoted identifiers
+# my $locking = $^O ne "MacOS" &&
+# ($^O ne "MSWin32" || !Win32::IsWin95 ()) &&
+# $^O ne "VMS";
+
+...@dbd::File::Statement::ISA = qw( DBI::SQL::Nano::Statement );
+
+my $open_table_re = sprintf "(?:%s|%s|%s)",
+ quotemeta (File::Spec->curdir ()),
+ quotemeta (File::Spec->updir ()),
+ quotemeta (File::Spec->rootdir ());
+
+sub get_file_name ($$$)
+{
+ my ($self, $data, $table) = @_;
+ $table =~ s/^\"//; # handle quoted identifiers
$table =~ s/\"$//;
my $file = $table;
- if ( $file !~ /^$open_table_re/o
- and $file !~ m!^[/\\]! # root
- and $file !~ m!^[a-z]\:! # drive letter
- ) {
- $file = $haveFileSpec ?
- File::Spec->catfile($data->{Database}->{'f_dir'}, $table)
- : $data->{Database}->{'f_dir'} . "/$table";
- }
- return($table,$file);
-}
+ if ( $file !~ m/^$open_table_re/o
+ and $file !~ m{^[/\\]} # root
+ and $file !~ m{^[a-z]\:} # drive letter
+ ) {
+ exists $data->{Database}{f_map}{$table} or
+ DBD::File::file2table ($data->{Database}, $data->{Database}{f_dir},
$file, 1);
+ $file = $data->{Database}{f_map}{$table} || undef;
+ }
+ return ($table, $file);
+ } # get_file_name
-sub open_table ($$$$$) {
- my($self, $data, $table, $createMode, $lockMode) = @_;
+sub open_table ($$$$$)
+{
+ my ($self, $data, $table, $createMode, $lockMode) = @_;
my $file;
- ($table,$file) = $self->get_file_name($data,$table);
+ ($table, $file) = $self->get_file_name ($data, $table);
require IO::File;
my $fh;
- my $safe_drop = 1 if $self->{ignore_missing_table};
+ my $safe_drop = $self->{ignore_missing_table} ? 1 : 0;
if ($createMode) {
- if (-f $file) {
- die "Cannot create table $table: Already exists";
- }
- if (!($fh = IO::File->new($file, "a+"))) {
- die "Cannot open $file for writing: $!";
- }
- if (!$fh->seek(0, 0)) {
- die " Error while seeking back: $!";
- }
- } else {
- if (!($fh = IO::File->new($file, ($lockMode ? "r+" : "r")))) {
- die " Cannot open $file: $!" unless $safe_drop;
+ -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: $!";
+ }
}
- }
- binmode($fh) if $fh;
+ $fh and binmode $fh;
if ($locking and $fh) {
if ($lockMode) {
- if (!flock($fh, 2)) {
- die " Cannot obtain exclusive lock on $file: $!";
+ flock $fh, 2 or
+ croak " Cannot obtain exclusive lock on $file: $!";
}
- } else {
- if (!flock($fh, 1)) {
- die "Cannot obtain shared lock on $file: $!";
+ else {
+ flock $fh, 1 or
+ croak "Cannot obtain shared lock on $file: $!";
}
}
- }
my $columns = {};
- my $array = [];
- my $pos = $fh->tell() if $fh;
- my $tbl = {
- file => $file,
- fh => $fh,
- col_nums => $columns,
- col_names => $array,
+ my $array = [];
+ my $pos = $fh ? $fh->tell () : undef;
+ my $tbl = {
+ file => $file,
+ fh => $fh,
+ col_nums => $columns,
+ col_names => $array,
first_row_pos => $pos,
- };
- my $class = ref($self);
+ };
+ my $class = ref $self;
$class =~ s/::Statement/::Table/;
- bless($tbl, $class);
+ bless $tbl, $class;
$tbl;
-}
-
+ } # open_table
package DBD::File::Table;
+use strict;
+use Carp;
+
@DBD::File::Table::ISA = qw(DBI::SQL::Nano::Table);
-sub drop ($) {
- my($self) = @_;
+sub drop ($)
+{
+ my $self = shift;
# We have to close the file before unlinking it: Some OS'es will
# refuse the unlink otherwise.
- $self->{'fh'}->close() if $self->{fh};
- unlink($self->{'file'});
+ $self->{fh} and $self->{fh}->close ();
+ unlink $self->{file};
return 1;
-}
+ } # drop
-sub seek ($$$$) {
- my($self, $data, $pos, $whence) = @_;
- if ($whence == 0 && $pos == 0) {
- $pos = $self->{'first_row_pos'};
- } elsif ($whence != 2 || $pos != 0) {
- die "Illegal seek position: pos = $pos, whence = $whence";
- }
- if (!$self->{'fh'}->seek($pos, $whence)) {
- die "Error while seeking in " . $self->{'file'} . ": $!";
- }
-}
+sub seek ($$$$)
+{
+ my ($self, $data, $pos, $whence) = @_;
+ if ($whence == 0 && $pos == 0) {
+ $pos = $self->{first_row_pos};
+ }
+ elsif ($whence != 2 || $pos != 0) {
+ croak "Illegal seek position: pos = $pos, whence = $whence";
+ }
-sub truncate ($$) {
- my($self, $data) = @_;
- if (!$self->{'fh'}->truncate($self->{'fh'}->tell())) {
- die "Error while truncating " . $self->{'file'} . ": $!";
- }
+ $self->{fh}->seek ($pos, $whence) or
+ croak "Error while seeking in " . $self->{file} . ": $!";
+ } # seek
+
+sub truncate ($$)
+{
+ my ($self, $data) = @_;
+ $self->{fh}->truncate ($self->{fh}->tell ()) or
+ croak "Error while truncating " . $self->{file} . ": $!";
1;
-}
+ } # truncate
1;
-
__END__
=head1 NAME
@@ -735,8 +847,25 @@
opened. Usually you set it in the dbh, it defaults to the current
directory ("."). However, it is overwritable in the statement handles.
-=back
+=item f_ext
+
+This attribute is used for setting the file extension where (CSV) files are
+opened. There are several possibilities.
+
+ DBI:CSV:f_dir=data;f_ext=.csv
+
+In this case, DBD::File will open only C<table.csv> if both C<table.csv> and
+C<table> exist in the datadir. The table will still be named C<table>. If
+your datadir has files with extensions, and you do not pass this attribute,
+your table is named C<table.csv>, which is probably not what you wanted. The
+extension is always case-insensitive. The table names are not.
+
+ DBI:CSV:f_dir=data;f_ext=.csv/r
+In this case the extension is required, and all filenames that do not match
+are ignored.
+
+=back
=head2 Driver private methods
@@ -749,16 +878,16 @@
If you want to read the subdirectories of another directory, use
- my($drh) = DBI->install_driver("CSV");
- my(@list) = $drh->data_sources('f_dir' => '/usr/local/csv_data' );
+ my ($drh) = DBI->install_driver ("CSV");
+ my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data" );
=item list_tables
-This method returns a list of file names inside $dbh->{'f_dir'}.
+This method returns a list of file names inside $dbh->{f_dir}.
Example:
- my($dbh) = DBI->connect("DBI:CSV:f_dir=/usr/local/csv_data");
- my(@list) = $dbh->func('list_tables');
+ my ($dbh) = DBI->connect ("DBI:CSV:f_dir=/usr/local/csv_data");
+ my (@list) = $dbh->func ("list_tables");
Note that the list includes all files contained in the directory, even
those that have non-valid table names, from the view of SQL.
@@ -771,33 +900,36 @@
=item *
-The module is using flock() internally. However, this function is not
-available on all platforms. Using flock() is disabled on MacOS and
+The module is using flock () internally. However, this function is not
+available on all platforms. Using flock () is disabled on MacOS and
Windows 95: There's no locking at all (perhaps not so important on
MacOS and Windows 95, as there's a single user anyways).
=back
-
-=head1 AUTHOR AND COPYRIGHT
+=head1 AUTHOR
This module is currently maintained by
-Jeff Zucker < jzucker @ cpan.org >
+H.Merijn Brand < h.m.brand at xs4all.nl > and
+Jens Rehsack < rehsack at googlemail.com >
The original author is Jochen Wiedmann.
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by H.Merijn Brand & Jens Rehsack
Copyright (C) 2004 by Jeff Zucker
Copyright (C) 1998 by Jochen Wiedmann
All rights reserved.
-You may freely distribute and/or modify this module under the terms of either
the GNU General Public License (GPL) or the Artistic License, as specified in
-the Perl README file.
+You may freely distribute and/or modify this module under the terms of
+either the GNU General Public License (GPL) or the Artistic License, as
+specified in the Perl README file.
=head1 SEE ALSO
-L<DBI>, L<Text::CSV_XS>, L<SQL::Statement>
-
+L<DBI>, L<Text::CSV>, L<Text::CSV_XS>, L<SQL::Statement>
=cut
