diff --git a/Changes b/Changes index 3beee67..f7fc9f4 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,17 @@ Revision history for Perl extension XBase and DBD::Xbase. +0.100 + DBD::XBase: capitalized AND/OR in SQL commands now work, + method rows implemented, reported by cybertoast. + Updated to use _set_fbav. + + XBase::SQL: fixed the primary key/key parsing problem, patch + by Bill Brinkley & Joe Johnston. + + XBase::Memo: appending record to dBaseIV memo used to corrupt + the data -- reported by Dan Albertsson. + 0.0696 Mon Oct 26 11:57:01 MET 1998 DBD::XBase: added bug reporting by INSERT command and fixed diff --git a/Makefile.PL b/Makefile.PL index 91200f8..8a01e50 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,26 +1,24 @@ -eval 'use XBase'; -if (not $@) - { - if (eval { $XBase::VERSION < 0.063 } ) - { - print < 'lib/XBase.pm', ($] >= 5.005 ? ( 'AUTHOR' => 'Jan Pazdziora (adelton@fi.muni.cz)', - 'ABSTRACT' => 'Works with XBase (dbf) files, includes DBI support', + 'ABSTRACT' => 'Reads and writes XBase (dbf) files, includes DBI support', ) : ()), 'PL_FILES' => { 'bin/dbfdump.PL' => 'bin/dbfdump' }, 'EXE_FILES' => [ 'bin/dbfdump' ], diff --git a/README b/README index c820fc3..a06019a 100644 --- a/README +++ b/README @@ -3,29 +3,47 @@ XBase and DBD::XBase ------------------------------------ -This is the README file for the XBase and DBD::XBase packages. +This is the README file for the XBase and DBD::XBase packages. Please +read it if you install this module for the first time or if there are +some problems with the module. Module XBase provides access to XBase (dBase, Fox*) database files, -namely dbf, dbt, fpt, ndx, ntx. It provides native Perl interface -($table->get_record) to read and write the tables. - -Module DBD::XBase is DBI driver that uses XBase to actually access the -data, giving you SQL interface ($dbh->prepare("SELECT * FROM TABLE")). -To use DBD::XBase, you need the DBI module -- please check the DBI(3) -man page for how to use it. As an argument to connect, give -"dbi:XBase:$dir", where $dir is directory with the data files. +namely dbf, dbt, fpt, ndx and ntx. It provides native Perl interface +($table->get_record, $table->update_record) to read and write the tables. +Module DBD::XBase is a DBI driver that uses the XBase module to work with +the data, providing you with DBI compliant processing interface and SQL +commands ($dbh->prepare("SELECT * FROM TABLE")). As an argument to +DBI->connect, specify "dbi:XBase:$dir", where $dir is the directory with +the data files. + +So this package offers two ways of accessing your beloved data in dbf +files: XBase and DBD::XBase. You are free to pick any you find more +suitable for your project, I personally prefer the DBD::XBase. + +You have to have Perl version 5.004. [Please do not ask me to make these +modules work under 5.003 or older version -- upgrade instead.] + +You need a DBI module version at least 1.0 to use the DBD driver. If you +have older DBI and cannot upgrade for some reason, check the CPAN for +DBD::XBase version < 0.090. Those are the last versions that do not +require DBI 1.0. [Please do not ask me to make this line of DBD::XBase +work under older DBI's -- it will not work. Please do not ask me to make +the DBD::XBase work without DBI -- it will not work. Use the XBase +interface or install the DBI module.] No other servers/software are needed, these modules directly read and write the files. The main goal was to create a parser, mainly to work -with data from your current applications. If you are looking for -something more powerfull, check (for example) MySQL or PostgreSQL. +with data from your legacy applications. If you are looking for something +more powerfull, check (for example) MySQL or PostgreSQL. -The distribution also includes a dbfdump script that prints out the -content of the table in readable form. +The distribution also includes a dbfdump script that prints the content +of the table in readable form. The support for ndx/ntx index files is rather minimal. It currently -allows you to search directly to the record you want. But you cannot -create the index, nor is the index updated when you change the dbf. +allows you to search directly to the record you want, in the XBase +module. But you cannot create the index, nor is the index updated when +you change the dbf. Check the eg/ directory for how you can help to +make it better. This module is provided in a hope you might find it usefull. My intent is to support as many variations of formats as possible, but I do not @@ -34,7 +52,8 @@ data files if you feel your native XBase engines produce data incompatible with this module. Man pages for XBase, DBD::XBase and dbfdump are included, examples of -little scripts can also be found in eg directory of the distribution. +little scripts can also be found in eg/ directory of the distribution. +Read the DBI man page for DBI specific issues. Installation: Download the tar.gz, unpack it, change to the DBD-XBase-* @@ -50,8 +69,8 @@ Installation: perl -MCPAN -e shell cpan> install XBase - You have to have Perl version 5.004. You need a DBI module to - use the DBD driver. + You have to have Perl version 5.004. You need a DBI module version + 1.0 or higher to use the DBD driver. Some people asked whether it is possible to use the module even if they do not have root access. Even if this is in @@ -69,20 +88,31 @@ Installation: use lib '/your/directory'; use XBase; + Some people asked how to use this module when they are not + able to run make on their system. Even if it's beyond my + understanding why somebody would want to do such thing, you + are free to just copy the lib/ directory where you want it to + have. This should work. + Problems and bug reports: If anything goes wrong when installing, please send me output of your installation messages and of make test TEST_VERBOSE=1. + If there are errors when actually using the module on your - data, please send me example of your script, the errstr + data, please chcek first that it's really a XBase/DBD::XBase + problem. If so, please send me example of your script, the errstr messages you get and (if possible) your data files that cause the problems, so that I can trace down the problem. Add info about your OS, version of Perl and other modules that might be relevant. You can of course also send patches to actual bugs. - Please mention word XBase in the Subject line. - - Sending bug reports and patches to c.l.p.m is fine but send - a copy to me as well, since I might miss your post. + + Mention the word "XBase" in the Subject line, otherwise you + mail will probably just slip through my 4 MB mailbox without + being even read. + For general Perl issues, use the comp.lang.perl.m* newsgroups, + for DBI issues, use dbi-users@fugue.com. + If it works for you: I'd appreciate any message if you use the module and find it usefull -- I'm just curious for what tasks people use the diff --git a/bin/dbfdump.PL b/bin/dbfdump.PL index b3b94ba..364ef9b 100644 --- a/bin/dbfdump.PL +++ b/bin/dbfdump.PL @@ -20,11 +20,11 @@ use Getopt::Long; my %options; Getopt::Long::GetOptions( \%options, 'help', 'version', 'info', 'rs=s', 'fs=s', 'undef=s', 'fields=s', - 'nomemo', 'memofile=s', + 'nomemo', 'memofile=s', 'memosep=s', ) or exit; if (defined $options{'version'}) - { print "This is dbfdump version $XBase::VERSION\n"; exit; } + { print "This is dbfdump version $XBase::VERSION.\n"; exit; } if (@ARGV == 0 or defined $options{'help'}) { @@ -35,7 +35,8 @@ Usage: dbfdump [ options ] files --fs field separator --fields comma separated list of fields to print --undef what to print for NULL values - --memofile sepcifies unstandard name of attached memo file + --memofile specifies unstandard name of attached memo file + --memosep separator for dBase III dbt's -- default "\x1a\x1a" all having as parameter a string; and also --nomemo do not try to read the memo (dbt/fpt) file --info print info about the file and fields diff --git a/dbit/00base.t b/dbit/00base.t old mode 100755 new mode 100644 index 1ac4a7e..e719351 --- a/dbit/00base.t +++ b/dbit/00base.t @@ -19,7 +19,6 @@ foreach $file ("lib.pl", "t/lib.pl") { last; } } -if ($verbose) { print "Driver is $mdriver\n"; } # Base DBD Driver Test @@ -34,6 +33,8 @@ print "ok 2\n"; $switch = DBI->internal; (ref $switch eq 'DBI::dr') ? print "ok 3\n" : print "not ok 3\n"; + + # This is a special case. install_driver should not normally be used. $drh = DBI->install_driver($mdriver); @@ -41,9 +42,7 @@ $drh = DBI->install_driver($mdriver); if ($drh->{Version}) { print "ok 5\n"; - if ($verbose) { - print "Driver version is ", $drh->{Version}, "\n"; - } + print "Driver version is ", $drh->{Version}, "\n"; } BEGIN { $tests = 5 } diff --git a/dbit/10dsnlist.t b/dbit/10dsnlist.t index 37ddaeb..e52cae6 100755 --- a/dbit/10dsnlist.t +++ b/dbit/10dsnlist.t @@ -12,7 +12,7 @@ # require DBI; $mdriver = ""; -foreach $file ("lib.pl", "t/lib.pl") { +foreach $file ("lib.pl", "t/lib.pl", "DBD-~DBD_DRIVER~/t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } @@ -20,11 +20,11 @@ foreach $file ("lib.pl", "t/lib.pl") { last; } } -if ($mdriver eq 'pNET' || $mdriver eq 'ODBC') { +if ($mdriver eq 'pNET' || $mdriver eq 'Adabas') { print "1..0\n"; exit 0; } -if ($verbose) { print "Driver is $mdriver\n"; } +print "Driver is $mdriver\n"; sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", @@ -47,7 +47,7 @@ while (Testing()) { or ServerError(); Test($state or defined(@dsn = DBI->data_sources($mdriver))); - if (!$state && $verbose) { + if (!$state) { my $d; print "List of $mdriver data sources:\n"; foreach $d (@dsn) { @@ -56,6 +56,24 @@ while (Testing()) { print "List ends.\n"; } Test($state or $dbh->disconnect()); + + # + # Try different DSN's + # + my(@dsnList); + if (($mdriver eq 'mysql' or $mdriver eq 'mSQL') + and $test_dsn eq "DBI:$mdriver:test") { + @dsnList = ("DBI:$mdriver:test:localhost", + "DBI:$mdriver:test;localhost", + "DBI:$mdriver:database=test;host=localhost"); + } + my($dsn); + foreach $dsn (@dsnList) { + Test($state or ($dbh = DBI->connect($dsn, $test_user, + $test_password))) + or print "Cannot connect to DSN $dsn: ${DBI::errstr}\n"; + Test($state or $dbh->disconnect()); + } } exit 0; diff --git a/dbit/20createdrop.t b/dbit/20createdrop.t index 78f667d..7c9d894 100644 --- a/dbit/20createdrop.t +++ b/dbit/20createdrop.t @@ -58,11 +58,15 @@ while (Testing()) { # Create a new table # my $def; - Test($state or ($def = TableDefinition($table, - ["id", "INTEGER", 4, 0], - ["name", "CHAR", 64, 0]), - $dbh->do($def))) - or DbiError($dbh->err, $dbh->errstr); + if (!$state) { + ($def = TableDefinition($table, + ["id", "INTEGER", 4, 0], + ["name", "CHAR", 64, 0])); + print "Creating table:\n$def\n"; + } + Test($state or $dbh->do($def)) + or DbiError($dbh->err, $dbh->errstr); + # # ... and drop it. diff --git a/dbit/30insertfetch.t b/dbit/30insertfetch.t index addc6f3..a892f74 100644 --- a/dbit/30insertfetch.t +++ b/dbit/30insertfetch.t @@ -4,7 +4,7 @@ # # This is a simple insert/fetch test. # - +$^W = 1; # # Make -w happy @@ -19,7 +19,7 @@ $test_password = ''; # use DBI; $mdriver = ""; -foreach $file ("lib.pl", "t/lib.pl") { +foreach $file ("lib.pl", "t/lib.pl", "DBD-~DBD_DRIVER~/t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } @@ -43,67 +43,99 @@ sub ServerError() { # the new table. # while (Testing()) { + # # Connect to the database - Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password)) + Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password), + 'connect') or ServerError(); # # Find a possible new table name # - Test($state or $table = FindNewTable($dbh)) - or DbiError($dbh->err, $dbh->errstr); + Test($state or $table = FindNewTable($dbh), 'FindNewTable') + or DbiError($dbh->err, $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($def = TableDefinition($table, - ["id", "INTEGER", 4, 0], - ["name", "CHAR", 64, 0]), - $dbh->do($def))) - or DbiError($dbh->err, $dbh->errstr); + ["id", "INTEGER", 4, 0], + ["name", "CHAR", 64, 0], + ["val", "INTEGER", 4, 0], + ["txt", "CHAR", 64, 0]) and + $dbh->do($def)), 'create', $def) + or DbiError($dbh->err, $dbh->errstr); # # Insert a row into the test table....... # Test($state or $dbh->do("INSERT INTO $table" - . " VALUES(1, 'Alligator Descartes')")) - or DbiError($dbh->err, $dbh->errstr); + . " VALUES(1, 'Alligator Descartes', 1111," + . " 'Some Text')"), 'insert') + or DbiError($dbh->err, $dbh->errstr); + # + # Now, try SELECT'ing the row out. + # + Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" + . " WHERE id = 1"), + 'prepare select') + or DbiError($dbh->err, $dbh->errstr); + + Test($state or $cursor->execute, 'execute select') + or DbiError($cursor->err, $cursor->errstr); + + my ($row, $errstr); + Test($state or (defined($row = $cursor->fetchrow_arrayref) && + !($cursor->errstr)), 'fetch select') + or DbiError($cursor->err, $cursor->errstr); + + Test($state or ($row->[0] == 1 && + $row->[1] eq 'Alligator Descartes' && + $row->[2] == 1111 && + $row->[3] eq 'Some Text'), 'compare select') + or DbiError($cursor->err, $cursor->errstr); + + Test($state or $cursor->finish, 'finish select') + or DbiError($cursor->err, $cursor->errstr); + + Test($state or undef $cursor || 1, 'undef select'); + # # ...and delete it........ # - Test($state or $dbh->do("DELETE FROM $table WHERE id = 1")) - or DbiError($dbh->err, $dbh->errstr); + Test($state or $dbh->do("DELETE FROM $table WHERE id = 1"), 'delete') + or DbiError($dbh->err, $dbh->errstr); # # Now, try SELECT'ing the row out. This should fail. # Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" - . " WHERE id = 1")) - or DbiError($dbh->err, $dbh->errstr); + . " WHERE id = 1"), + 'prepare select deleted') + or DbiError($dbh->err, $dbh->errstr); - Test($state or $cursor->execute) - or DbiError($cursor->err, $cursor->errstr); + Test($state or $cursor->execute, 'execute select deleted') + or DbiError($cursor->err, $cursor->errstr); - my ($row, $errstr); Test($state or (!defined($row = $cursor->fetchrow_arrayref) && (!defined($errstr = $cursor->errstr) || - $cursor->errstr eq ''))) + $cursor->errstr eq '')), 'fetch select deleted') or DbiError($cursor->err, $cursor->errstr); - Test($state or $cursor->finish, "\$sth->finish failed") - or DbiError($cursor->err, $cursor->errstr); + Test($state or $cursor->finish, 'finish select deleted') + or DbiError($cursor->err, $cursor->errstr); - Test($state or undef $cursor || 1); + Test($state or undef $cursor || 1, 'undef select deleted'); # # Finally drop the test table. # - Test($state or $dbh->do("DROP TABLE $table")) - or DbiError($dbh->err, $dbh->errstr); + Test($state or $dbh->do("DROP TABLE $table"), 'drop') + or DbiError($dbh->err, $dbh->errstr); } diff --git a/dbit/40bindparam.t b/dbit/40bindparam.t index a1b764d..4027b44 100644 --- a/dbit/40bindparam.t +++ b/dbit/40bindparam.t @@ -6,6 +6,8 @@ # and modify/extend it. # +$^W = 1; + # # Make -w happy @@ -59,28 +61,29 @@ if (!defined(&SQL_INTEGER)) { while (Testing()) { # # Connect to the database - Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password)) + Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password), + 'connect') or ServerError(); # # Find a possible new table name # - Test($state or $table = FindNewTable($dbh)) - or DbiError($dbh->err, $dbh->errstr); + Test($state or $table = FindNewTable($dbh), 'FindNewTable') + or DbiError($dbh->err, $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($def = TableDefinition($table, ["id", "INTEGER", 4, 0], - ["name", "CHAR", 64, $COL_NULLABLE]), - $dbh->do($def))) - or DbiError($dbh->err, $dbh->errstr); + ["name", "CHAR", 64, $COL_NULLABLE]) and + $dbh->do($def)), 'create', $def) + or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor = $dbh->prepare("INSERT INTO $table" - . " VALUES (?, ?)")) - or DbiError($dbh->err, $dbh->errstr); + . " VALUES (?, ?)"), 'prepare') + or DbiError($dbh->err, $dbh->errstr); # # Insert some rows @@ -89,24 +92,25 @@ while (Testing()) { # Automatic type detection my $numericVal = 1; my $charVal = "Alligator Descartes"; - Test($state or $cursor->execute($numericVal, $charVal)) - or DbiError($dbh->err, $dbh->errstr); + Test($state or $cursor->execute($numericVal, $charVal), 'execute insert 1') + or DbiError($dbh->err, $dbh->errstr); # Does the driver remember the automatically detected type? - Test($state or $cursor->execute("2", "Tim Bunce")) - or DbiError($dbh->err, $dbh->errstr); - $numericVal = 3; - $charVal = "Jochen Wiedmann"; - Test($state or $cursor->execute($numericVal, $charVal)) - or DbiError($dbh->err, $dbh->errstr); + Test($state or $cursor->execute("3", "Jochen Wiedmann"), + 'execute insert num as string') + or DbiError($dbh->err, $dbh->errstr); + $numericVal = 2; + $charVal = "Tim Bunce"; + Test($state or $cursor->execute($numericVal, $charVal), 'execute insert 2') + or DbiError($dbh->err, $dbh->errstr); # Now try the explicit type settings - Test($state or $cursor->bind_param(1, " 4", SQL_INTEGER())) + Test($state or $cursor->bind_param(1, " 4", SQL_INTEGER()), 'bind 1') or DbiError($dbh->err, $dbh->errstr); - Test($state or $cursor->bind_param(2, "Andreas König")) + Test($state or $cursor->bind_param(2, "Andreas König"), 'bind 2') + or DbiError($dbh->err, $dbh->errstr); + Test($state or $cursor->execute, 'execute binds') or DbiError($dbh->err, $dbh->errstr); - Test($state or $cursor->execute) - or DbiError($dbh->err, $dbh->errstr); # Works undef -> NULL? Test($state or $cursor->bind_param(1, 5, SQL_INTEGER())) @@ -117,11 +121,24 @@ while (Testing()) { or DbiError($dbh->err, $dbh->errstr); - Test($state or undef $cursor || 1); + Test($state or $cursor -> finish, 'finish'); + + Test($state or undef $cursor || 1, 'undef cursor'); + + Test($state or $dbh -> disconnect, 'disconnect'); + + Test($state or undef $dbh || 1, 'undef dbh'); # # And now retreive the rows using bind_columns # + # + # Connect to the database + # + Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password), + 'connect for read') + or ServerError(); + Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" . " ORDER BY id")) or DbiError($dbh->err, $dbh->errstr); @@ -131,41 +148,30 @@ while (Testing()) { Test($state or $cursor->bind_columns(undef, \$id, \$name)) or DbiError($dbh->err, $dbh->errstr); - Test($state or ($ref = $cursor->fetch) && $id == 1 && - $name eq 'Alligator Descartes') - or DbiError($dbh->err, $dbh->errstr); - if (!$state && $verbose) { - print "Query returned id = $id, name = $name, ref = $ref, @$ref\n"; - } + $name eq 'Alligator Descartes') + or printf("Query returned id = %s, name = %s, ref = %s, %d\n", + $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 2 && $name eq 'Tim Bunce')) - or DbiError($dbh->err, $dbh->errstr); - if (!$state && $verbose) { - print "Query returned id = $id, name = $name, ref = $ref, @$ref\n"; - } + or printf("Query returned id = %s, name = %s, ref = %s, %d\n", + $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 3 && $name eq 'Jochen Wiedmann')) - or DbiError($dbh->err, $dbh->errstr); - if (!$state && $verbose) { - print "Query returned id = $id, name = $name, ref = $ref, @$ref\n"; - } + or printf("Query returned id = %s, name = %s, ref = %s, %d\n", + $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 4 && $name eq 'Andreas König')) - or DbiError($dbh->err, $dbh->errstr); - if (!$state && $verbose) { - print "Query returned id = $id, name = $name, ref = $ref, @$ref\n"; - } + or printf("Query returned id = %s, name = %s, ref = %s, %d\n", + $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 5 && - (!defined($name) or $name eq ''))) - or DbiError($dbh->err, $dbh->errstr); - if (!$state && $verbose) { - print "Query returned id = $id, name = $name, ref = $ref, @$ref\n"; - } + (!defined($name) or $name eq ''))) + or printf("Query returned id = %s, name = %s, ref = %s, %d\n", + $id, $name, $ref, scalar(@$ref)); Test($state or undef $cursor or 1); diff --git a/dbit/40blobs.t b/dbit/40blobs.t index 870485e..58b5fb9 100644 --- a/dbit/40blobs.t +++ b/dbit/40blobs.t @@ -6,11 +6,12 @@ # is expected to work correctly. # +$^W = 1; + # # Make -w happy # -$::verbose = defined($::verbose) ? $::verbose : 0; $test_dsn = ''; $test_user = ''; $test_password = ''; @@ -75,15 +76,19 @@ while (Testing()) { Test($state or $table = FindNewTable($dbh)) or DbiError($dbh->error, $dbh->errstr); - foreach $size (1, 64) { + my($def); + foreach $size (128) { # # Create a new table # - Test($state or ($def = TableDefinition($table, - ["id", "INTEGER", 4, 0], - ["name", "BLOB", $size, 0]), - $dbh->do($def))) - or DbiError($dbh->err, $dbh->errstr); + if (!$state) { + $def = TableDefinition($table, + ["id", "INTEGER", 4, 0], + ["name", "BLOB", $size, 0]); + print "Creating table:\n$def\n"; + } + Test($state or $dbh->do($def)) + or DbiError($dbh->err, $dbh->errstr); # @@ -109,9 +114,16 @@ while (Testing()) { # # Insert a row into the test table....... # - Test($state or $dbh->do("INSERT INTO $table VALUES(1, " - . $qblob . ")")) - or DbiError($dbh->err, $dbh->errstr); + my($query); + if (!$state) { + $query = "INSERT INTO $table VALUES(1, $qblob)"; + if ($ENV{'SHOW_BLOBS'} && open(OUT, ">" . $ENV{'SHOW_BLOBS'})) { + print OUT $query; + close(OUT); + } + } + Test($state or $dbh->do($query)) + or DbiError($dbh->err, $dbh->errstr); # # Now, try SELECT'ing the row out. @@ -127,19 +139,21 @@ while (Testing()) { or DbiError($cursor->err, $cursor->errstr); Test($state or (@$row == 2 && $$row[0] == 1 && $$row[1] eq $blob)) - or !$verbose or (ShowBlob($blob), - ShowBlob(defined($$row[1]) ? $$row[1] : "")); + or (ShowBlob($blob), + ShowBlob(defined($$row[1]) ? $$row[1] : "")); Test($state or $cursor->finish) - or DbiError($cursor->err, $cursor->errstr); + or DbiError($cursor->err, $cursor->errstr); Test($state or undef $cursor || 1) - or DbiError($cursor->err, $cursor->errstr); + or DbiError($cursor->err, $cursor->errstr); # # Finally drop the test table. # + next; + Test($state or $dbh->do("DROP TABLE $table")) - or DbiError($dbh->err, $dbh->errstr); + or DbiError($dbh->err, $dbh->errstr); } } diff --git a/dbit/40listfields.t b/dbit/40listfields.t index a4a2600..f09833b 100644 --- a/dbit/40listfields.t +++ b/dbit/40listfields.t @@ -21,12 +21,12 @@ $COL_KEY = ''; use DBI; use vars qw($verbose); -$mdriver = ""; +$dbdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } - if ($mdriver ne '') { + if ($dbdriver ne '') { last; } } @@ -95,9 +95,10 @@ while (Testing()) { } } - Test($state or ($ref = $cursor->{'NULLABLE'}) && @$ref == @table_def - && !($$ref[0] xor ($table_def[0][3] & $COL_NULLABLE)) - && !($$ref[1] xor ($table_def[1][3] & $COL_NULLABLE))) + Test($state or ($dbdriver eq 'CSV') or ($dbdriver eq 'ConfFile') + or ($ref = $cursor->{'NULLABLE'}) && @$ref == @table_def + && !($$ref[0] xor ($table_def[0][3] & $COL_NULLABLE)) + && !($$ref[1] xor ($table_def[1][3] & $COL_NULLABLE))) or DbiError($cursor->err, $cursor->errstr); if (!$state && $verbose) { print "Nullable:\n"; diff --git a/dbit/40nulls.t b/dbit/40nulls.t index e014f73..86619b0 100644 --- a/dbit/40nulls.t +++ b/dbit/40nulls.t @@ -81,11 +81,13 @@ while (Testing()) { Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); - Test($state or $rv = $cursor->fetchrow_arrayref) - or DbiError($dbh->err, $dbh->errstr); + Test($state or ($rv = $cursor->fetchrow_arrayref) or $dbdriver eq 'CSV' + or $dbdriver eq 'ConfFile') + or DbiError($dbh->err, $dbh->errstr); - Test($state or !defined($$rv[0]) && defined($$rv[1])) - or DbiError($dbh->err, $dbh->errstr); + Test($state or (!defined($$rv[0]) and defined($$rv[1])) or + $dbdriver eq 'CSV' or $dbdriver eq 'ConfFile') + or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->finish) or DbiError($dbh->err, $dbh->errstr); diff --git a/dbit/40numrows.t b/dbit/40numrows.t index f5a8222..3d436f7 100644 --- a/dbit/40numrows.t +++ b/dbit/40numrows.t @@ -5,6 +5,9 @@ # This tests, whether the number of rows can be retrieved. # +$^W = 1; +$| = 1; + # # Make -w happy @@ -19,7 +22,7 @@ $test_password = ''; # use DBI; $mdriver = ""; -foreach $file ("lib.pl", "t/lib.pl") { +foreach $file ("lib.pl", "t/lib.pl", "DBD-~DBD_DRIVER~/t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } diff --git a/dbit/50chopblanks.t b/dbit/50chopblanks.t index 79364eb..84c3b8b 100644 --- a/dbit/50chopblanks.t +++ b/dbit/50chopblanks.t @@ -107,8 +107,8 @@ while (Testing()) { or ErrMsgF("fetch failed: query $query, error %s.\n", $sth->errstr); Test($state or ($$ref[1] eq $name) - or ($$ref[1] =~ /^$name\s+$/ && - ($dbdriver eq 'XBase' or $dbdriver eq 'mysql' || $dbdriver eq 'ODBC' ))) + or ($$ref[1] =~ /^$name\s+$/ && + ($dbdriver eq 'XBase' || $dbdriver eq 'mysql' || $dbdriver eq 'ODBC'))) or ErrMsgF("problems with ChopBlanks = 0:" . " expected '%s', got '%s'.\n", $name, $$ref[1]); @@ -120,12 +120,11 @@ while (Testing()) { or ErrMsg("execute failed: query $query, error %s.\n", $sth->errstr); my $n = $name; - $n =~ s/^\s+//; $n =~ s/\s+$//; Test($state or ($ref = $sth->fetchrow_arrayref)) or ErrMsgF("fetch failed: query $query, error %s.\n", $sth->errstr); - Test($state or ($$ref[1] eq $n or $$ref[1] =~ /^\s+$n$/)) + Test($state or ($$ref[1] eq $n)) or ErrMsgF("problems with ChopBlanks = 1:" . " expected '%s', got '%s'.\n", $n, $$ref[1]); diff --git a/dbit/50commit.t b/dbit/50commit.t index ccb5869..4117ad3 100644 --- a/dbit/50commit.t +++ b/dbit/50commit.t @@ -4,6 +4,7 @@ # # This is testing the transaction support. # +$^W = 1; # @@ -62,7 +63,7 @@ while (Testing()) { # Connect to the database Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password)), - undef, + 'connect', "Attempting to connect.\n") or ErrMsgF("Cannot connect: Error %s.\n\n" . "Make sure, your database server is up and running.\n" @@ -88,7 +89,7 @@ while (Testing()) { $dbh->errstr); Test($state or $dbh->{AutoCommit}) - or ErrMsg("AutoCommit is off\n"); + or ErrMsg("AutoCommit is off\n", 'AutoCommint on'); # # Tests for databases that do support transactions @@ -154,16 +155,17 @@ while (Testing()) { eval { $dbh->{AutoCommit} = 0; } } Test($state or $@) - or ErrMsg("Expected fatal error for AutoCommit => 0\n"); + or ErrMsg("Expected fatal error for AutoCommit => 0\n", + 'AutoCommit off -> error'); } # Check whether AutoCommit mode works. Test($state or $dbh->do("INSERT INTO $table VALUES (1, 'Jochen')")) or ErrMsgF("Failed to delete: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); - Test($state or !($msg = NumRows($dbh, $table, 1))) + Test($state or !($msg = NumRows($dbh, $table, 1)), 'NumRows') or ErrMsg($msg); - Test($state or $dbh->disconnect) + Test($state or $dbh->disconnect, 'disconnect') or ErrMsgF("Failed to disconnect: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or ($dbh = DBI->connect($test_dsn, $test_user, diff --git a/lib/DBD/XBase.pm b/lib/DBD/XBase.pm index ed2b91a..a7d3b13 100644 --- a/lib/DBD/XBase.pm +++ b/lib/DBD/XBase.pm @@ -161,12 +161,54 @@ sub rollback sub disconnect { 1; } -=comment - -sub DESTROY - { } +sub table_info + { + my $dbh = shift; + my @tables = map { [ undef, undef, $_, 'TABLE', undef ] } $dbh->tables(); + my $sth = DBI::_new_sth($dbh, { 'xbase_lines' => [ @tables ] } ); + $sth->STORE('NUM_OF_FIELDS', 5); + $sth->execute and return $sth; + return; + } -=cut +my @TYPE_INFO_ALL = ( + [ qw( TYPE_NAME DATA_TYPE PRECISION LITERAL_PREFIX LITERAL_SUFFIX CREATE_PARAMS NULLABLE CASE_SENSITIVE SEARCHABLE UNSIGNED_ATTRIBUTE MONEY AUTO_INCREMENT LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE ) ], + [ 'VARCHAR', DBI::SQL_VARCHAR, 65535, "'", "'", 'max length', 0, 1, 2, undef, 0, 0, undef, undef, undef ], + [ 'CHAR', DBI::SQL_CHAR, 65535, "'", "'", 'max length', 0, 1, 2, undef, 0, 0, undef, undef, undef ], + [ 'INTEGER', DBI::SQL_INTEGER, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], + [ 'FLOAT', DBI::SQL_FLOAT, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], + [ 'NUMERIC', DBI::SQL_FLOAT, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], + [ 'BOOLEAN', DBI::SQL_BINARY, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], + [ 'DATE', DBI::SQL_DATE, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], + [ 'BLOB', DBI::SQL_LONGVARBINARY, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], + ); + +my %TYPE_INFO_TYPES = map { ( $TYPE_INFO_ALL[$_][0] => $_ ) } ( 1 .. $#TYPE_INFO_ALL ); +my %REVTYPES = qw( C char N numeric F float L boolean D date M blob ); +my %REVSQLTYPES = map { ( $_ => $TYPE_INFO_ALL[ $TYPE_INFO_TYPES{ uc $REVTYPES{$_} } ][1] ) } keys %REVTYPES; + +### use Data::Dumper; print Dumper \%TYPE_INFO_TYPES, \%REVSQLTYPES; + +sub type_info_all + { + my $dbh = shift; + my $result = [ @TYPE_INFO_ALL ]; + my $i = 0; + my $hash = { map { ( $_ => $i++) } @{$result->[0]} }; + $result->[0] = $hash; + $result; + } +sub type_info + { + my ($dbh, $type) = @_; + my $result = []; + for my $row ( 1 .. $#TYPE_INFO_ALL ) + { + if ($type == DBI::SQL_ALL_TYPES or $type == $TYPE_INFO_ALL[$row][1]) + { push @$result, { map { ( $TYPE_INFO_ALL[0][$_] => $TYPE_INFO_ALL[$row][$_] ) } ( 0 .. $#{$TYPE_INFO_ALL[0]} ) } } + } + $result; + } package DBD::XBase::st; use strict; @@ -179,39 +221,29 @@ sub bind_param $sth->{'param'}[$param - 1] = $value; 1; } - -=comment - -sub bind_columns +sub rows { - my ($sth, $attrib, @col_refs) = @_; - my $i = 1; - for (@col_refs) - { $sth->bind_col($i, $_); $i++; } - 1; - } -sub bind_col - { - my ($sth, $col_num, $col_var_ref) = @_; - $col_num--; - $sth->{'xbase_bind_col'}[$col_num] = $col_var_ref; - 1; + my $sth = shift; + if (defined $sth->{'xbase_rows'}) { return $sth->{'xbase_rows'}; } + return -1; } - -=cut - sub execute { my $sth = shift; if (@_) { $sth->{'param'} = [ @_ ]; } my $param = $sth->{'param'}; + + if (defined $sth->{'xbase_lines'}) + { return -1; } + delete $sth->{'xbase_rows'} if defined $sth->{'xbase_rows'}; my $parsed_sql = $sth->{'xbase_parsed_sql'}; my $command = $parsed_sql->{'command'}; my $table = $parsed_sql->{'table'}[0]; my $dbh = $sth->{'Database'}; - $sth->STORE('NUM_OF_FIELDS', 0); + ### if (not defined $sth->FETCH('NUM_OF_FIELDS')) + ### { $sth->STORE('NUM_OF_FIELDS', 0); } # Create table first -- we do not need to work with the table anymore if ($command eq 'create') @@ -290,6 +322,8 @@ sub execute my $wherefn = $parsed_sql->{'wherefn'}; my @fields = @{$parsed_sql->{'fields'}} if defined $parsed_sql->{'fields'}; ### use Data::Dumper; print STDERR Dumper $parsed_sql; + my $rows = 0; + if ($command eq 'select') { if (defined $parsed_sql->{'orderfield'}) @@ -330,7 +364,8 @@ sub execute { $sth->{'xbase_cursor'} = $cursor; } - $sth->STORE('NUM_OF_FIELDS', scalar @fields); + if (not $sth->FETCH('NUM_OF_FIELDS') and scalar @fields) + { $sth->STORE('NUM_OF_FIELDS', scalar @fields); } } elsif ($command eq 'delete') { @@ -338,14 +373,23 @@ sub execute { my $last = $xbase->last_record; for (my $i = 0; $i <= $last; $i++) - { $xbase->delete_record($i); } - return 1; + { + if (not ($xbase->get_record_fn($i, 0))[0]) + { + $xbase->delete_record($i); + $rows++; + } + } } - my $values; - while (defined($values = $cursor->fetch_hashref)) + else { - next unless &{$wherefn}($xbase, $values, $param, 0); - $xbase->delete_record($cursor->last_fetched); + my $values; + while (defined($values = $cursor->fetch_hashref)) + { + next unless &{$wherefn}($xbase, $values, $param, 0); + $xbase->delete_record($cursor->last_fetched); + $rows++; + } } } elsif ($command eq 'update') @@ -358,13 +402,16 @@ sub execute my %newval; @newval{ @fields } = &{$parsed_sql->{'updatefn'}}($xbase, $values, $param, 0); $xbase->update_record_hash($cursor->last_fetched, %newval); + $rows++; } } elsif ($command eq 'drop') { $xbase->drop; + $rows = -1; } - -1; + $sth->{'xbase_rows'} = $rows; + return $rows ? $rows : '0E0'; } sub fetch { @@ -388,6 +435,8 @@ sub fetch if defined $values; } +### use Data::Dumper; print Dumper $retarray; + return unless defined $retarray; ### print STDERR "sth->{'NUM_OF_FIELDS'}: $sth->{'NUM_OF_FIELDS'} sth->{'NUM_OF_PARAMS'}: $sth->{'NUM_OF_PARAMS'}\n"; @@ -411,20 +460,23 @@ sub fetch sub FETCH { my ($sth, $attrib) = @_; + my $parsed_sql = $sth->{'xbase_parsed_sql'}; if ($attrib eq 'NAME') { - return [ @{$sth->{'xbase_parsed_sql'}{'fields'}} ]; } + return [ @{$parsed_sql->{'fields'}} ]; + } elsif ($attrib eq 'NULLABLE') { - return [ (1) x scalar(@{$sth->{'xbase_parsed_sql'}{'fields'}}) ]; + return [ (1) x scalar(@{$parsed_sql->{'fields'}}) ]; } elsif ($attrib eq 'TYPE') { - return [ (0) x scalar(@{$sth->{'xbase_parsed_sql'}{'fields'}}) ]; + return [ map { $REVSQLTYPES{$_} } + map { $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_type($_) } + @{$parsed_sql->{'fields'}} ]; } - elsif ($attrib eq 'ChopBlanks') - { return $sth->{'xbase_parsed_sql'}->{'ChopBlanks'}; } + { return $parsed_sql->{'ChopBlanks'}; } else { return $sth->DBD::_::st::FETCH($attrib); } } diff --git a/lib/XBase.pm b/lib/XBase.pm index 7f24ecc..b0bb7b8 100644 --- a/lib/XBase.pm +++ b/lib/XBase.pm @@ -18,7 +18,7 @@ use XBase::Base; # will give us general methods use vars qw( $VERSION $errstr $CLEARNULLS @ISA ); @ISA = qw( XBase::Base ); -$VERSION = '0.0902'; +$VERSION = '0.097'; $CLEARNULLS = 1; # Cut off white spaces from ends of char fields *errstr = \$XBase::Base::errstr; @@ -1077,7 +1077,7 @@ Thanks a lot. =head1 VERSION -0.0696 +0.097 =head1 AUTHOR diff --git a/lib/XBase/Index.pm b/lib/XBase/Index.pm index 810a16b..c732a37 100644 --- a/lib/XBase/Index.pm +++ b/lib/XBase/Index.pm @@ -458,43 +458,6 @@ sub new my ($left, $key) = unpack "\@${offset}Va${keylength}", $data; -=comment - - if ($indexfile->{'active'}{'key_type'} eq 'N') - { - my $f = substr $key, 0, 8; - my $exp = substr $key, 8, 2; - print "$key $f $exp\n"; - - $f = unpack 'V', $f; - $exp = unpack 'v', $exp; - - print "$key $f $exp\n"; - - $f &= 0xfffffffffffff; - $exp >>= 4; - - print "$key $f $exp\n"; - - - print "$key $f $exp\n"; - - $f = pack 'V', $f; - $exp = pack 'v', $exp; - - print "$key $f $exp\n"; - exit; - - my $bigend = substr(pack( "d", 1), 0, 2) eq '?ğ'; - if ($bigend) - { - $key = reverse $key if $bigend; - ### $key = unpack "d", $key; - } - } - -=cut - push @$keys, $key; if ($noleaf == 54 or $noleaf == 20 or $noleaf == 32 or diff --git a/lib/XBase/Memo.pm b/lib/XBase/Memo.pm index fbeb862..c4d1a33 100644 --- a/lib/XBase/Memo.pm +++ b/lib/XBase/Memo.pm @@ -55,7 +55,8 @@ sub read_header @{$self}{ qw( next_for_append header_len record_len version ) } = ( $next_for_append, $block_size, $block_size, $version ); - $self->{'memosep'} = ( $options{'memosep'} or "\x1a\x1a" ); + $self->{'memosep'} = $options{'memosep'}; + $self->{'memosep'} = "\x1a\x1a" if not defined $self->{'memosep'}; 1; } @@ -171,6 +172,8 @@ sub read_record return unless substr($buffer, 0, 4) eq "\xff\xff\x08\x00"; } my ($unused_id, $length) = unpack $unpackstr, $buffer; + $length += 8 if ref $self eq 'XBase::Memo::Fox'; + my $block_size = $self->{'record_len'}; if ($length < $block_size) { return substr $buffer, 8, $length - 8; } @@ -193,7 +196,7 @@ sub write_record if ($type eq 'P') { $startfield = pack 'N', 0; } elsif ($type eq 'M') { $startfield = pack 'N', 1; } else { $startfield = pack 'N', 2; } - $startfield .= pack 'N', $length; + $startfield .= pack 'N', ($length - 8); } $data = $startfield . $data . "\x1a\x1a"; @@ -214,6 +217,8 @@ sub write_record else { $num = $self->last_record() + 1; } } + else + { $num = $self->last_record() + 1; } $self->SUPER::write_record($num, $data); $num; } diff --git a/lib/XBase/SQL.pm b/lib/XBase/SQL.pm index 8a628fb..63a72e9 100644 --- a/lib/XBase/SQL.pm +++ b/lib/XBase/SQL.pm @@ -6,10 +6,9 @@ package XBase::SQL::Expr; package XBase::SQL; use strict; -use vars qw( $VERSION $DEBUG %COMMANDS ); +use vars qw( $VERSION %COMMANDS ); $VERSION = '0.068'; -$DEBUG = 0; # ################################# # Type conversions for create table @@ -37,12 +36,14 @@ my %TYPES = ( 'char' => 'C', 'varchar' => 'C', # table, field name, number, string - 'TABLE' => '[a-z_][a-z0-9_]*', + 'TABLE' => '\\S+', 'FIELDNAME' => '[a-z_][a-z0-9_]*', 'NUMBER' => q'-?\d*\.?\d+', - 'STRING' => [ qw{ STRINGDBL | STRINGSGL } ] , - 'STRINGDBL' => q' \\" (?:\\\\\\\\|\\\\"|[^\\"])* \\" ', - 'STRINGSGL' => q! \\' (?:\\\\\\\\|\\\\'|[^\\'])* \\' !, + 'STRING' => q! \\" STRINGDBL \\" | \\' STRINGSGL \\' !, + 'STRINGDBL' => q' STRINGDBLPART ( \\\\. STRINGDBLPART ) * ', + 'STRINGSGL' => q' STRINGSGLPART ( \\\\. STRINGSGLPART ) * ', + 'STRINGDBLPART' => q' [^\\\\"]* ', + 'STRINGSGLPART' => q! [^\\\\']* !, # select fields @@ -55,9 +56,11 @@ my %TYPES = ( 'char' => 'C', 'varchar' => 'C', 'WHERE' => 'where WHEREEXPR', 'WHEREEXPR' => 'BOOLEAN', - 'BOOLEAN' => q'\( BOOLEAN \) | RELATION ( ( and | or ) BOOLEAN ) *', + 'BOOLEAN' => q'\( BOOLEAN \) | RELATION ( ( AND | OR ) BOOLEAN ) *', 'RELATION' => 'EXPFIELDNAME ( RELOP ARITHMETIC | is not ? null )', 'EXPFIELDNAME' => 'FIELDNAME', + 'AND' => 'and', + 'OR' => 'or', 'RELOP' => [ qw{ == | = | <= | >= | <> | != | < | > } ], 'ARITHMETIC' => [ qw{ \( ARITHMETIC \) @@ -84,7 +87,7 @@ my %TYPES = ( 'char' => 'C', 'varchar' => 'C', # create definitions 'COLUMNDEF' => 'COLUMNKEY | COLUMNNAMETYPE ( not null ) ?', - 'COLUMNKEY' => 'primary ? key \( FIELDNAME \)', + 'COLUMNKEY' => 'primary key \( FIELDNAME \)', 'COLUMNNAMETYPE' => 'FIELDNAME FIELDTYPE', 'FIELDTYPE' => 'TYPECHAR | TYPENUM | TYPEBOOLEAN | TYPEMEMO | TYPEDATE', @@ -120,6 +123,8 @@ my %ERRORS = ( # ######################################## # Simplifying conversions during the match my %SIMPLIFY = ( + 'STRINGDBL' => sub { join '', get_strings(@_); }, + 'STRINGSGL' => sub { join '', get_strings(@_); }, 'STRING' => sub { my $e = (get_strings(@_))[1]; ## $e =~ s/([\\'])/\\$1/g; "XBase::SQL::Expr->string('$e')"; }, @@ -142,6 +147,8 @@ my %SIMPLIFY = ( { return "not $1 defined(($values[0])->value)"; } else { return join ' ', @values; } }, 'NULL' => 'XBase::SQL::Expr->null()', + 'AND' => 'and', + 'OR' => 'or', ); # #