Author: timbo
Date: Wed Feb 25 15:43:12 2004
New Revision: 159
Added:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
dbi/trunk/lib/DBI/SQL/
dbi/trunk/lib/DBI/SQL/Nano.pm
dbi/trunk/t/50dbm.t (contents, props changed)
Modified:
dbi/trunk/Changes
dbi/trunk/MANIFEST
Log:
Major additions that Jeff Zucker and I have been working on:
Added DBI::SQL::Nano a 'smaller than micro' SQL parser
with an SQL::Statement compatible API. If SQL::Statement
is installed then DBI::SQL::Nano becomes an empty subclass
of SQL::Statement, unless the DBI_SQL_NANO env var is true.
Added DBD::File, modified to use DBI::SQL::Nano.
Added DBD::DBM that provides an SQL interface to DBM files.
They need more docs, of course, but that's in the works.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Wed Feb 25 15:43:12 2004
@@ -23,6 +23,15 @@
trace flags into the corresponding trace flag bits:
$h->{TraceLevel} = $h->trace_flags("foo,SQL,7");
+ Major additions that Jeff Zucker and I have been working on:
+
+ Added DBI::SQL::Nano a 'smaller than micro' SQL parser
+ with an SQL::Statement compatible API. If SQL::Statement
+ is installed then DBI::SQL::Nano becomes an empty subclass
+ of SQL::Statement, unless the DBI_SQL_NANO env var is true.
+ Added DBD::File, modified to use DBI::SQL::Nano.
+ Added DBD::DBM that provides an SQL interface to DBM files.
+
=head1 CHANGES in DBI 1.41 (svn rev 130), 22nd February 2004
Fixed execute_for_array() so tuple_status parameter is optional
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Wed Feb 25 15:43:12 2004
@@ -19,6 +19,8 @@
lib/Bundle/DBI.pm A bundle for automatic installation via CPAN.
lib/DBD/ExampleP.pm A very simple example Driver module
lib/DBD/NullP.pm An empty example Driver module
+lib/DBD/File.pm A driver base class for simple drivers
+lib/DBD/DBM.pm A driver for DBM files (uses DBD::File)
lib/DBD/Proxy.pm Proxy driver
lib/DBD/Sponge.pm A driver for fake cursors (precached data)
lib/DBI/Const/GetInfo/ANSI.pm GetInfo data based on ANSI standard
@@ -52,6 +54,7 @@
t/40profile.t
t/41prof_dump.t
t/42prof_data.t
+t/50dbm.t
t/60preparse.t
t/80proxy.t
test.pl A very simple test harness using ExampleP.pm
Added: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/DBM.pm Wed Feb 25 15:43:12 2004
@@ -0,0 +1,187 @@
+#######################################################################
+#
+# DBD::DBM - a simple DBI driver for DBM files
+#
+# Copyright (C) 2004 by Jeff Zucker < jzucker AT cpan.org >
+#
+# 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.005_03;
+use strict;
+
+package DBD::DBM;
+
+use DBD::File ();
+use vars qw($VERSION $ATTRIBUTION);
+use base qw( DBD::File );
+
+$VERSION = "0.01";
+$ATTRIBUTION = "DBD::DBM by Jeff Zucker";
+
+package DBD::DBM::dr;
+$DBD::DBM::dr::imp_data_size = 0;
[EMAIL PROTECTED]::DBM::dr::ISA = qw(DBD::File::dr);
+
+package DBD::DBM::db;
+$DBD::DBM::db::imp_data_size = 0;
[EMAIL PROTECTED]::DBM::db::ISA = qw(DBD::File::db);
+
+package DBD::DBM::st;
+$DBD::DBM::st::imp_data_size = 0;
[EMAIL PROTECTED]::DBM::st::ISA = qw(DBD::File::st);
+
+package DBD::DBM::Statement;
+use base qw( DBD::File::Statement );
+
+use Fcntl;
+# AnyDBM_File defaults ISA to (NDBM_File DB_File GDBM_File SDBM_File ODBM_File)
+# ideally we'd prefer DB_File but we don't want to mess with @ISA ourselves
+# because the application using us may have already changed it
+use AnyDBM_File;
+
+sub open_table ($$$$$) {
+ # NEED TO ADD FILE LOCKING
+ my($self, $data, $table, $createMode, $lockMode) = @_;
+ my $dbh = $data->{Database};
+ my $file = $table || $self->{tables}->[0]->{name};
+ my $open_mode = O_RDONLY;
+ $open_mode = O_RDWR if $lockMode;
+ $open_mode = O_RDWR|O_CREAT|O_TRUNC if $createMode;
+ my %h;
+ die "Cannot CREATE '$file', already exists!"
+ if $createMode and (-e "$file.pag" or -e "$file.dir");
+ my $dbm_type = $dbh->{dbm_type} || 'AnyDBM_File';
+ if ($dbm_type ne 'AnyDBM_File') {
+ require "$dbm_type.pm";
+ $dbh->STORE(dbm_type => $dbm_type);
+ }
+ eval { tie(%h, $dbm_type, $file, $open_mode, 0666) };
+ die "Cannot tie file '$file': $@" if $@;
+ my $tbl = {
+ file => $file,
+ hash => \%h,
+ col_nums => {dkey=>0,dval=>1},
+ col_names => ['dkey','dval'],
+ };
+ my $class = ref($self);
+ $class =~ s/::Statement/::Table/;
+ bless($tbl, $class);
+ $tbl;
+}
+
+# DELETE is only needed for backward compat with old SQL::Statement
+# can remove when next SQL::Statement is released
+sub DELETE ($$$) {
+ my($self, $data, $params) = @_;
+ my $dbh = $data->{Database};
+ my($table,$tname,@where_args);
+ if ($dbh->{Driver}->{statement_version}) {
+ my($eval,$all_cols) = $self->open_tables($data, 0, 1);
+ return undef unless $eval;
+ $eval->params($params);
+ $self->verify_columns($eval, $all_cols);
+ $table = $eval->table($self->tables(0)->name());
+ @where_args = ($eval,$self->tables(0)->name());
+ }
+ else {
+ $table = $self->open_tables($data, 0, 1);
+ @where_args = ($table);
+ }
+ my($affected) = 0;
+ while (my $array = $table->fetch_row($data)) {
+ if ($self->eval_where(@where_args,$array)) {
+ ++$affected;
+ $table->delete_one_row($data,$array);
+ }
+ }
+ return ($affected, 0);
+}
+
+package DBD::DBM::Table;
+use base qw( DBD::File::Table );
+
+sub drop ($$) {
+ my($self,$data) = @_;
+ untie %{$self->{hash}} if $self->{hash};
+ unlink $self->{file}.'.dir' if -f $self->{file}.'.dir';
+ unlink $self->{file}.'.pag' if -f $self->{file}.'.pag';
+ unlink $self->{file}.'.db' if -f $self->{file}.'.db'; # Berzerkeley
+ # put code to delete lockfile here
+ return 1;
+}
+sub fetch_row ($$$) {
+ my($self, $data, $row) = @_;
+ my @ary = each %{$self->{hash}};
+ return undef unless defined $ary[0];
+ return @ary if wantarray;
+ return [EMAIL PROTECTED];
+}
+sub push_row ($$$) {
+ my($self, $data, $row_aryref) = @_;
+ $self->{hash}->{$row_aryref->[0]}=$row_aryref->[1];
+ 1;
+}
+# optimized for hash-lookup, fetches without looping
+sub fetch_one_row {
+ my($self,$key_only,$value) = @_;
+ return $self->{col_names}->[0] if $key_only;
+ return $self->{hash}->{$value};
+}
+# "delete_one_row" seems to work within the each loop through the hash
+# "update_one_row" does not
+sub delete_one_row {
+ my($self,$data,$aryref) = @_;
+ delete $self->{hash}->{$aryref->[0]};
+}
+sub DESTROY {
+ # code to release lock goes here
+}
+sub truncate {}
+sub seek {}
+sub push_names { 1; }
+1;
+__END__
+
+=head1 NAME
+
+DBD::DBM - simple DBI driver for DBM files
+
+=head1 SYNOPSIS
+
+ use DBI;
+ $dbh = DBI->connect("DBI:DBM:", undef, undef);
+ $dbh = DBI->connect("DBI:DBM:", undef, undef, { dbm_type => 'ODBM_File' });
+ $dbh = DBI->connect("DBI:DBM(dbm_type=ODBM_File):", undef, undef);
+
+=head1 DESCRIPTION
+
+See L<DBI(3)> for details on DBI, L<SQL::Statement(3)> for details on
+SQL::Statement and L<DBD::CSV(3)> or L<DBD::IniFile(3)> for example
+drivers.
+
+=head1 AUTHOR AND COPYRIGHT
+
+This module was written and maintained by
+
+ Jeff Zucker
+ <[EMAIL PROTECTED]>
+
+Copyright (C) 2004 by Jeff Zucker
+
+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.
+
+=head1 SEE ALSO
+
+L<DBI(3)>
+
+=cut
+
Added: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/File.pm Wed Feb 25 15:43:12 2004
@@ -0,0 +1,755 @@
+# -*- perl -*-
+#
+# DBD::File - A base class for implementing DBI drivers that
+# act on plain files
+#
+# This module is currently maintained by
+#
+# Jeff Zucker < jeff AT cpan.org >
+#
+# The original author is Jochen Wiedmann.
+#
+# 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.004;
+use strict;
+
+
+require DynaLoader;
+require DBI::SQL::Nano;
+require DBI;
+my $haveFileSpec = eval { require File::Spec };
+
+package DBD::File;
+
+use vars qw(@ISA $VERSION $drh $err $errstr $sqlstate);
+
[EMAIL PROTECTED] = qw(DynaLoader);
+
+$VERSION = '0.23'; #
+
+$err = 0; # holds error code for DBI::err
+$errstr = ""; # holds error string for DBI::errstr
+$sqlstate = ""; # holds error state for DBI::state
+$drh = undef; # holds driver handle once initialised
+
+sub driver ($;$) {
+ my($class, $attr) = @_;
+ my $drh = eval '$' . $class . "::drh";
+ if (!$drh) {
+ if (!$attr) { $attr = {} };
+ if (!exists($attr->{Attribution})) {
+ $attr->{Attribution} = eval '$' . $class . '::ATTRIBUTION';
+ $attr->{Attribution} = "$class by Jeff Zucker"
+ if $class eq 'DBD::File';
+ $attr->{Attribution} ||=
+ "oops the author of $class forgot to define this";
+ }
+ if (!exists($attr->{Version})) {
+ $attr->{Version} = eval '$' . $class . '::VERSION';
+ }
+ if (!exists($attr->{Err})) {
+ $attr->{Err} = eval '\$' . $class . '::err';
+ }
+ if (!exists($attr->{Errstr})) {
+ $attr->{Errstr} = eval '\$' . $class . '::errstr';
+ }
+ if (!exists($attr->{State})) {
+ $attr->{State} = eval '\$' . $class . '::state';
+ }
+ if (!exists($attr->{Name})) {
+ my $c = $class;
+ $c =~ s/^DBD\:\://;
+ $attr->{Name} = $c;
+ }
+ $attr->{file_version} = $DBD::File::VERSION;
+ for (qw( nano_version statement_version)) {
+ $attr->{$_} = $DBI::SQL::Nano::versions->{$_}||'';
+ }
+ $drh = DBI::_new_drh($class . "::dr", $attr);
+ }
+ $drh;
+}
+
+
+package DBD::File::dr; # ====== DRIVER ======
+
+$DBD::File::dr::imp_data_size = 0;
+
+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,
+ });
+
+ if ($this) {
+ my($var, $val);
+ $this->{f_dir} = $haveFileSpec ? File::Spec->curdir() : '.';
+ while (length($dbname)) {
+ if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) {
+ $var = $1;
+ } else {
+ $var = $dbname;
+ $dbname = '';
+ }
+ if ($var =~ /^(.+?)=(.*)/s) {
+ $var = $1;
+ ($val = $2) =~ s/\\(.)/$1/g;
+ $this->{$var} = $val;
+ }
+ }
+ }
+ $this;
+}
+
+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)) {
+ DBI::set_err($drh, 1, "Cannot open directory $dir");
+ return undef;
+ }
+ my($file, @dsns, %names, $driver);
+ if ($drh->{'ImplementorClass'} =~ /^dbd\:\:([^\:]+)\:\:/i) {
+ $driver = $1;
+ } else {
+ $driver = 'File';
+ }
+ while (defined($file = readdir($dirh))) {
+ my $d = $haveFileSpec ?
+ File::Spec->catdir($dir, $file) : "$dir/$file";
+ if ($file ne ($haveFileSpec ? File::Spec->curdir() : '.')
+ and $file ne ($haveFileSpec ? File::Spec->updir() : '..')
+ and -d $d) {
+ push(@dsns, "DBI:$driver:f_dir=$d");
+ }
+ }
+ @dsns;
+}
+
+sub disconnect_all {
+}
+
+sub DESTROY {
+ undef;
+}
+
+
+package DBD::File::db; # ====== DATABASE ======
+
+$DBD::File::db::imp_data_size = 0;
+
+
+sub prepare ($$;@) {
+ my($dbh, $statement, @attribs)= @_;
+
+ # create a 'blank' dbh
+ my $sth = DBI::_new_sth($dbh, {'Statement' => $statement});
+
+ if ($sth) {
+ $@ = '';
+ my $class = $sth->FETCH('ImplementorClass');
+ $class =~ s/::st$/::Statement/;
+ 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
+
+ my $sversion = $SQL::Statement::VERSION;
+ if ($sversion and $SQL::Statement::VERSION > 1) {
+ my $parser = $dbh->{csv_sql_parser_object};
+ eval { $parser ||= $dbh->func('csv_cache_sql_parser_object') };
+ if ($@) {
+ undef $@;
+ $stmt = eval { $class->new($statement) };
+ }
+ else {
+ $stmt = eval { $class->new($statement,$parser) };
+ }
+ }
+ else {
+ $stmt = eval { $class->new($statement) };
+ }
+ if ($@) {
+ DBI::set_err($dbh, 1, $@);
+ undef $sth;
+ } else {
+ $sth->STORE('f_stmt', $stmt);
+ $sth->STORE('f_params', []);
+ $sth->STORE('NUM_OF_PARAMS', scalar($stmt->params()));
+ }
+ }
+
+ $sth;
+}
+
+sub disconnect ($) {
+ 1;
+}
+
+sub FETCH ($$) {
+ my ($dbh, $attrib) = @_;
+ if ($attrib eq 'AutoCommit') {
+ return 1;
+ } elsif ($attrib eq (lc $attrib)) {
+ # Driver private attributes are lower cased
+ return $dbh->{$attrib};
+ }
+ # else pass up to DBI to handle
+ return $dbh->DBD::_::db::FETCH($attrib);
+}
+
+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)) {
+ # Driver private attributes are lower cased
+ $dbh->{$attrib} = $value;
+ return 1;
+ }
+ return $dbh->DBD::_::db::STORE($attrib, $value);
+}
+
+sub DESTROY ($) {
+ 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
+ ]
+ ]
+}
+
+
+{
+ 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)) {
+ DBI::set_err($dbh, 1, "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)) {
+ DBI::set_err($dbh, 1, "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) {
+ DBI::set_err($dbh, 1, $DBI::errstr);
+ return undef;
+ }
+ }
+
+ # Temporary kludge: DBD::Sponge dies if @tables is empty. :-(
+ return undef if [EMAIL PROTECTED];
+
+ my $sth = $dbh2->prepare("TABLE_INFO", { 'rows' => [EMAIL PROTECTED],
+ 'NAMES' => $names });
+ if (!$sth) {
+ DBI::set_err($dbh, 1, $dbh2->errstr());
+ }
+ $sth;
+ }
+}
+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]);
+ }
+ @tables;
+}
+
+sub quote ($$;$) {
+ my($self, $str, $type) = @_;
+ 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::TINYINT())) {
+ return $str;
+ }
+ if (!defined($str)) { return "NULL" }
+ $str =~ s/\\/\\\\/sg;
+ $str =~ s/\0/\\0/sg;
+ $str =~ s/\'/\\\'/sg;
+ $str =~ s/\n/\\n/sg;
+ $str =~ s/\r/\\r/sg;
+ "'$str'";
+}
+
+sub commit ($) {
+ my($dbh) = shift;
+ if ($dbh->FETCH('Warn')) {
+ warn("Commit ineffective while AutoCommit is on", -1);
+ }
+ 1;
+}
+
+sub rollback ($) {
+ my($dbh) = shift;
+ if ($dbh->FETCH('Warn')) {
+ warn("Rollback ineffective while AutoCommit is on", -1);
+ }
+ 0;
+}
+
+
+package DBD::File::st; # ====== STATEMENT ======
+
+$DBD::File::st::imp_data_size = 0;
+
+sub bind_param ($$$;$) {
+ my($sth, $pNum, $val, $attr) = @_;
+ $sth->{f_params}->[$pNum-1] = $val;
+ 1;
+}
+
+sub execute {
+ my $sth = shift;
+ my $params;
+ if (@_) {
+ $sth->{'f_params'} = ($params = [EMAIL PROTECTED]);
+ } else {
+ $params = $sth->{'f_params'};
+ }
+ my $stmt = $sth->{'f_stmt'};
+ my $result = eval { $stmt->execute($sth, $params); };
+ return $sth->set_err(1,$@) if $@;
+ if ($stmt->{'NUM_OF_FIELDS'} && !$sth->FETCH('NUM_OF_FIELDS')) {
+ $sth->STORE('NUM_OF_FIELDS', $stmt->{'NUM_OF_FIELDS'});
+ }
+ return $result;
+}
+
+sub fetch ($) {
+ my $sth = shift;
+ my $data = $sth->{f_stmt}->{data};
+ if (!$data || ref($data) ne 'ARRAY') {
+ DBI::set_err($sth, 1,
+ "Attempt to fetch row from a Non-SELECT statement");
+ return undef;
+ }
+ my $dav = shift @$data;
+ if (!$dav) {
+ return undef;
+ }
+ if ($sth->FETCH('ChopBlanks')) {
+ map { $_ =~ s/\s+$//; } @$dav;
+ }
+ $sth->_set_fbav($dav);
+}
+*fetchrow_arrayref = \&fetch;
+
+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);
+ }
+ return $names;
+ }
+ if ($attrib eq (lc $attrib)) {
+ # Private driver attributes are lower cased
+ return $sth->{$attrib};
+ }
+ # else pass up to DBI to handle
+ return $sth->DBD::_::st::FETCH($attrib);
+}
+
+sub STORE ($$$) {
+ my ($sth, $attrib, $value) = @_;
+ if ($attrib eq (lc $attrib)) {
+ # Private driver attributes are lower cased
+ $sth->{$attrib} = $value;
+ return 1;
+ }
+ return $sth->DBD::_::st::STORE($attrib, $value);
+}
+
+sub DESTROY ($) {
+ undef;
+}
+
+sub rows ($) { shift->{'f_stmt'}->{'NUM_OF_ROWS'} };
+
+sub finish ($) { 1; }
+
+
+package DBD::File::Statement;
+
+my $locking = $^O ne 'MacOS' &&
+ ($^O ne 'MSWin32' || !Win32::IsWin95()) &&
+ $^O ne 'VMS';
+
[EMAIL PROTECTED]::File::Statement::ISA = qw(DBI::SQL::Nano::Statement);
+
+sub set_err {
+ my($handle,$errmsg,$state);
+ $handle->set_err($errmsg,$state);
+ die $errmsg;
+}
+
+my $open_table_re =
+ $haveFileSpec ?
+ sprintf('(?:%s|%s�%s)',
+ quotemeta(File::Spec->curdir()),
+ quotemeta(File::Spec->updir()),
+ quotemeta(File::Spec->rootdir()))
+ : '(?:\.?\.)?\/';
+sub open_table ($$$$$) {
+ my($self, $data, $table, $createMode, $lockMode) = @_;
+ my $file = $table;
+ if ($file !~ /^$open_table_re/o) {
+ $file = $haveFileSpec ?
+ File::Spec->catfile($data->{Database}->{'f_dir'}, $table)
+ : $data->{Database}->{'f_dir'} . "/$table";
+ }
+ my $fh;
+ 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: $!";
+ }
+ }
+ binmode($fh);
+ if ($locking) {
+ if ($lockMode) {
+ if (!flock($fh, 2)) {
+ die " Cannot obtain exclusive lock on $file: $!";
+ }
+ } else {
+ if (!flock($fh, 1)) {
+ die "Cannot obtain shared lock on $file: $!";
+ }
+ }
+ }
+ my $columns = {};
+ my $array = [];
+ my $tbl = {
+ file => $file,
+ fh => $fh,
+ col_nums => $columns,
+ col_names => $array,
+ first_row_pos => $fh->tell()
+ };
+ my $class = ref($self);
+ $class =~ s/::Statement/::Table/;
+ bless($tbl, $class);
+ $tbl;
+}
+
+
+package DBD::File::Table;
+
[EMAIL PROTECTED]::File::Table::ISA = qw(DBI::SQL::Nano::Table);
+
+sub drop ($) {
+ my($self) = @_;
+ # We have to close the file before unlinking it: Some OS'es will
+ # refuse the unlink otherwise.
+ $self->{'fh'}->close();
+ unlink($self->{'file'});
+ return 1;
+}
+
+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 truncate ($$) {
+ my($self, $data) = @_;
+ if (!$self->{'fh'}->truncate($self->{'fh'}->tell())) {
+ die "Error while truncating " . $self->{'file'} . ": $!";
+ }
+ 1;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+DBD::File - Base class for writing DBI drivers for plain files
+
+=head1 SYNOPSIS
+
+ use DBI;
+ $dbh = DBI->connect("DBI:File:f_dir=/home/joe/csvdb")
+ or die "Cannot connect: " . $DBI::errstr;
+ $sth = $dbh->prepare("CREATE TABLE a (id INTEGER, name CHAR(10))")
+ or die "Cannot prepare: " . $dbh->errstr();
+ $sth->execute() or die "Cannot execute: " . $sth->errstr();
+ $sth->finish();
+ $dbh->disconnect();
+
+=head1 DESCRIPTION
+
+The DBD::File module is not a true DBI driver, but an abstract
+base class for deriving concrete DBI drivers from it. The implication is,
+that these drivers work with plain files, for example CSV files or
+INI files. The module is based on the SQL::Statement module, a simple
+SQL engine.
+
+See L<DBI(3)> for details on DBI, L<SQL::Statement(3)> for details on
+SQL::Statement and L<DBD::CSV(3)> or L<DBD::IniFile(3)> for example
+drivers.
+
+
+=head2 Metadata
+
+The following attributes are handled by DBI itself and not by DBD::File,
+thus they all work like expected:
+
+ Active
+ ActiveKids
+ CachedKids
+ CompatMode (Not used)
+ InactiveDestroy
+ Kids
+ PrintError
+ RaiseError
+ Warn (Not used)
+
+The following DBI attributes are handled by DBD::File:
+
+=over 4
+
+=item AutoCommit
+
+Always on
+
+=item ChopBlanks
+
+Works
+
+=item NUM_OF_FIELDS
+
+Valid after C<$sth->execute>
+
+=item NUM_OF_PARAMS
+
+Valid after C<$sth->prepare>
+
+=item NAME
+
+Valid after C<$sth->execute>; undef for Non-Select statements.
+
+=item NULLABLE
+
+Not really working, always returns an array ref of one's, as DBD::CSV
+doesn't verify input data. Valid after C<$sth->execute>; undef for
+Non-Select statements.
+
+=back
+
+These attributes and methods are not supported:
+
+ bind_param_inout
+ CursorName
+ LongReadLen
+ LongTruncOk
+
+Additional to the DBI attributes, you can use the following dbh
+attribute:
+
+=over 4
+
+=item f_dir
+
+This attribute is used for setting the directory where CSV files are
+opened. Usually you set it in the dbh, it defaults to the current
+directory ("."). However, it is overwritable in the statement handles.
+
+=back
+
+
+=head2 Driver private methods
+
+=over 4
+
+=item data_sources
+
+The C<data_sources> method returns a list of subdirectories of the current
+directory in the form "DBI:CSV:f_dir=$dirname".
+
+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' );
+
+=item list_tables
+
+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');
+
+Note that the list includes all files contained in the directory, even
+those that have non-valid table names, from the view of SQL. See
+L<Creating and dropping tables> above.
+
+=back
+
+
+=head1 TODO
+
+=over 4
+
+=item Joins
+
+The current version of the module works with single table SELECT's
+only, although the basic design of the SQL::Statement module allows
+joins and the likes.
+
+=item Table name mapping
+
+Currently it is not possible to use files with names like C<names.csv>.
+Instead you have to use soft links or rename files. As an alternative
+one might use, for example a dbh attribute 'table_map'. It might be a
+hash ref, the keys being the table names and the values being the file
+names.
+
+=back
+
+
+=head1 KNOWN BUGS
+
+=over 8
+
+=item *
+
+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
+
+This module is currently maintained by
+
+ Jeff Zucker
+ <[EMAIL PROTECTED]>
+
+The original author is Jochen Wiedmann.
+
+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.
+
+=head1 SEE ALSO
+
+L<DBI(3)>, L<Text::CSV_XS(3)>, L<SQL::Statement(3)>
+
+
+=cut
Added: dbi/trunk/lib/DBI/SQL/Nano.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/SQL/Nano.pm Wed Feb 25 15:43:12 2004
@@ -0,0 +1,491 @@
+package DBI::SQL::Nano;
+
+use strict;
+use warnings;
+use vars qw( $VERSION $versions );
+
+BEGIN {
+ $VERSION = '0.01';
+ $versions->{nano_version} = $VERSION;
+ eval { require "SQL/Statement.pm" } unless $ENV{DBI_SQL_NANO};
+ if ($@ or $ENV{DBI_SQL_NANO}) {
+ @DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
+ @DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_);
+ }
+ else {
+ @DBI::SQL::Nano::Statement::ISA = qw(SQL::Statement);
+ @DBI::SQL::Nano::Table::ISA = qw(SQL::Eval::Table);
+ $versions->{statement_version} = $SQL::Statement::VERSION;
+ }
+}
+
+package DBI::SQL::Nano::Statement_;
+use vars qw($numexp);
+# XXX change to DBI::looks_like_number?
+$numexp= qr/^([+-]?|\s+)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+sub new {
+ my($class,$sql) = @_;
+ my $self = {};
+ bless $self, $class;
+ return $self->prepare($sql);
+}
+
+#####################################################################
+# PREPARE
+#####################################################################
+sub prepare {
+ my($self,$sql) = @_;
+ for ($sql) {
+ /^\s*CREATE\s+TABLE\s+(.*?)\s*\((.+)\)\s*$/is
+ &&do{
+ $self->{command} = 'CREATE';
+ $self->{table_name} = $1;
+ $self->{column_names} = parse_comma_list($2) if $2;
+ };
+ /^\s*DROP\s+TABLE\s+(.*?)\s*$/is
+ &&do{
+ $self->{command} = 'DROP';
+ $self->{table_name} = $1;
+ };
+ /^\s*SELECT\s+(.*?)\s+FROM\s+(\w+)(\s+WHERE\s+(.*))?/is
+ &&do{
+ $self->{command} = 'SELECT';
+ $self->{column_names} = parse_comma_list($1) if $1;
+ $self->{table_name} = $2;
+ $self->{where_clause} = $self->parse_where_clause($4) if $4;
+ };
+ /^\s*INSERT\s+INTO\s+(\w+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is
+ &&do{
+ $self->{command} = 'INSERT';
+ $self->{table_name} = $1;
+ $self->{column_names} = parse_comma_list($2) if $2;
+ $self->{values} = $self->parse_values_list($4) if $4;
+ };
+ /DELETE\s+FROM\s+(\w+)(\s+WHERE\s+(.*))?/is
+ &&do{
+ $self->{command} = 'DELETE';
+ $self->{table_name} = $1;
+ $self->{where_clause} = $self->parse_where_clause($3) if $3;
+ };
+ /UPDATE\s+(\w+)\s+SET\s+(.+)WHERE\s+(.+)/is
+ &&do{
+ $self->{command} = 'UPDATE';
+ $self->{table_name} = $1;
+ $self->parse_set_clause($2) if $2;
+ $self->{where_clause} = $self->parse_where_clause($3) if $3;
+ };
+ }
+ return undef unless $self->{command} and $self->{table_name};
+ $self->{NAME} = $self->{column_names};
+ return $self;
+}
+sub parse_comma_list {[map{clean_parse_str($_)} split(',',shift)]}
+sub clean_parse_str {
+ $_ = shift; s/\(//;s/\)//;s/^\s+//; s/\s+$//; s/^(\S+)\s*.*/$1/; $_;
+}
+sub parse_values_list {
+ my($self,$str) = @_;
+ [map{$self->parse_value(clean_parse_str($_))}split(',',$str)]
+}
+sub parse_set_clause {
+ my $self = shift;
+ my @cols = split /,/, shift;
+ my $set_clause;
+ for my $col(@cols) {
+ my($col_name,$value)= $col =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/s;
+ push @{$self->{column_names}}, $col_name;
+ push @{$self->{values}}, $self->parse_value($value);
+ }
+}
+sub parse_value {
+ my($self,$str) = @_;
+ if ($str =~ /^\?$/) {
+ push @{$self->{params}},'?';
+ return { value=>'?' ,type=> 'placeholder' };
+ }
+ return { value=>undef,type=> 'NULL' } if $str =~ /^NULL$/i;
+ return { value=>$1 ,type=> 'string' } if $str =~ /^'(.+)'$/s;
+ return { value=>$str ,type=> 'number' } if $str =~ $numexp;
+ return { value=>$str ,type=> 'column' };
+}
+sub parse_where_clause {
+ my($self,$str) = @_;
+ $str =~ s/\s+$//;
+ my($neg) = $str =~ s/^\s*(NOT)\s+//is;
+ my $opexp = '=|<>|<=|>=|<|>|LIKE|CLIKE|IS';
+ my($val1,$op,$val2) = $str =~ /(\S+?)\s*($opexp)\s*(\S+)/is;
+ #die "<$val1> <$op> <$val2>";
+ return {
+ arg1 => $self->parse_value($val1),
+ arg2 => $self->parse_value($val2),
+ op => $op,
+ neg => $neg,
+ }
+}
+#####################################################################
+# EXECUTE
+#####################################################################
+sub execute {
+ my($self, $data, $params) = @_;
+ my $num_placeholders = $self->params;
+ my $num_params = scalar @$params || 0;
+ die "Number of params '$num_params' does not match "
+ . "number of placeholders '$num_placeholders'!\n"
+ unless $num_placeholders == $num_params;
+ if (scalar @$params) {
+ for my $i(0..$#{$self->{values}}) {
+ if ($self->{values}->[$i]->{type} eq 'placeholder') {
+ $self->{values}->[$i]->{value} = shift @$params;
+ }
+ }
+ if ($self->{where_clause}) {
+ if ($self->{where_clause}->{arg1}->{type} eq 'placeholder') {
+ $self->{where_clause}->{arg1}->{value} = shift @$params;
+ }
+ if ($self->{where_clause}->{arg2}->{type} eq 'placeholder') {
+ $self->{where_clause}->{arg2}->{value} = shift @$params;
+ }
+ }
+ }
+ my $command = $self->{command};
+ ( $self->{'NUM_OF_ROWS'},
+ $self->{'NUM_OF_FIELDS'},
+ $self->{'data'},
+ ) = $self->$command($data, $params);
+ $self->{'NUM_OF_ROWS'} || '0E0';
+}
+sub DROP ($$$) {
+ my($self, $data, $params) = @_;
+ my $tbl_obj = { file => $self->{table_name} };
+ my $class = ref($self);
+ $class =~ s/::Statement/::Table/;
+ bless($tbl_obj, $class);
+ $self->{tbl_obj} = $tbl_obj;
+ eval { $tbl_obj->drop($data); };
+ (-1, 0);
+}
+sub CREATE ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 1, 1);
+ $table->push_names($data, $self->{column_names});
+ (0, 0);
+}
+sub INSERT ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 1);
+ $table->seek($data, 0, 2);
+ my($array) = [];
+ my($val, $col, $i);
+ $self->{column_names}=$table->{col_names} unless $self->{column_names};
+ my $cNum = scalar(@{$self->{column_names}}) if $self->{column_names};
+ my $param_num = 0;
+ if ($cNum) {
+ for ($i = 0; $i < $cNum; $i++) {
+ $col = $self->{column_names}->[$i];
+ $array->[$self->column_nums($table,$col)] = $self->row_values($i);
+ }
+ } else {
+ die "Bad col names in INSERT";
+ }
+ $table->push_row($data, $array);
+ (1, 0);
+}
+sub DELETE ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 1);
+ my($affected) = 0;
+ my(@rows, $array);
+ if ( $table->can('delete_one_row') ) {
+ while (my $array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ ++$affected;
+ $table->delete_one_row($data,$array);
+ }
+ }
+ return ($affected, 0);
+ }
+ while ($array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ ++$affected;
+ } else {
+ push(@rows, $array);
+ }
+ }
+ $table->seek($data, 0, 0);
+ foreach $array (@rows) {
+ $table->push_row($data, $array);
+ }
+ $table->truncate($data);
+ return ($affected, 0);
+}
+sub SELECT ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 0);
+ my $tname = $self->{table_name};
+ my($affected) = 0;
+ my(@rows, $array, $val, $col, $i);
+ while ($array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ if ( $self->{fetched_from_key} ) {
+ push(@rows, [$self->{fetched_value}] );
+ return (scalar(@rows),scalar @{$self->{column_names}},[EMAIL
PROTECTED]);
+ }
+ my $col_nums = $self->column_nums($table);
+ my %cols = reverse %{ $col_nums };
+ my $rowhash;
+ for (sort keys %cols) {
+ $rowhash->{$cols{$_}} = $array->[$_];
+ }
+ my @newarray;
+ for ($i = 0; $i < @{$self->{column_names}}; $i++) {
+ $col = $self->{column_names}->[$i];
+ push @newarray,$rowhash->{$col};
+ }
+ push(@rows, [EMAIL PROTECTED]);
+ }
+ }
+ (scalar(@rows), scalar @{$self->{column_names}}, [EMAIL PROTECTED]);
+}
+sub UPDATE ($$$) {
+ my($self, $data, $params) = @_;
+ my $table = $self->open_tables($data, 0, 1);
+ my($eval,$all_cols) = $self->open_tables($data, 0, 1);
+ return undef unless $eval;
+ my($affected) = 0;
+ my(@rows, $array, $val, $col, $i);
+ while ($array = $table->fetch_row($data)) {
+ if ($self->eval_where($table,$array)) {
+ my $col_nums = $self->column_nums($table);
+ my %cols = reverse %{ $col_nums };
+ my $rowhash;
+ for (sort keys %cols) {
+ $rowhash->{$cols{$_}} = $array->[$_];
+ }
+ for ($i = 0; $i < @{$self->{column_names}}; $i++) {
+ $col = $self->{column_names}->[$i];
+ $array->[$self->column_nums($table,$col)]=$self->row_values($i);
+ }
+ $affected++;
+ push(@rows, $array);
+ }
+ else {
+ push(@rows, $array);
+ }
+ }
+ $table->seek($data, 0, 0);
+ foreach my $array (@rows) {
+ $table->push_row($data, $array);
+ }
+ $table->truncate($data);
+ ($affected, 0);
+}
+sub column_nums {
+ my($self,$table,$stmt_col_name)[EMAIL PROTECTED];
+ my %dbd_nums = %{ $table->{col_nums} };
+ my @dbd_cols = @{ $table->{col_names} };
+ my %stmt_nums;
+ if ($stmt_col_name) {
+ while(my($k,$v)=each %dbd_nums) {
+ return $v if uc $k eq uc $stmt_col_name;
+ }
+ return undef;
+ }
+ for my $i(0 .. $#dbd_cols) {
+ for my $stmt_col(@{$self->{column_names}}) {
+ $stmt_nums{$stmt_col} = $i if uc $dbd_cols[$i] eq uc $stmt_col;
+ }
+ }
+ return \%stmt_nums;
+}
+sub eval_where {
+ my $self = shift;
+ my $table = shift;
+ my $rowary = shift;
+ my $where = $self->{"where_clause"} || return 1;
+ my $col_nums = $table->{"col_nums"} ;
+ my %cols = reverse %{ $col_nums };
+ my $rowhash;
+ for (sort keys %cols) {
+ $rowhash->{uc $cols{$_}} = $rowary->[$_];
+ }
+ return $self->process_predicate ($where,$table,$rowhash);
+}
+sub process_predicate {
+ my($self,$pred,$table,$rowhash) = @_;
+ my $val1 = $pred->{arg1};
+ if ($val1->{type} eq 'column') {
+ $val1 = $rowhash->{ uc $val1->{value}};
+ }
+ else {
+ $val1 = $val1->{value};
+ }
+ my $val2 = $pred->{arg2};
+ if ($val2->{type}eq 'column') {
+ $val2 = $rowhash->{uc $val2->{value}};
+ }
+ else {
+ $val2 = $val2->{value};
+ }
+ my $op = $pred->{op};
+ my $neg = $pred->{neg};
+ my $match;
+ if ( $self->{command} eq 'SELECT'
+ and $op eq '=' and !$neg and $table->can('fetch_one_row')
+ ) {
+ my $key_col = $table->fetch_one_row(1,1);
+ if ($pred->{arg1}->{value} =~ /^$key_col$/i) {
+ $self->{fetched_from_key}=1;
+ $self->{fetched_value} = $table->fetch_one_row(
+ 0,$pred->{arg2}->{value}
+ );
+ return 1;
+ }
+ }
+ $match = $self->is_matched($val1,$op,$val2) || 0;
+ if ($neg) { $match = $match ? 0 : 1; }
+ return $match;
+}
+sub is_matched {
+ my($self,$val1,$op,$val2)[EMAIL PROTECTED];
+ if ($op eq 'IS') {
+ return 1 if (!defined $val1 or $val1 eq '');
+ return 0;
+ }
+ #return $val1 == $val2;
+ #print "[$val1] [$op] [$val2]\n";
+ $val1 = '' unless defined $val1;
+ $val2 = '' unless defined $val2;
+ if ($op =~ /LIKE|CLIKE/i) {
+ $val2 = quotemeta($val2);
+ $val2 =~ s/\\%/.*/g;
+ $val2 =~ s/_/./g;
+ }
+ if ($op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; }
+ if ($op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; }
+ if ($val1 =~ /$numexp/ and $val2 =~ /$numexp/) {
+ if ($op eq '<' ) { return $val1 < $val2; }
+ if ($op eq '>' ) { return $val1 > $val2; }
+ if ($op eq '=' ) { return $val1 == $val2; }
+ if ($op eq '<>' ) { return $val1 != $val2; }
+ if ($op eq '<=' ) { return $val1 <= $val2; }
+ if ($op eq '>=' ) { return $val1 >= $val2; }
+ }
+ else {
+ if ($op eq '<' ) { return $val1 lt $val2; }
+ if ($op eq '>' ) { return $val1 gt $val2; }
+ if ($op eq '=' ) { return $val1 eq $val2; }
+ if ($op eq '<>' ) { return $val1 ne $val2; }
+ if ($op eq '<=' ) { return $val1 ge $val2; }
+ if ($op eq '>=' ) { return $val1 le $val2; }
+ }
+}
+sub params {
+ my $self = shift;
+ my $val_num = shift;
+ if (!$self->{"params"}) { return 0; }
+ if (defined $val_num) {
+ return $self->{"params"}->[$val_num];
+ }
+ if (wantarray) {
+ return @{$self->{"params"}};
+ }
+ else {
+ return scalar @{ $self->{"params"} };
+ }
+
+}
+sub open_tables {
+ my($self, $data, $createMode, $lockMode) = @_;
+ my $table_name = $self->{table_name};
+ my $table;
+ eval{$table = $self->open_table($data,$table_name,$createMode,$lockMode)};
+ die $@ if $@;
+ die "Couldn't open table '$table_name'!" unless $table;
+ if (!$self->{column_names} or $self->{column_names}->[0] eq '*') {
+ $self->{column_names} = $table->{col_names};
+ }
+ return $table;
+}
+sub row_values {
+ my $self = shift;
+ my $val_num = shift;
+ if (!$self->{"values"}) { return 0; }
+ if (defined $val_num) {
+ return $self->{"values"}->[$val_num]->{value};
+ }
+ if (wantarray) {
+ return map{$_->{"value"} } @{$self->{"values"}};
+ }
+ else {
+ return scalar @{ $self->{"values"} };
+ }
+}
+package DBI::SQL::Nano::Table_;
+sub new ($$) {
+ my($proto, $attr) = @_;
+ my($self) = { %$attr };
+ bless($self, (ref($proto) || $proto));
+ $self;
+}
+1;
+__END__
+
+=pod
+
+=head1 SUPPORTED SQL SYNTAX
+
+ statement ::=
+ DROP TABLE <table_name>
+ | CREATE TABLE <table_name> <col_def_list>
+ | INSERT INTO <table_name> <insert_col_list> VALUES <val_list>
+ | DELETE FROM <table_name> <where_clause>
+ | UPDATE <table_name> SET <set_clause> <where_clause>
+ | SELECT <select_col_list> FROM <table_name> <where_clause>
+ identifiers ::=
+ * table and column names should be valid SQL identifiers
+ * especially avoid using spaces and commas in identifiers
+ * note: there is no error checking for invalid names, some
+ will be accepted, others will cause parse failures
+ table_name ::=
+ * only one table (no multiple table operations)
+ * see identifier for valid table names
+ col_def_list ::=
+ * a parens delimited, comma-separated list of column names
+ * see identifier for valid column names
+ * column types and column constraints may be included but are ignored
+ e.g. these are all the same:
+ (id,phrase)
+ (id INT, phrase VARCHAR(40))
+ (id INT PRIMARY KEY, phrase VARCHAR(40) NOT NULL)
+ insert_col_list ::=
+ * a parens delimited, comma-separated list of column names
+ * as in standard SQL, this is optional
+ select_col_list ::=
+ * a comma-separated list of column names
+ * or an asterisk denoting all columns
+ val_list ::=
+ * a parens delimited, comma-separated list of values which can be:
+ * placeholders (an unquoted question mark)
+ * numbers (unquoted numbers)
+ * column names (unquoted strings)
+ * nulls (unquoted word NULL)
+ * strings (delimited with single quote marks);
+ * note: leading and trailing percent mark (%) and underscore (_)
+ can be used as wildcards in quoted strings for use with
+ the LIKE and CLIKE operators
+ * note: escaped single quote marks within strings are not
+ supported, neither are embedded commas, use placeholders instead
+ set_clause ::=
+ * a comma-separated list of column = value pairs
+ * see val_list for acceptable value formats
+ where_clause ::=
+ * a single "column/value <op> column/value" predicate, optionally
+ preceded by "NOT"
+ * note: multiple predicates combined with ORs or ANDs are not supported
+ * see val_list for acceptable value formats
+ * op may be one of:
+ < > >= <= = <> LIKE CLIKE IS
+ * CLIKE is a case insensitive LIKE
+
+=cut
+
Added: dbi/trunk/t/50dbm.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/50dbm.t Wed Feb 25 15:43:12 2004
@@ -0,0 +1,70 @@
+#!perl -w
+
+use strict;
+use Test::More;
+
+BEGIN {
+ $ENV{DBI_SQL_NANO}=1; # 0=SQL::Statement 1=DBI::SQL::Nano
+ use lib './' # to find the new DBD::File
+}
+use DBI;
+
+BEGIN { plan tests => 8 }
+
+$|=1;
+my $dbh = DBI->connect('dbi:DBM(RaiseError=0,PrintError=0):f_foo=bar');
+ok($dbh);
+
+#
+# dbm_type defaults to AnyDBM_File which uses the @INC to find
+# the DBM type. See AnyDBM_File docs for default order.
+#
+# the user may also specify a dbm_type in the connect() or afterwards
+# for example:
+# $dbh->{dbm_type}='MLDBM';
+# $dbh->{dbm_type}='SDBM_File';
+#
+# It should be possible to have multiple tables, each using different
+# DBMs in the same database handle.
+#
+
+printf "\n%s %s\n%s %s\n%s %s\n%s %s\n",
+ 'DBD::DBM' , $dbh->{Driver}->{Version}
+ , 'DBD::File' , $dbh->{Driver}->{file_version}
+ , 'DBI::SQL::Nano' , $dbh->{Driver}->{nano_version}
+ , 'SQL::Statement' , $dbh->{Driver}->{statement_version}
+ ;
+
+for my $sql (split /;\s*\n+/,join '',<DATA>) {
+
+ my $sth = $dbh->prepare($sql) or die $dbh->errstr;
+ $sth->execute;
+ die $sth->errstr if $sth->errstr and $sql !~ /DROP/;
+ next unless $sql =~ /SELECT/;
+
+ my $results='';
+ my $expected_results = {
+ 1 => 'oranges',
+ 2 => 'apples',
+ 3 => '', # NULL returned as undef, currently
+ };
+ # Note that we can't rely on the order here, it's not portable,
+ # different DBMs (or versions) will return different orders.
+ while (my ($key, $value) = $sth->fetchrow_array) {
+ ok exists $expected_results->{$key};
+ is $value, $expected_results->{$key};
+ }
+ is $DBI::rows, keys %$expected_results;
+}
+
+__DATA__
+DROP TABLE fruit;
+CREATE TABLE fruit (dKey INT, dVal VARCHAR(10));
+INSERT INTO fruit VALUES (1,'oranges' );
+INSERT INTO fruit VALUES (2,'to_change' );
+INSERT INTO fruit VALUES (3, NULL );
+INSERT INTO fruit VALUES (4,'to_delete' );
+DELETE FROM fruit WHERE dKey=4;
+UPDATE fruit SET dVal='apples' WHERE dKey=2;
+SELECT * FROM fruit;
+DROP TABLE fruit;
