[Gd-chatter] r11462 - in trunk/libraries/database: sql-odbc sql-odbc-test sql-odbc/sql sql-odbc/sql/sql-example
agent at gwydiondylan.org
agent at gwydiondylan.org
Fri Sep 28 06:22:18 CEST 2007
Author: agent
Date: Fri Sep 28 06:22:17 2007
New Revision: 11462
Added:
trunk/libraries/database/sql-odbc/
trunk/libraries/database/sql-odbc-test/
trunk/libraries/database/sql-odbc-test/Makefile (contents, props changed)
trunk/libraries/database/sql-odbc-test/Open-Source-License.txt (contents, props changed)
trunk/libraries/database/sql-odbc-test/collection-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/connection-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/creation-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/datatype-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/ddl-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/dml-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/introspection-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/library.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/query-tests.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/sql-odbc-test.dylan (contents, props changed)
trunk/libraries/database/sql-odbc-test/sql-odbc-test.lid (contents, props changed)
trunk/libraries/database/sql-odbc-test/transaction-test.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/Makefile (contents, props changed)
trunk/libraries/database/sql-odbc/README (contents, props changed)
trunk/libraries/database/sql-odbc/library.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/
trunk/libraries/database/sql-odbc/sql/conditions.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/conversion.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/datatypes.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/diagnostic.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/introspection.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/large-object.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/macros.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/make.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/module.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/record.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/result-set.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/sql-example/
trunk/libraries/database/sql-odbc/sql/sql-example/NWIND.MDB (contents, props changed)
trunk/libraries/database/sql-odbc/sql/sql-example/Open-Source-License.txt (contents, props changed)
trunk/libraries/database/sql-odbc/sql/sql-example/library.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/sql-example/sql-example.dylan (contents, props changed)
trunk/libraries/database/sql-odbc/sql/sql-example/sql-example.lid (contents, props changed)
Log:
Job: gd
Added SQL-ODBC lib compatible with Melange.
Added: trunk/libraries/database/sql-odbc-test/Makefile
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/Makefile Fri Sep 28 06:22:17 2007
@@ -0,0 +1,9 @@
+LIBPATHS = -L ../odbc-ffi -L ../sql-odbc
+LIBS = ../odbc-ffi/odbc-ffi.lib.du \
+ ../sql-odbc/sql-odbc.lib.du
+
+sql-odbc-test: sql-odbc-test.lid *.dylan $(LIBS)
+ d2c --debug $(LIBPATHS) sql-odbc-test.lid
+
+clean:
+ -rm -rf *.o *.s *.a *.c *.lib.du *.mak *.el *~ sql-odbc-test
Added: trunk/libraries/database/sql-odbc-test/Open-Source-License.txt
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/Open-Source-License.txt Fri Sep 28 06:22:17 2007
@@ -0,0 +1,21 @@
+The contents of this library are subject to the Functional Objects Library
+Public License Version 1.0 (the "License"); you may not use this library
+except in compliance with the License. You may obtain a copy of the License
+at http://www.functionalobjects.com/licenses/library-public-license-1.0.txt
+
+Software distributed under the License is distributed on an "AS IS" basis,
+WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+for the specific language governing rights and limitations under the License.
+
+Original Code is Copyright (c) 1996-2004 Functional Objects, Inc.
+All rights reserved.
+
+Alternatively, the contents of this library may be used under the
+terms of the GNU Lesser General Public License (the "GLGPL"), in which
+case the provisions of the GLGPL are applicable instead of those above. If
+you wish to allow use of your version of this library only under the
+terms of the GLGPL and not to allow others to use your version of this
+library under the License, indicate your decision by deleting the provisions
+above and replace them with the notice and other provisions required
+by the GLGPL. If you do not delete the provisions above, a recipient
+may use your version of this library under either the License or the GLGPL.
Added: trunk/libraries/database/sql-odbc-test/collection-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/collection-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,724 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!collection-tests.dylan(trunk.6) $
+
+
+define constant $a-value = as(<integer>, 'a');
+define constant $z-value = as(<integer>, 'z');
+define constant $a-thru-z-list-size = $z-value - $a-value + 1;
+define constant $a-thru-z-list = map(method(num)
+ make(<string>,
+ size: 1,
+ fill: as(<character>, num))
+ end method,
+ make(<range>,
+ from: $a-value,
+ to: $z-value));
+define constant $a-thru-z-list-list = map(list, $a-thru-z-list);
+
+define generic rs-name(rs :: <result-set>) => (name :: <string>);
+
+define method rs-name(rs :: <forward-only-result-set>) => (name :: <string>)
+ "<forward-only-result-set>"
+end method;
+
+define method rs-name(rs :: <scrollable-result-set>) => (name :: <string>)
+ "<scrollable-result-set>"
+end method;
+
+
+define method check-result-set-identity(result-set :: <result-set>,
+ coercion-policy,
+ scrollable?)
+ => (identity-good :: <boolean>)
+ let correct-class = if (scrollable? = #t)
+ <scrollable-result-set>
+ else
+ <forward-only-result-set>
+ end if;
+ let correct-class? = instance?(result-set, correct-class);
+
+ check-true("Result-set identity test", correct-class?);
+ correct-class?;
+end method;
+
+define method test-body-aux(sql-text :: <string>,
+ coercion-policy :: <coercion-policy>,
+ is-scrollable? :: <boolean>)
+ => (result-set :: <result-set>, field-accessor :: <function>)
+ let query = make(<sql-statement>, text: sql-text, coercion-policy: coercion-policy);
+ let field-accessor = if (coercion-policy = $no-coercion)
+ pointer-value
+ else
+ identity
+ end if;
+ let policy = make(<result-set-policy>, scrollable: is-scrollable?, rowset-size: 1);
+ let result-set = execute(query,
+ result-set-policy: make(<result-set-policy>,
+ scrollable: is-scrollable?,
+ rowset-size: 10));
+ check-result-set-identity(result-set, coercion-policy, is-scrollable?);
+ query.close-statement;
+ values(result-set, field-accessor);
+end method;
+
+define macro result-set-test-definer
+ { define result-set-test ?test-name:name
+ ( ?sql-text:expression )
+ ?test-body:body end }
+ =>
+ {
+ define test ?test-name()
+ with-connection(*collection-connection*)
+ with-transaction()
+ let options = vector(vector($no-coercion, #f),
+ vector($default-coercion, #f),
+ vector($default-coercion, #t));
+ do(method(option-instance)
+ let (?=coercion-policy, ?=is-scrollable?) = apply(values, option-instance);
+ let (?=result-set, ?=field-accessor)
+ = test-body-aux(?sql-text, ?=coercion-policy, ?=is-scrollable?);
+ ?test-body;
+ end method,
+ options);
+ end with-transaction;
+ end with-connection;
+ end test; }
+end macro;
+
+
+define result-set-test size-1("select * from dwsql "
+ "where col_2 = 0 and col_2 = 1")
+ check-equal(format-to-string("Size 1 check on %s",
+ rs-name(result-set)),
+ size(result-set), 0);
+end;
+
+
+
+define result-set-test size-2("select * from dwsql")
+ let result-set-size = result-set.size;
+ check-equal(format-to-string("Size 2 check on %s",
+ rs-name(result-set)),
+ result-set-size, $a-thru-z-list-size);
+end;
+
+
+define result-set-test size-3("select col_1 from dwsql order by col_1")
+ if (is-scrollable?)
+ check-equal("Size 3 test", result-set[result-set.size - 1][0], "z")
+ end if;
+end result-set-test;
+
+
+define result-set-test size-setter-1("select * from dwsql")
+ check-condition(format-to-string("Size 1 setter test on %s",
+ rs-name(result-set)),
+ <result-set-mutation-error>,
+ result-set.size := 3);
+end;
+
+
+define result-set-test empty?-1("select * from dwsql")
+ check-true(format-to-string("Empty? test 1 on %s",
+ rs-name(result-set)),
+ ~empty?(result-set));
+end;
+
+
+define result-set-test empty?-2("select * from dwsql "
+ "where col_2 = 0 and col_2 = 1")
+ let is-empty? = result-set.empty?;
+ check-true(format-to-string("Empty? test 2 on %s",
+ rs-name(result-set)),
+ is-empty?); //empty?(result-set));
+end;
+
+
+define result-set-test element-1("select col_2 from dwsql order by col_2")
+ let record-1 = element(result-set, 0);
+ let field-1 = field-accessor(element(record-1, 0));
+ check-equal(format-to-string("Element test on %s: record 1",
+ rs-name(result-set)),
+ field-1, as(<integer>, 'a'));
+
+ let record-2 = element(result-set, 1);
+ let field-2 = field-accessor(element(record-2, 0));
+ check-equal(format-to-string("Element test on %s: record 2", rs-name(result-set)),
+ field-2, as(<integer>, 'b'));
+
+ let record-3 = element(result-set, 2);
+ let field-3 = field-accessor(element(record-3, 0));
+ check-equal(format-to-string("Element test on %s: record 3", rs-name(result-set)),
+ field-3, as(<integer>, 'c'));
+end;
+
+define result-set-test element-2("select col_2 from dwsql order by col_2")
+ let record-3 = element(result-set, 2);
+ let field-1 = field-accessor(element(record-3, 0));
+
+ check-equal(format-to-string("Element test-2 on %s: record 3",
+ rs-name(result-set)),
+ field-1, as(<integer>, 'c'));
+
+ if (is-scrollable? = #t)
+ check-true(format-to-string("Element test-2 on %s: revisiting",
+ rs-name(result-set)),
+ block ()
+ let record-2 = element(result-set, 1);
+ let field = field-accessor(element(record-2, 0));
+ field = as(<integer>, 'b')
+ end);
+ else
+ let not-found = pair(#f, #f);
+ let field = element(result-set, 1, default: not-found);
+ check-true(format-to-string("Element test-2 on %s: invalid revisiting",
+ rs-name(result-set)), field = not-found);
+ end if;
+end;
+
+define result-set-test element-3("select col_2 from dwsql order by col_2")
+ check-equal("Element with default test",
+ element(result-set, 30, default: #"ack"),
+ #"ack");
+end;
+
+define result-set-test map-1("select col_2 from dwsql where col_2 < 100")
+ let result = map(compose(field-accessor, rcurry(element, 0)),
+ result-set);
+ let answer = list(as(<integer>, 'a'),
+ as(<integer>, 'b'),
+ as(<integer>, 'c'));
+ check-equal("Map-1 test", result, answer);
+end;
+
+define result-set-test map-2("select col_2 from dwsql "
+ "where col_2 = 0 and col_2 = 1")
+ check-equal("Map-2 test",
+ map(rcurry(element, 0), result-set),
+ #());
+end;
+
+define result-set-test map-3("select col_2 from dwsql")
+ check-true("Map-3 test",
+ instance?(map(rcurry(element, 0), result-set),
+ type-for-copy(result-set)));
+end;
+
+
+define result-set-test map-4("select col_2 from dwsql")
+ let answer = make(<range>, from: as(<integer>, 'a'), to: as(<integer>, 'z'));
+ check-false("Map-4 test", \==(result-set, answer));
+end;
+
+
+
+define result-set-test map-as-1("select col_2 from dwsql where col_2 < 100")
+ let answer = list(as(<integer>, 'a'),
+ as(<integer>, 'b'),
+ as(<integer>, 'c'));
+ let result = map-as(<list>,
+ compose(field-accessor, rcurry(element, 0)),
+ result-set);
+ check-true("Map-as test 1 - identity check", instance?(result, <list>));
+ check-equal("Map-as test 1", result, answer);
+end;
+
+define result-set-test map-as-2("select col_2 from dwsql where col_2 < 100")
+ let answer = list(as(<integer>, 'a'),
+ as(<integer>, 'b'),
+ as(<integer>, 'c'));
+ check-true("Map-as test 2",
+ \~==(map-as(<list>,
+ compose(field-accessor, rcurry(element, 0)),
+ result-set),
+ answer));
+end;
+
+
+define result-set-test map-into-1("select col_2 from dwsql where col_2 < 100")
+ let collection = list('a', 'b', 'c');
+ check-equal("Map-into test 1",
+ map-into(collection,
+ compose(even?, truncate, field-accessor,
+ rcurry(element, 0)),
+ result-set),
+ map-as(<list>, compose(even?, curry(as, <integer>)),
+ #('a', 'b', 'c')));
+end;
+
+
+define result-set-test any?-1("select col_2 from dwsql where col_2 < 100")
+ check-true("Any?-1 test",
+ any?(compose(curry(\=, as(<integer>, 'b')),
+ field-accessor,
+ rcurry(element, 0)),
+ result-set));
+end;
+
+define result-set-test any?-2("select col_2 from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-false("Any?-2 test",
+ any?(compose(curry(\=, as(<integer>, 'b')),
+ field-accessor, rcurry(element, 0)),
+ result-set));
+end;
+
+
+define result-set-test every?-1("select col_2 from dwsql where col_2 < 100")
+ check-true("Every?-1 test",
+ every?(compose(curry(\>, 100),
+ field-accessor,
+ rcurry(element, 0)),
+ result-set));
+end;
+
+define result-set-test every?-2("select * from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-true("Every?-2 test",
+ every?(compose(curry(\>, 100),
+ field-accessor,
+ rcurry(element, 0)),
+ result-set));
+end;
+
+
+define result-set-test reduce-1("select col_2 from dwsql")
+ let answer = reduce(\+, 0, make(<range>,
+ from: as(<integer>, 'a'),
+ to: as(<integer>, 'z')));
+ check-equal("Reduce-1 test",
+ reduce(method(x, record)
+ x + field-accessor(element(record, 0))
+ end method,
+ 0,
+ result-set),
+ answer);
+end;
+
+define result-set-test reduce-2("select * from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-equal("Reduce-2 test",
+ reduce(method(x, record)
+ x + field-accessor(element(record, 0))
+ end method,
+ 0,
+ result-set),
+ 0);
+end;
+
+define result-set-test member?-1("select col_2 from dwsql")
+ check-true("Member?-1 test",
+ member?(as(<integer>, 's'), result-set,
+ test: method(value, collection-element)
+ value = field-accessor(collection-element[0])
+ end method));
+end;
+
+define result-set-test member?-2("select col_2 from dwsql")
+ check-false("Member?-2 test",
+ member?(1, result-set,
+ test: method(value, collection-element)
+ value = field-accessor(collection-element[0])
+ end method));
+end;
+
+define result-set-test member?-3("select * from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-false("Member?-3 test",
+ member?(1, result-set,
+ test: method(value, collection-element)
+ value = field-accessor(collection-element[0])
+ end method));
+end;
+
+define result-set-test find-key-1("select col_2 from dwsql order by col_2")
+ let s-value = as(<integer>, 's');
+ let s-key = s-value - as(<integer>, 'a');
+ let result = find-key(result-set, method(record)
+ let field = field-accessor(element(record, 0));
+ field = s-value;
+ end method);
+ check-equal("Find-key-1 test", result, s-key);
+end;
+
+define result-set-test find-key-2("select * from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-false("Find-key-2 test", find-key(result-set, empty?));
+end;
+
+define result-set-test find-key-3("select col_2 from dwsql order by col_2")
+ check-equal("Find-key-3 test",
+ find-key(result-set,
+ method(record)
+ field-accessor(element(record, 0)) =
+ as(<integer>, 'a')
+ end method),
+ 0);
+end;
+
+
+// Since result-sets are immutable (not derived from <mutable-collection>),
+// the following methods are not defined on it:
+// replace-elements!
+// fill!
+// element-setter
+// add!
+// remove (double check this one)
+// remove!
+
+
+define result-set-test key-sequence-1("select col_2 from dwsql "
+ "where col_2 < 100 order by col_2")
+ check-true("Key sequence test 1",
+ key-sequence(result-set) = #(0, 1, 2));
+end;
+
+
+// Can't use the following method on a result-set since they access each
+// element more than once:
+// add
+// add-new
+
+
+define result-set-test choose-1("select col_2 from dwsql order by col_2")
+ // choose will not work correctly on instances of <forward-only-result-set>.
+ // Calling choose on such a result-set will result in a collection of the
+ // proper size but each element of the collection will be the same (ie,
+ // the last record retrieved from the database).
+
+ // field elements are truncated in case floating-point values are returned
+ // instead of integers (ODBC does this)
+
+ let element-access = compose(truncate, field-accessor, rcurry(element, 0));
+ let choose-result = choose(compose(even?, element-access), result-set);
+ let result = map-as(<deque>, element-access, choose-result);
+
+ let answer = if (coercion-policy == $no-coercion)
+ make(<deque>, size: 13, fill: $z-value);
+ else
+ choose(even?, make(<range>, from: $a-value, to: $z-value));
+ end if;
+ check-equal("Choose test 1", result, answer);
+end;
+
+
+define result-set-test choose-2("select col_2 from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-equal("Choose test 2",
+ choose(compose(even?, rcurry(element, 0)), result-set),
+ #());
+end;
+
+
+define result-set-test choose-by-1("select col_2 from dwsql order by col_2")
+ let result = choose-by(even?, range(from: 1, to: 26), result-set);
+ let answer = if (coercion-policy == $no-coercion)
+ make(<deque>, size: 13, fill: $z-value)
+ else
+ choose-by(even?,
+ range(from: 1, to: 26),
+ range(from: $a-value, to: $z-value))
+ end if;
+
+ check-true("Choose by test 1",
+ every?(method(result-record, answer-item)
+ let element-access = compose(truncate,
+ field-accessor,
+ rcurry(element, 0));
+ element-access(result-record) = answer-item;
+ end method,
+ result,
+ answer));
+end;
+
+define result-set-test choose-by-2("select col_2 from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-equal("Choose by test 2",
+ choose-by(even?, #(), result-set),
+ #());
+end;
+
+define result-set-test choose-by-3("select col_2 from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-equal("Choose by test 3",
+ choose-by(even?, result-set, #()),
+ #());
+end;
+
+
+define result-set-test intersection-1("select col_2 from dwsql order by col_2")
+ let element-access = compose(truncate, field-accessor, rcurry(element, 0));
+ let answer = if (coercion-policy = $no-coercion)
+ make(<list>, size: 3, fill: $z-value)
+ else
+ list(as(<integer>, 'm'),
+ as(<integer>, 'n'),
+ as(<integer>, 'o'))
+ end if;
+ let new-set = intersection(result-set, answer,
+ test: method (record, item)
+ element-access(record) = item
+ end method);
+
+ check-true("Intersection test 1",
+ every?(method (new-set-record)
+ let field = element-access(new-set-record);
+ member?(field, answer)
+ end method,
+ new-set));
+end;
+
+define result-set-test intersection-2("select col_2 from dwsql "
+ "where col_2 = 1 and col_2 = 0")
+ check-true("Intersection test 2",
+ empty?(intersection(result-set, #())));
+end;
+
+
+define result-set-test union-1("select col_1 from dwsql "
+ "where col_2 < 99")
+ let answer = #("a", "b", "c", "x", "y", "z");
+ let new-set = union(result-set, #(#("x"), #("y"), #("z")));
+
+ check-true("Union test 1",
+ every?(method (new-set-record)
+ member?(new-set-record[0], answer, test: \=)
+ end method,
+ new-set));
+end;
+
+/* need test for
+ remove-duplicates
+ remove-duplicates!
+ copy-sequence
+*/
+
+
+define result-set-test concatenate-1("select col_1 from dwsql "
+ "where col_1 < 'd'")
+ let ending = #(#("x"), #("y"), #("z"));
+ let heading = #(#("a"), #("b"), #("c"));
+ if (is-scrollable?)
+ let result = concatenate(result-set, ending);
+ check-equal("Concatenate 1 test",
+ result,
+ concatenate(heading, ending));
+ else
+ check-condition("Concatenate 1 test",
+ <data-not-available>,
+ concatenate(result-set, ending));
+ end if;
+end;
+
+
+define result-set-test concatenate-as-1("select col_1 from dwsql "
+ "where col_1 < 'd'")
+ if (is-scrollable?)
+ let answer = #("a", "b", "c", "x", "y", "z");
+
+ let result = concatenate-as(<list>,
+ result-set,
+ #(#("x"), #("y"), #("z")));
+
+ check-true("Concatenate-as 1 test",
+ instance?(result, <list>) &
+ every?(method(record)
+ let field = record[0];
+ member?(field, answer, test: \=)
+ end method,
+ result));
+ else
+ check-condition("Concatenate-as 1 test",
+ <data-not-available>,
+ concatenate-as(<list>,
+ result-set,
+ #(#("x"), #("y"), #("z"))));
+ end if;
+end;
+
+
+define result-set-test replace-subsequence!-1 ("select col_1 from dwsql")
+ check-condition("replace-subsequence! 1 test",
+ <result-set-mutation-error>,
+ replace-subsequence!(result-set, #("x", "y", "z"),
+ end: 1));
+end;
+
+
+define result-set-test reverse-1("select col_1 from dwsql order by col_1")
+ if (coercion-policy ~= $no-coercion)
+ check-equal("reverse 1 test",
+ reverse(result-set),
+ reverse($a-thru-z-list-list))
+ end if;
+end;
+
+
+define result-set-test sort-1("select col_1 from dwsql order by col_1 desc")
+ // sorting will only work on scrolling result-sets.
+ if (is-scrollable? = #t)
+ let result = sort(result-set,
+ test: method(a, b)
+ a[0] < b[0]
+ end method);
+
+ check-equal("Sort test 1", result, $a-thru-z-list-list);
+ end if;
+end;
+
+
+define result-set-test first-1("select col_1 from dwsql order by col_1")
+ let answer = if(coercion-policy = $no-coercion) 'a' else "a" end if;
+ let first-record = first(result-set);
+ check-equal("First test 1",
+ field-accessor(element(first-record, 0)),
+ answer);
+end;
+
+define result-set-test last-1("select col_1 from dwsql order by col_1")
+ if (is-scrollable?)
+ let last-record = last(result-set);
+ check-equal("Last test 1", last-record[0], "z");
+ end if;
+end;
+
+define result-set-test last-2("select * from dwsql "
+ "where col_2 = 0 and col_2 = 1")
+ check-true("Last test 2", last(result-set, default: #"ack") = #"ack");
+end;
+
+
+define result-set-test subsequence-position-1("select col_2 from dwsql "
+ "order by col_2")
+// check-false("subsequence-position test not implemented! "
+// "Need a damn debugger!!", #t);
+/* if (is-scrollable?)
+ check-equal("Subsequence-position test 1",
+ subsequence-position(result-set, #("l", "m", "n"),
+ test: method (record, pattern)
+ record[0] = pattern
+ end method),
+ as(<integer>, 'l') - as(<integer>, 'a'));
+ end if;*/
+end;
+
+
+
+define variable *collection-connection* = #f;
+
+define method create-collection-test-table()
+ with-connection(*collection-connection*)
+ let statement = make(<sql-statement>,
+ text: "create table dwsql (col_1 varchar(1), "
+ "col_2 number, col_3 number)",
+ input-indicator: $null-value);
+ execute(statement);
+
+ statement.text := "insert into dwsql(col_1, col_2, col_3) values(?, ?, ?)";
+ for (i from as(<integer>, 'a') to as(<integer>, 'z'))
+ execute(statement,
+ parameters: vector(as(<character>, i), i,
+ if (even?(i)) i else $null-value end if));
+ end for;
+ statement.close-statement
+ end with-connection;
+end method;
+
+define method collection-test-setup()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *collection-connection* := connect(database, user);
+ create-collection-test-table();
+ end with-dbms;
+end method;
+
+define method collection-test-cleanup()
+ with-connection(*collection-connection*)
+ execute("drop table dwsql");
+ end with-connection;
+ disconnect(*collection-connection*);
+ *collection-connection* := #f;
+end method;
+
+define suite collection-test-suite(setup-function: collection-test-setup,
+ cleanup-function: collection-test-cleanup)
+ test size-1;
+ test size-2;
+ test size-3;
+ test size-setter-1;
+
+ test empty?-1;
+ test empty?-2;
+
+ test element-1;
+ test element-2;
+ test element-3;
+
+ test map-1;
+ test map-2;
+ test map-3;
+ test map-4;
+
+ test map-as-1;
+ test map-as-2;
+
+ test map-into-1;
+
+ test any?-1;
+ test any?-2;
+
+ test every?-1;
+ test every?-2;
+
+ test reduce-1;
+ test reduce-2;
+
+ test member?-1;
+ test member?-2;
+ test member?-3;
+
+ test find-key-1;
+ test find-key-2;
+ test find-key-3;
+
+ test key-sequence-1;
+
+ test choose-1;
+
+ test choose-2;
+
+ test choose-by-1;
+ test choose-by-2;
+ test choose-by-3;
+
+ test intersection-1;
+ test intersection-2;
+
+ test union-1;
+
+ test concatenate-1;
+
+ test concatenate-as-1;
+
+ test replace-subsequence!-1;
+
+ test reverse-1;
+
+ test sort-1;
+
+ test first-1;
+
+ test last-1;
+ test last-2;
+
+ test subsequence-position-1;
+end suite;
+
Added: trunk/libraries/database/sql-odbc-test/connection-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/connection-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,101 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!connection-tests.dylan(trunk.3) $
+
+
+define test single-connection-test()
+ with-dbms(*the-dbms*)
+ check-condition("Connection test: bad datasource-name",
+ <connection-exception>,
+ block ()
+ let connection =
+ connect(make(<database>,
+ datasource-name: "bad-db-name"),
+ make(<user>,
+ user-name: *user-name*,
+ password: *user-password*));
+ // In the event a condition is not thrown, disconnect
+ // from the database.
+ disconnect(connection);
+ end block);
+
+ check("Connection test: good datasource-name",
+ method ()
+ let connection = connect(make(<database>,
+ datasource-name: *datasource-name*),
+ make(<user>,
+ user-name: *user-name*,
+ password: *user-password*));
+ disconnect(connection);
+ #t
+ end method);
+
+ check("Connection test: short-cut",
+ method ()
+ let db = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>,
+ user-name: *user-name*,
+ password: *user-password*);
+ let connection = connect(db, user);
+ disconnect(connection);
+ #t;
+ end method);
+ end with-dbms;
+
+ check-condition("Connection test: dbms not specified in connect call",
+ <dbms-not-specified>,
+ connect(make(<database>,
+ datasource-name: *datasource-name*),
+ make(<user>,
+ user-name: *user-name*,
+ password: *user-password*)));
+end test;
+
+define test multiple-connection-test()
+ with-dbms(*the-dbms*)
+ check("Multiple connections test",
+ method ()
+ let db = make(<odbc-database>,
+ datasource-name: *datasource-name*);
+ let user = make(<odbc-user>,
+ user-name: *user-name*,
+ password: *user-password*);
+ let a-connection = connect(db, user);
+ let b-connection = connect(db, user);
+ disconnect(a-connection);
+ disconnect(b-connection);
+ #t
+ end method);
+ end with-dbms;
+end test;
+
+define test misc-connection-functions-test()
+ with-dbms(*the-dbms*)
+ let con = connect(make(<odbc-database>,
+ datasource-name: *datasource-name*),
+ make(<odbc-user>, user-name: *user-name*,
+ password: *user-password*),
+ dbms: *the-dbms*);
+ check-equal("There is one connection in the list of connections.",
+ size(connections()), 1);
+ check-equal("And that connection is the one we created.",
+ connections()[0], con);
+ disconnect-all(dbms: make(<odbc-dbms>));
+ check-equal("It's still here.",size(connections()), 1);
+ disconnect-all();
+ check-equal("Now there are none---we disconnected everything.",
+ size(connections()), 0);
+ end with-dbms;
+end test;
+
+define suite connection-test-suite()
+ test single-connection-test;
+ test multiple-connection-test;
+ test misc-connection-functions-test;
+end suite;
Added: trunk/libraries/database/sql-odbc-test/creation-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/creation-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,62 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: DBdylan-sql-odbc-test!creation-tests.dylan(trunk.1) $
+
+
+define test dbms-make-test()
+ let dbms = make(*dbms-class*);
+ check-true(concatenate(*dbms-class-name*, " <dbms> make test"),
+ instance?(dbms, *dbms-class*));
+ check-condition("invalid <dbms> make test", <condition>, make(<dbms>));
+end test;
+
+
+define test user-make-test()
+ let dbms = make(*dbms-class*);
+
+ check-true(concatenate(*dbms-class-name*, " <user> make test"),
+ instance?(make(*dbms-user-class*), *dbms-user-class*));
+
+ check-true(concatenate(*dbms-class-name*, " <user> short-cut make test"),
+ with-dbms(dbms)
+ instance?(make(<user>), *dbms-user-class*)
+ end with-dbms);
+
+ check-condition("<user> invalid short-cut make test",
+ <dbms-not-specified>,
+ make(<user>));
+end test;
+
+
+define test database-make-test()
+ let dbms = make(*dbms-class*);
+ check-true(concatenate(*dbms-class-name*, " <database> make test"),
+ instance?(make(*dbms-database-class*,
+ datasource-name: *datasource-name*),
+ *dbms-database-class*));
+
+ check-true(concatenate(*dbms-class-name*, " <database> short-cut make test"),
+ with-dbms(dbms)
+ instance?(make(<database>,
+ datasource-name: *datasource-name*),
+ *dbms-database-class*)
+ end with-dbms);
+
+ check-condition("<database> invalid short-cut make test",
+ <dbms-not-specified>,
+ make(<database>));
+end test;
+
+
+define suite creation-test-suite()
+ test dbms-make-test;
+ test user-make-test;
+ test database-make-test;
+end suite;
+
Added: trunk/libraries/database/sql-odbc-test/datatype-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/datatype-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,135 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: DBdylan-sql-odbc-test!datatype-tests.dylan(trunk.2) $
+
+define constant $a-thru-z-range = make(<range>, from: $a-value, to: $z-value);
+
+define generic float-equal(float-1 :: <float>, float-2 :: <float>)
+ => (equal? :: <boolean>);
+
+define method float-equal(float-1 :: <float>, float-2 :: <float>)
+ => (equal? :: <boolean>)
+ abs(float-1 - float-2) < 0.5s5;
+end method;
+
+
+define test float-test()
+ with-connection(*datatype-connection*)
+ with-transaction()
+ let answer = map(curry(\*, 1.1), $a-thru-z-range);
+ let query = make(<sql-statement>,
+ text: "select col_3 from dwsql order by col_3");
+ let result-set = execute(query);
+
+ check-true("Double float test",
+ every?(method(record, answer-item)
+ check-true("Record element of type float",
+ instance?(record[0], <float>));
+ float-equal(record[0], answer-item);
+ end method,
+ result-set,
+ answer));
+ query.close-statement
+ end with-transaction;
+ end with-connection;
+end test;
+
+define test date-test()
+ with-connection(*datatype-connection*)
+ with-transaction()
+ let answer = make(<date>, year: 1997, month: 1, day: 1);
+ let query = make(<sql-statement>,
+ text: "select col_4 from dwsql");
+ let result-set = execute(query);
+ check-true("Date test",
+ every?(method(record)
+ instance?(record[0], <date>) &
+ record[0] = answer;
+ end method,
+ result-set));
+ query.close-statement
+ end with-transaction;
+ end with-connection;
+end test;
+
+define test string-test()
+ with-connection(*datatype-connection*)
+ with-transaction()
+ let answer = map(integer-to-string,
+ make(<range>, from: $a-value, to: $z-value));
+ let query = make(<sql-statement>, text: "select col_5 from dwsql");
+ let result-set = execute(query);
+ check-true("String test",
+ every?(method(record)
+ instance?(record[0], <string>) &
+ member?(record[0], answer, test: \=)
+ end method,
+ result-set));
+ query.close-statement
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+
+define method create-datatype-test-table()
+ with-connection(*datatype-connection*)
+ let statement = make(<sql-statement>,
+ text: "create table dwsql (col_1 varchar(1), "
+ "col_2 number, col_3 number, col_4 date, "
+ "col_5 varchar(5))",
+ input-indicator: $null-value);
+ execute(statement);
+ close-statement(statement);
+
+ let statement
+ = make(<sql-statement>,
+ text: "insert into dwsql(col_1, col_2, col_3, col_4, col_5)"
+ "values(?, ?, ?, ?, ?)");
+
+ for (i from as(<integer>, 'a') to as(<integer>, 'z'))
+ execute(statement,
+ parameters: vector(as(<character>, i),
+ i,
+ i * 1.1,
+ make(<date>, year: 1997, month: 1, day: 1),
+ integer-to-string(i)));
+ end for;
+ close-statement(statement)
+ end with-connection;
+end method;
+
+
+define variable *datatype-connection* = #f;
+
+define method datatype-test-setup()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *datatype-connection* := connect(database, user);
+ create-datatype-test-table();
+ end with-dbms;
+end method;
+
+define method datatype-test-cleanup()
+ with-connection(*datatype-connection*)
+ execute("drop table dwsql");
+ end with-connection;
+ disconnect(*datatype-connection*);
+ *datatype-connection* := #f;
+end method;
+
+
+define suite datatype-test-suite(setup-function: datatype-test-setup,
+ cleanup-function: datatype-test-cleanup)
+ test float-test;
+ test date-test;
+ test string-test;
+end suite;
+
Added: trunk/libraries/database/sql-odbc-test/ddl-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/ddl-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,68 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: DBdylan-sql-odbc-test!ddl-tests.dylan(trunk.3) $
+
+
+define test create-table-test()
+ with-connection(*ddl-connection*)
+ let stmt = make(<sql-statement>,
+ text: "create table dwsql (col_1 char(50), col_2 integer)");
+ let result = execute(stmt);
+ check-true("Create table test: "
+ "result is instance of <empty-result-set>",
+ instance?(result, <empty-result-set>));
+
+ let result = execute("drop table dwsql");
+ check-true("Create table test: "
+ "result is instance of <empty-result-set>",
+ instance?(result, <empty-result-set>));
+ close-statement(stmt)
+ end with-connection;
+end test;
+
+
+define test create-duplicate-table-test()
+ with-connection(*ddl-connection*)
+ local method create-table()
+ let stmt = make(<sql-statement>,
+ text: "create table dwsql (col_1 char(50), "
+ "col_2 integer)");
+ execute(stmt);
+ close-statement(stmt)
+ end method;
+
+ create-table();
+ check-condition("Duplicate table creation test",
+ <syntax-error-or-access-rule-violation>,
+ create-table());
+ let result = execute("drop table dwsql");
+ end with-connection;
+end test;
+
+
+define variable *ddl-connection* = #f;
+
+define method ddl-test-setup() => ()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *ddl-connection* := connect(database, user);
+ end with-dbms;
+end method;
+
+define method ddl-test-cleanup() => ()
+ disconnect(*ddl-connection*);
+ *ddl-connection* := #f;
+end method;
+
+define suite ddl-test-suite(setup-function: ddl-test-setup,
+ cleanup-function: ddl-test-cleanup)
+ test create-table-test;
+ test create-duplicate-table-test;
+end suite;
Added: trunk/libraries/database/sql-odbc-test/dml-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/dml-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,192 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!dml-tests.dylan(trunk.3) $
+
+
+// Destructures the first record returned from a query.
+define macro execute-singleton
+ { execute-singleton(?body:*) }
+ => { let result-set = execute(?body);
+ if (instance?(result-set, <empty-result-set>))
+ signal("Execute-singleton: query returned an empty result-set\n");
+ end if;
+ let first-record = element(result-set, 0);
+ apply(values, first-record);
+ }
+end macro;
+
+define test insertion-test()
+ insertion-test-body();
+end test;
+define function insertion-test-body()
+ with-connection(*dml-connection*)
+ block (exit)
+ // Need to set an isolation level in the first transaction to work
+ // around a MySQL bug. Normally, you'd just use the default.
+ with-transaction(isolation-level: serializable)
+ execute("create table dwsql (col_1 varchar(1), col_2 integer)");
+
+ let stmt = make(<sql-statement>,
+ text: "insert into dwsql (col_1, col_2) values(?, ?)");
+ for (i from as(<integer>, 'a') to as(<integer>, 'z'))
+ execute(stmt, parameters: vector(as(<character>, i), i));
+ end for;
+
+ let count = execute-singleton("select count(*) from dwsql",
+ datatype-hints: vector(<sql-integer>),
+ coercion-policy: $no-coercion);
+ check("Insertion-test Check count", \=, count.pointer-value, 26);
+ close-statement(stmt);
+ end with-transaction;
+
+ cleanup
+ execute("drop table dwsql");
+ end block;
+ end with-connection;
+end function;
+
+
+define test null-insertion-test-1()
+ null-insertion-test-1-body();
+end test;
+define function null-insertion-test-1-body()
+ with-connection(*dml-connection*)
+ block (exit)
+ with-transaction()
+ execute("create table dwsql (col_1 varchar(1), col_2 integer)");
+
+ let statement = make(<sql-statement>,
+ text: "insert into dwsql(col_1, col_2) "
+ "values(?, ?)",
+ input-indicator: $null-value);
+ execute(statement, parameters: vector('a', $null-value));
+
+
+ let count = execute-singleton("select count(*) from dwsql "
+ "where col_2 is null",
+ datatype-hints: vector(<sql-integer>),
+ coercion-policy: $no-coercion);
+ check("null-insertion-test-1 Check count", \=, count.pointer-value, 1);
+ close-statement(statement);
+ end with-transaction;
+
+ cleanup
+ execute("drop table dwsql");
+ end block;
+ end with-connection;
+end function;
+
+
+
+define test null-insertion-test-2()
+ null-insertion-test-2-body();
+end test;
+define function null-insertion-test-2-body()
+ // Uses a domain value (-1) to indicate null-value
+ with-connection(*dml-connection*)
+ block (exit)
+ with-transaction()
+ execute("create table dwsql (col_1 varchar(1), col_2 integer)");
+
+ let statement = make(<sql-statement>,
+ text: "insert into dwsql(col_1, col_2) "
+ "values('a', ?)",
+ input-indicator: -1);
+ execute(statement, parameters: vector(-1));
+
+ let count = execute-singleton("select count(*) from dwsql "
+ "where col_2 is null",
+ datatype-hints: vector(<sql-integer>),
+ coercion-policy: $no-coercion);
+ check("Null-insertion-test-2 Check count", \=, count.pointer-value, 1);
+ close-statement(statement);
+ end with-transaction;
+
+ cleanup
+ execute("drop table dwsql");
+ end block;
+ end with-connection;
+end function;
+
+
+define test null-selection-test()
+ null-selection-test-body();
+end test;
+define function null-selection-test-body()
+ with-connection(*dml-connection*)
+ block (exit)
+ with-transaction()
+ execute("create table dwsql (col_1 varchar(1), col_2 integer)");
+
+ let insert-statement = make(<sql-statement>,
+ text: "insert into dwsql(col_1, col_2) "
+ "values(?, ?)",
+ input-indicator: $null-value);
+
+ for (i :: <integer> from as(<integer>, 'a') to as(<integer>, 'z'))
+ execute(insert-statement,
+ parameters: vector(if (even?(i))
+ $null-value
+ else
+ as(<character>, i)
+ end if,
+ i));
+ end for;
+
+ let query-statement
+ = make(<sql-statement>,
+ text: "select col_1, col_2 from dwsql",
+ output-indicator: $null-value,
+ datatype-hints: vector(<sql-character-varying>, <sql-integer>),
+ coercion-policy: $no-coercion);
+ let result = execute(query-statement);
+ let null-count = 0;
+
+ for (record in result)
+ let col1 = record[0];
+ let col2 = record[1];
+ if (even?(col2.pointer-value) & col1 == $null-value)
+ null-count := null-count + 1;
+ end if;
+ end for;
+
+ check("Null-selection-test Check count", \=, null-count, 13);
+ close-statement(insert-statement);
+ close-statement(query-statement);
+ end with-transaction;
+
+ cleanup
+ execute("drop table dwsql");
+ end block;
+ end with-connection;
+end function;
+
+
+define variable *dml-connection* = #f;
+
+define method dml-test-setup() => ()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *dml-connection* := connect(database, user);
+ end with-dbms;
+end method;
+
+define method dml-test-cleanup() => ()
+ disconnect(*dml-connection*);
+ *dml-connection* := #f;
+end method;
+
+define suite dml-test-suite(setup-function: dml-test-setup,
+ cleanup-function: dml-test-cleanup)
+ test insertion-test;
+ test null-insertion-test-1;
+ test null-insertion-test-2;
+ test null-selection-test;
+end suite;
Added: trunk/libraries/database/sql-odbc-test/introspection-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/introspection-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,149 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+// $HopeName: D-databases-sql-odbc-test!introspection-tests.dylan(trunk.6) $
+define test resource-stress-test()
+ let catalog-list = catalogs(connection: *introspection-connection*);
+ for (catalog :: <odbc-catalog> in catalog-list)
+ for (schema :: <schema> in catalog)
+ for (a-table :: <sql-table> in schema)
+ for (column :: <column> in a-table)
+ end for;
+
+ for (index :: <index> in indexes(a-table))
+ end for;
+ end for;
+ end for;
+ end for;
+end test;
+
+define test simple-introspection-test()
+ let table-found? = #f;
+ let catalog-list = catalogs(connection: *introspection-connection*);
+ for (catalog :: <odbc-catalog> in catalog-list)
+ for (schema :: <schema> in catalog)
+ for (a-table :: <sql-table> in schema)
+ if (a-table.database-object-name.as-lowercase = "dwsql")
+ table-found? := #t;
+ examine-columns(a-table);
+ examine-indices(a-table);
+ end if;
+ end for;
+ end for;
+ end for;
+ check-true("dwsql table found", table-found?);
+end test;
+
+define method examine-columns(a-table :: <sql-table>)
+ => ()
+ check-true("Table name is dwsql",
+ as-lowercase(a-table.database-object-name) = "dwsql");
+ check-true("Table dwsql has two columns", a-table.size = 2);
+ for (column keyed-by column-index :: <column> in a-table)
+ check-true("Column is col_1 or col_2",
+ as-lowercase(column.database-object-name) = "col_1"
+ | as-lowercase(column.database-object-name) = "col_2");
+
+ if (*detect-null-column* = #t)
+ select (as-lowercase(column.database-object-name) by \=)
+ "col_1" => check-true("Column is nullable", column.nullable?);
+ "col_2" => check-false("Column is not nullable", column.nullable?);
+ end select;
+ end if;
+
+ // What about testing the column's domain?
+ end for;
+end method;
+
+define method examine-indices(table :: <sql-table>)
+ let count :: <integer> = 0;
+ for (index in indexes(table))
+ count := count + 1;
+ let index-name = as-lowercase(index.database-object-name);
+ check-true("Index has a name we expected",
+ index-name = "index1" | index-name = "index2" | index-name = "indexboth");
+ select (index-name by \=)
+ "index1" =>
+ check-true("Index1 - column count = 1", index.fields.size = 1);
+ check-true("Index1 - Indexed field is col_1",
+ as-lowercase(index.fields[0].database-object-name) = "col_1");
+ "index2" =>
+ check-true("Index1 - column count = 1", index.fields.size = 1);
+ check-true("Index1 - Indexed field is col_2",
+ as-lowercase(index.fields[0].database-object-name) = "col_2");
+ "indexboth" =>
+ check-true("Indexboth - column count = 2", index.fields.size = 2);
+ check-true("Indexboth - Indexed fields are col_1 and col_2",
+ begin
+ let field-0 = as-lowercase(index.fields[0].database-object-name);
+ let field-1 = as-lowercase(index.fields[1].database-object-name);
+ (field-0 = "col_1" & field-1 = "col_2") |
+ (field-0 = "col_2" & field-1 = "col_1")
+ end);
+ end select
+ end for;
+ check-equal("Three indices total", count, 3);
+end method;
+
+define method examine-constraints(table :: <sql-table>)
+// check-true("We need to know what constraints are all about!",#f);
+end method;
+
+define variable *introspection-connection* = #f;
+
+define method create-introspection-test-table()
+ with-connection(*introspection-connection*)
+ execute("create table dwsql (col_1 char(50), col_2 number not null)");
+
+ execute("create index index1 on dwsql (col_1)");
+ execute("create index index2 on dwsql (col_2)");
+ execute("create index indexboth on dwsql (col_1, col_2)");
+ end with-connection;
+end method;
+
+
+define method introspection-test-setup()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *introspection-connection* := connect(database, user);
+ create-introspection-test-table();
+ end with-dbms;
+end method;
+
+
+define method introspection-test-cleanup()
+ with-connection(*introspection-connection*)
+ execute("drop table dwsql");
+ end with-connection;
+ disconnect(*introspection-connection*);
+ *introspection-connection* := #f;
+end method;
+
+define suite introspection-test-suite
+ (setup-function: introspection-test-setup,
+ cleanup-function: introspection-test-cleanup)
+ test simple-introspection-test;
+ // Until the GC is fixed, it is not possible to run this unless you
+ // bump the VM up to something like 300MB and wait a few hours for
+ // it to complete.
+ //test resource-stress-test;
+end suite;
+
+
+
+
+
+
+
+
+
+
+
+
+
Added: trunk/libraries/database/sql-odbc-test/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/library.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,55 @@
+Module: dylan-user
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!library.dylan(trunk.4) $
+
+define library sql-odbc-test
+ use common-dylan;
+ use threads;
+ use sql-odbc;
+
+ use io;
+ use system;
+ use melange-support;
+
+ use testworks;
+
+ export sql-odbc-test;
+end library;
+
+define module sql-odbc-test-include
+ create
+ *datasource-name*,
+ *user-name*,
+ *user-password*,
+ *the-dbms*,
+ *detect-null-column*,
+ *do-introspection*,
+ *dbms-class*,
+ *dbms-class-name*,
+ *dbms-user-class*,
+ *dbms-database-class*,
+ *dbms-sql-statement-class*;
+end module;
+
+define module sql-odbc-test
+ use common-dylan, // common-dylan lib
+ exclude: { format-to-string };
+ use threads; // threads lib
+ use sql-odbc; // sql-odbc lib
+
+ use format-out; // io lib
+ use format; // io lib
+ use date; // system lib
+ use operating-system; // system lib
+ use melange-support; // melange-support lib
+
+ use testworks; // testworks lib
+ use sql-odbc-test-include;
+end module;
+
Added: trunk/libraries/database/sql-odbc-test/query-tests.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/query-tests.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,357 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!query-tests.dylan(trunk.7) $
+
+
+define test forward-only-query-test()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_1, col_2 from dwsql");
+ let result-set = execute(query);
+ check-true("forward-only result-set query test: "
+ "result set instance of <forward-only-result-set",
+ instance?(result-set, <forward-only-result-set>));
+ let result-set-size = result-set.size;
+ check-true("forward-only result-set query test: result-set size check",
+ result-set-size = 26);
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+define test explicit-coercion-query-test()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_1, col_2 from dwsql",
+ coercion-policy: vector(curry(as, <byte-string>),
+ curry(as, <integer>)));
+ let result-set = execute(query);
+ check-true("Explicit coercion result-set test: "
+ "result set instance of <forward-only-result-set>",
+ instance?(result-set, <forward-only-result-set>));
+
+ let record-count :: <integer> = 0;
+ let not-found = pair(#f, #f);
+ let col-1 = #f;
+ let col-2 = #f;
+
+ check-true("Explicit coercion result-set test, structure check",
+ every?(method(record)
+ record-count := record-count + 1;
+ col-1 := element(record, 0, default: not-found);
+ col-2 := element(record, 1, default: not-found);
+
+ instance?(record, <simple-object-vector>) &
+ col-1 ~== not-found
+ & col-2 ~== not-found &
+ instance?(col-1, <byte-string>) &
+ instance?(col-2, <integer>)
+ end method,
+ result-set));
+
+ check-true("Explicit coercion result-set test: result-set size check",
+ record-count = 26);
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+define test default-coercion-query-test()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_1, col_2 from dwsql",
+ coercion-policy: #"default-coercion");
+ let result-set = execute(query);
+
+ check-true("Coercion result-set query test 2: "
+ "result set instance of <forward-only-result-set>",
+ instance?(result-set, <forward-only-result-set>));
+
+ let record-count :: <integer> = 0;
+ let not-found = pair(#f, #f);
+ let col-1 = #f;
+ let col-2 = #f;
+
+ check-true("Coercion result-set-query test 2",
+ every?(method(record)
+ record-count := record-count + 1;
+ col-1 := element(record, 0, default: not-found);
+ col-2 := element(record, 1, default: not-found);
+
+ instance?(record, <simple-object-vector>) &
+ col-1 ~== not-found &
+ col-2 ~== not-found &
+ instance?(col-1, <byte-string>) &
+ instance?(col-2, <number>)
+ end method,
+ result-set));
+ check-true("Coercion result-set query test 2: result-set size check",
+ record-count = 26);
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+//-------------------- liaison-query test --------------------
+
+define class <ack> (<object>)
+ constant slot col-1, init-keyword: col-1:;
+
+ constant slot col-2, init-keyword: col-2:;
+end class;
+
+define test liaison-query-test()
+ local method liaison-fn(rec :: <record>)
+ make(<ack>, col-1: rec[0], col-2: rec[1]);
+ end method;
+
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_1, col_2 from dwsql",
+ coercion-policy: #"default-coercion");
+ let result-set = execute(query, liaison: liaison-fn);
+
+ let record-count :: <integer> = 0;
+
+ check-true("Liaison query test",
+ every?(method(record)
+ record-count := record-count + 1;
+ instance?(record, <ack>);
+ end method,
+ result-set));
+
+ check-true("Liaison query test: result-size check", record-count = 26);
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+//-------------------- null test -------------------
+
+define test null-query-test()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_1, col_3 from dwsql",
+ output-indicator: $null-value,
+ coercion-policy: #"default-coercion");
+ let result-set = execute(query, liaison: identity);
+ let not-found = pair(#f, #f);
+ let record-count :: <integer> = 0;
+ let col-1 = #f;
+ let col-3 = #f;
+
+ check-true("Null query test",
+ every?(method(record)
+ record-count := record-count + 1;
+ col-1 := element(record, 0, default: not-found);
+ col-3 := element(record, 1, default: not-found);
+
+ col-1 ~== not-found &
+ col-3 ~== not-found &
+ instance?(col-1, <string>) &
+ col-3 = $null-value
+ end method,
+ result-set));
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+//-------------------- scrollable test -------------------
+
+define test scrollable-query-test-1()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_2 from dwsql order by col_2",
+ datatype-hints: vector(<sql-integer>));
+ let result-set
+ = execute(query, result-set-policy: $scrollable-result-set-policy);
+
+ check-true("Scrollable result-set identity test",
+ instance?(result-set, <scrollable-result-set>));
+ check-true("Scrollable result-set test 1",
+ every?(method (record, answer)
+ record[0] = answer
+ end method,
+ result-set,
+ make(<range>, from: $a-value, to: $z-value)));
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+define test scrollable-query-test-2()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_2 from dwsql order by col_2",
+ datatype-hints: vector(<sql-integer>));
+ let result-set = execute(query,
+ result-set-policy: $scrollable-result-set-policy);
+
+ check-true("Scrollable result-set test 2",
+ every?(method (record, answer)
+ record[0] = answer
+ end method,
+ result-set,
+ make(<range>, from: $a-value, to: $z-value)));
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+define test scrollable-query-test-3()
+ with-connection(*query-connection*)
+ with-transaction()
+ let query = #f;
+ block ()
+ query := make(<sql-statement>,
+ text: "select col_2 from dwsql order by col_2",
+ datatype-hints: vector(<sql-integer>));
+ let result-set = execute(query,
+ result-set-policy: $scrollable-result-set-policy);
+ check-true("Scrollable query test 3",
+ result-set[25][0] = as(<integer>, 'z') &
+ result-set[0][0] = as(<integer>, 'a') &
+ result-set[12][0] = as(<integer>, 'm'));
+ cleanup
+ query.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end test;
+
+define test multiple-queries()
+ with-connection(*query-connection*)
+ check-true("Multiple queries on same sql-statement",
+ begin
+ let query = #f;
+ block ()
+ with-transaction ()
+ let query = make(<sql-statement>,
+ text: "select col_2 from dwsql where col_2 > ?",
+ datatype-hints: vector(<sql-integer>));
+ let result-set = execute(query, parameters: vector(10));
+ let result-set = execute(query, parameters: vector(10));
+ query.close-statement
+ end with-transaction;
+ #t;
+ exception (condition :: <diagnostic>)
+ #f;
+ end block;
+ end);
+ end with-connection;
+end test;
+
+define method create-query-test-table()
+ with-connection(*query-connection*)
+ with-transaction()
+ let statement = #f;
+ block ()
+ statement := make(<sql-statement>,
+ text: "create table dwsql (col_1 varchar(1), "
+ "col_2 number, col_3 number)",
+ input-indicator: $null-value);
+ execute(statement);
+
+ statement.text := "insert into dwsql(col_1, col_2, col_3)"
+ "values(?, ?, ?)";
+ for (i from as(<integer>, 'a') to as(<integer>, 'z'))
+ execute(statement,
+ parameters: vector(as(<character>, i), i, $null-value));
+ end for;
+ cleanup
+ statement.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+end method;
+
+
+define variable *query-connection* = #f;
+
+define method query-test-setup()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *query-connection* := connect(database, user);
+ create-query-test-table();
+ end with-dbms;
+end method;
+
+define method query-test-cleanup()
+ with-connection(*query-connection*)
+ with-transaction()
+ let statement = #f;
+ block ()
+ statement := make(<sql-statement>, text: "drop table dwsql");
+ execute(statement);
+ cleanup
+ statement.close-statement
+ end block;
+ end with-transaction;
+ end with-connection;
+ disconnect(*query-connection*);
+ *query-connection* := #f;
+end method;
+
+
+define suite query-test-suite(setup-function: query-test-setup,
+ cleanup-function: query-test-cleanup)
+ test forward-only-query-test;
+ test explicit-coercion-query-test;
+ test default-coercion-query-test;
+ test liaison-query-test;
+ test null-query-test;
+ test scrollable-query-test-1;
+ test scrollable-query-test-2;
+ test scrollable-query-test-3;
+ test multiple-queries;
+end suite;
+
Added: trunk/libraries/database/sql-odbc-test/sql-odbc-test.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/sql-odbc-test.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,175 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!sql-odbc-test.dylan(trunk.5) $
+
+
+define constant $access-db-name = "access";
+define constant $access-user-name = "";
+define constant $access-user-password = "";
+define constant $access-detect-null-column = #f;
+define constant $access-do-introspection = #f;
+
+define constant $oracle-db-name = "phantom";
+define constant $oracle-user-name = "j2";
+define constant $oracle-user-password = "j2";
+define constant $oracle-detect-null-column = #t;
+define constant $oracle-do-introspection = #t;
+
+define constant $oracle8-db-name = "ORA8";
+define constant $oracle8-user-name = "scott";
+define constant $oracle8-user-password = "tiger";
+define constant $oracle8-detect-null-column = #t;
+define constant $oracle8-do-introspection = #t;
+
+define constant $mysql-db-name = "mysqltest";
+define constant $mysql-user-name = "";
+define constant $mysql-user-password = "";
+define constant $mysql-detect-null-column = #t;
+define constant $mysql-do-introspection = #t;
+
+define constant $ms-sql-server-db-name = "viral";
+define constant $ms-sql-server-user-name = "viral";
+define constant $ms-sql-server-user-password = "viral";
+define constant $ms-sql-server-detect-null-column = #t;
+define constant $ms-sql-server-do-introspection = #t;
+define constant $dbms-table
+ = vector(vector(<odbc-dbms>, "ODBC", <odbc-user>, <odbc-database>,
+ <odbc-sql-statement>));
+
+
+define variable *datasource-name* :: <string> = "";
+define variable *user-name* :: <string> = "";
+define variable *user-password* :: <string> = "";
+define variable *the-dbms* = #f;
+define variable *detect-null-column* = #t;
+define variable *do-introspection* = #t;
+
+define variable *dbms-class* = <dbms>;
+define variable *dbms-class-name* :: <string> = "";
+define variable *dbms-user-class* = <user>;
+define variable *dbms-database-class* = <database>;
+define variable *dbms-sql-statement-class* = <sql-statement>;
+
+
+define function pristine-database(dbms :: <dbms>)
+ with-dbms(dbms)
+ with-database(make(<database>, datasource-name: *datasource-name*),
+ make(<user>, user-name: *user-name*,
+ password: *user-password*))
+ block ()
+ execute("drop table dwsql");
+ execute("drop table trans_table");
+ exception (condition :: <condition>)
+ end block;
+ end with-database;
+ end with-dbms;
+end function;
+
+define method make-datasource-table(arguments :: <sequence>)
+ => (table :: <sequence>)
+ let table = make(<deque>);
+
+ if (member?("-oracle", arguments, test: \=))
+ add!(table, vector($oracle-db-name, $oracle-user-name,
+ $oracle-user-password, $oracle-detect-null-column,
+ $oracle-do-introspection));
+ end if;
+
+ if (member?("-oracle8", arguments, test: \=))
+ add!(table, vector($oracle8-db-name, $oracle8-user-name,
+ $oracle8-user-password, $oracle8-detect-null-column,
+ $oracle8-do-introspection));
+ end if;
+
+ if (member?("-access", arguments, test: \=))
+ add!(table, vector($access-db-name, $access-user-name,
+ $access-user-password, $access-detect-null-column,
+ $access-do-introspection));
+ end if;
+
+ if (member?("-ms-sql-server", arguments, test: \=))
+ add!(table, vector($ms-sql-server-db-name, $ms-sql-server-user-name,
+ $ms-sql-server-user-password,
+ $ms-sql-server-detect-null-column,
+ $ms-sql-server-do-introspection));
+ end if;
+
+ if (member?("-mysql", arguments, test: \=))
+ add!(table, vector($mysql-db-name, $mysql-user-name,
+ $mysql-user-password,
+ $mysql-detect-null-column,
+ $mysql-do-introspection));
+ end if;
+
+ when (empty?(table))
+ format-out("No arguments supplied: pass one or more of the following:\n"
+ "-oracle, -oracle8, -access, -ms-sql-server, -mysql\n");
+ exit-application(-1);
+ end;
+ table
+end method make-datasource-table;
+
+define method main
+ (application-name :: <string>, arguments :: <sequence>)
+ => (exit-code :: <integer>)
+ ignore(application-name);
+ block (exit)
+ *odbc-print-condition* := #t;
+ *odbc-report-success-with-info* := #f;
+ *debug?* := #t; //#"crashed";
+
+ for (dbms in $dbms-table)
+ *dbms-class* := dbms[0];
+ *dbms-class-name* := dbms[1];
+ *dbms-user-class* := dbms[2];
+ *dbms-database-class* := dbms[3];
+ *dbms-sql-statement-class* := dbms[4];
+
+ for (datasource in make-datasource-table(arguments))
+ *datasource-name* := datasource[0];
+ *user-name* := datasource[1];
+ *user-password* := datasource[2];
+ *detect-null-column* := datasource[3];
+ *do-introspection* := datasource[4];
+
+ format-out("*** Testing database %s\n", *datasource-name*);
+ perform-suite(creation-test-suite);
+ *the-dbms* := make(*dbms-class*);
+
+ pristine-database(*the-dbms*);
+
+ perform-suite(connection-test-suite);
+ perform-suite(ddl-test-suite);
+ perform-suite(dml-test-suite);
+ perform-suite(query-test-suite);
+ perform-suite(collection-test-suite);
+ perform-suite(transaction-test-suite);
+ perform-suite(datatype-test-suite);
+ if (*do-introspection*)
+ perform-suite(introspection-test-suite);
+ end if;
+ end for;
+ end for;
+ end block;
+ 0;
+end method main;
+
+
+block (exit)
+ let handler <sql-warning> =
+ method(diag, next-handler)
+ let next-diag = next-dbms-diagnostic(diag);
+ unless (next-diag = #f)
+ format-out("*** Handling sql-warning - next diagnostic: %=\n", next-diag);
+ signal(next-diag);
+ exit();
+ end unless;
+ end method;
+ main(application-name(), application-arguments());
+end block;
Added: trunk/libraries/database/sql-odbc-test/sql-odbc-test.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/sql-odbc-test.lid Fri Sep 28 06:22:17 2007
@@ -0,0 +1,22 @@
+library: sql-odbc-test
+executable: sql-odbc-test
+files: library
+ creation-tests
+ connection-tests
+ ddl-tests
+ dml-tests
+ query-tests
+ collection-tests
+ transaction-test
+ datatype-tests
+ introspection-tests
+ sql-odbc-test
+major-version: 2
+minor-version: 1
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+Other-files: Open-Source-License.txt
+
Added: trunk/libraries/database/sql-odbc-test/transaction-test.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc-test/transaction-test.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,124 @@
+Module: sql-odbc-test
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+//$HopeName: D-databases-sql-odbc-test!transaction-test.dylan(trunk.4) $
+
+
+define test transaction-test-1()
+ with-connection(*transaction-connection*)
+ check-true("Transaction test 1 - empty transaction body",
+ begin
+ with-transaction()
+ end with-transaction;
+ #t
+ end);
+ end with-connection;
+end test;
+
+
+define test transaction-test-2()
+ with-connection(*transaction-connection*)
+ with-transaction(rollback: do-rollback, commit: do-commit)
+ check-true("Transaction test 2 - rollback function",
+ instance?(do-rollback, <function>));
+ check-true("Transaction test 2 - commit function",
+ instance?(do-commit, <function>));
+ end with-transaction;
+ end with-connection;
+end test;
+
+
+define test transaction-test-3()
+ with-transaction(transaction-mode: read-only,
+ diagnostics-size: 10,
+ connection: *transaction-connection*)
+ let connection = default-connection();
+/* check-equal("Transaction test 3 - transaction mode",
+ connection.attributes.transaction-mode,
+ $read-only);
+ check-equal("Transaction test 3 - diagnostics size",
+ connection.attributes.diagnostics-size,
+ 10);*/
+ end with-transaction;
+end test;
+
+
+define test transaction-test-4()
+ with-connection(*transaction-connection*)
+ block ()
+ let statement = make(<sql-statement>,
+ text: "create table trans_table (col_1 number)");
+ execute(statement);
+
+ statement.text := "create unique index trans_index "
+ "on trans_table(col_1)";
+ execute(statement);
+
+ with-transaction()
+ statement.text := "insert into trans_table(col_1) values(?)";
+ execute(statement, parameters: vector(1));
+ execute(statement, parameters: vector(2));
+ check-condition("Transaction test 4 - integrity constraint violation",
+ <integrity-constraint-violation>,
+ execute(statement, parameters: vector(2)));
+ end with-transaction;
+ close-statement(statement);
+ cleanup
+ let statement = make(<sql-statement>,
+ text: "drop table trans_table");
+ execute(statement);
+ close-statement(statement);
+ end block;
+ end with-connection;
+end test;
+
+
+define variable *transaction-connection* = #f;
+
+define method create-transaction-test-table()
+ with-connection(*transaction-connection*)
+ let statement = make(<sql-statement>,
+ text: "create table dwsql (col_1 varchar(1), "
+ "col_2 number, col_3 number)",
+ input-indicator: $null-value);
+ execute(statement);
+
+ statement.text := "insert into dwsql(col_1, col_2, col_3) values(?, ?, ?)";
+ for (i from as(<integer>, 'a') to as(<integer>, 'z'))
+ execute(statement,
+ parameters: vector(as(<character>, i), i,
+ if (even?(i)) i else $null-value end if));
+ end for;
+ close-statement(statement);
+ end with-connection;
+end method;
+
+define method transaction-test-setup()
+ with-dbms(*the-dbms*)
+ let database = make(<database>, datasource-name: *datasource-name*);
+ let user = make(<user>, user-name: *user-name*, password: *user-password*);
+ *transaction-connection* := connect(database, user);
+ create-transaction-test-table();
+ end with-dbms;
+end method;
+
+define method transaction-test-cleanup()
+ with-connection(*transaction-connection*)
+ execute("drop table dwsql");
+ end with-connection;
+ disconnect(*transaction-connection*);
+ *transaction-connection* := #f;
+end method;
+
+define suite transaction-test-suite(setup-function: transaction-test-setup,
+ cleanup-function: transaction-test-cleanup)
+ test transaction-test-1;
+ test transaction-test-2;
+ test transaction-test-3;
+ test transaction-test-4;
+end suite;
Added: trunk/libraries/database/sql-odbc/Makefile
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/Makefile Fri Sep 28 06:22:17 2007
@@ -0,0 +1,10 @@
+SOURCES = sql/*.dylan \
+ sql-odbc/*.dylan
+
+LIBPATH = ../odbc-ffi
+
+sql-odbc.lib.du: sql-odbc.lid $(SOURCES)
+ d2c --debug -L $(LIBPATH) sql-odbc.lid
+
+clean:
+ -rm -rf *.o *.s *.a *.c *.mak *.el *~ sql-odbc.lib.du
Added: trunk/libraries/database/sql-odbc/README
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/README Fri Sep 28 06:22:17 2007
@@ -0,0 +1,18 @@
+This is the Gwydion Dylan version of the Open Dylan sql and sql-odbc
+libraries. This library resolves incompatibilities between OD and GD in the
+realms of garbage collection and C-FFI. The exposed API should be identical to
+that of Open Dylan's sql and sql-odbc libraries, except for the following
+changes:
+
+ *trace-odbc-functions* is defined, but doesn't do anything.
+
+ close-dbms(<dbms>) and close-statement(<database-statement>) were added.
+ Finalization is not implemented in GD. Be sure to call close-dbms,
+ disconnect, or close-statement when done with the relevant objects.
+
+What still needs to be done:
+
+ Testing. Neither the Gwydion Dylan nor the Open Dylan versions of the sql
+ and sql-odbc seem to work with MySQL, yet MySQL is all I have. So, this
+ library needs to be tested against a database with which the Open Dylan
+ version is known to work.
Added: trunk/libraries/database/sql-odbc/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/library.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,16 @@
+Module: dylan-user
+Author: Dustin Voss
+Synopsis: This library is a Gwydion Dylan implementation of the Open Dylan
+ sql and sql-odbc libraries. See subdirectories for module decl's.
+
+define library sql-odbc
+ use common-dylan, import: { dylan, common-extensions };
+ use dylan, import: { system };
+ use system, import: { date };
+ use table-extensions;
+ use threads;
+ use odbc-ffi;
+ use io;
+
+ export sql-odbc;
+end library;
Added: trunk/libraries/database/sql-odbc/sql/conditions.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/sql/conditions.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,51 @@
+Module: sql-implementation
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+define open class <invalid-argument> (<error>)
+end class <invalid-argument>;
+
+
+define open class <dbms-not-specified> (<error>)
+end class <dbms-not-specified>;
+
+define open class <connection-not-specified> (<error>)
+end class <connection-not-specified>;
+
+
+define open class <data-not-available> (<error>)
+end class <data-not-available>;
+
+
+define open concrete class <result-set-mutation-error> (<error>)
+end class <result-set-mutation-error>;
+
+
+define open concrete class <invalid-datatype-hint> (<warning>)
+ constant slot datatype-hint :: <object>,
+ required-init-keyword: datatype-hint:;
+end class <invalid-datatype-hint>;
+
+//---*** andrewa: not used, for some reason
+ignore(datatype-hint);
+
+define open abstract class <database-error> (<error>)
+end class <database-error>;
+
+define open abstract class <sql-error> (<database-error>)
+end class <sql-error>;
+
+define open class <unhandled-diagnostic> (<sql-error>)
+ constant slot diagnostic,
+ required-init-keyword: diagnostic:;
+end class <unhandled-diagnostic>;
+
+define method print-message
+ (condition :: <unhandled-diagnostic>, stream :: <stream>)
+ => ()
+ format(stream, "Database error: %s\n", condition.diagnostic.message-text)
+end method print-message;
Added: trunk/libraries/database/sql-odbc/sql/conversion.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/sql/conversion.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,93 @@
+Module: result-set-implementation
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+// $HopeName: D-databases-sql!conversion.dylan(trunk.5) $
+
+
+define open generic default-conversion(value :: <statically-typed-pointer>)
+ => (converted-value :: <object>);
+
+define method default-conversion(value :: <statically-typed-pointer>)
+ => (converted-value :: <object>);
+ pointer-value(value);
+end method;
+
+define method default-conversion(value :: <C-string>)
+ => (converted-value :: <byte-string>)
+ as(<byte-string>, value)
+end method;
+
+
+define constant $default-coercion = #"default-coercion";
+define constant $no-coercion = #"no-coercion";
+
+define constant <coercion-policy>
+ = type-union(singleton($default-coercion),singleton($no-coercion),
+ <sequence>, <object>);
+
+
+define generic convert-value(coercion-policy :: <coercion-policy>,
+ value :: <object>, key :: <integer>)
+ => (converted-value :: <object>);
+
+
+define method convert-value(coercion-policy == $default-coercion,
+ value :: <object>, key :: <integer>)
+ => (converted-value :: <object>)
+ default-conversion(value)
+end method;
+
+
+define method convert-value(coercion-policy :: <sequence>,
+ value :: <object>, key :: <integer>)
+ => (converted-value :: <object>)
+ let not-found = pair(#f, #f);
+ let conversion-function = element(coercion-policy, key, default: not-found);
+ if (conversion-function ~== not-found)
+ if (instance?(conversion-function, <function>) = #f)
+ error("Coercion-policy sequence contains "
+ "an item that is not a function.");
+ end if;
+ conversion-function(value);
+ else
+ //++ signal a warning?
+ convert-value(#"default-coercion", value, key)
+ end if;
+end method;
+
+
+define generic acquire-null-value(indicator :: <object>,
+ index :: <integer>)
+ => (null-value :: <object>);
+
+
+define method acquire-null-value(indicator :: <object>,
+ index :: <integer>)
+ => (null-value :: <object>);
+ indicator;
+end method;
+
+
+define method acquire-null-value(indicator == $no-indicator,
+ index :: <integer>)
+ => (null-value :: <object>);
+ error("no output indicator provided.\n"); //+++ throw proper condition
+end method;
+
+
+define method acquire-null-value(indicator :: <sequence>,
+ index :: <integer>)
+ => (null-value :: <object>);
+ let not-found = pair(#f, #f);
+ let null-value = element(indicator, index, default: not-found);
+ if (null-value == not-found)
+ error("no output indicator provided.\n"); //+++ throw proper condition
+ else
+ null-value
+ end if;
+end method;
Added: trunk/libraries/database/sql-odbc/sql/datatypes.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/sql/datatypes.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,125 @@
+Module: sql-implementation
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+// $HopeName: D-databases-sql!datatypes.dylan(trunk.3) $
+
+
+define open abstract class <sql-datatype> (<object>)
+end class;
+
+define open concrete class <sql-unknown-type> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-unsupported-type> (<sql-datatype>)
+end class;
+
+// Exact Numeric datatypes
+
+define open concrete class <sql-integer> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-smallint> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-numeric> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-decimal> (<sql-datatype>)
+end class;
+
+
+// Approximate Numeric datatypes
+
+define open concrete class <sql-real> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-double-precision> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-float> (<sql-datatype>)
+end class;
+
+
+// Character String datatypes
+
+define open concrete class <sql-character> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-character-varying> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-national-character> (<sql-character>)
+end class;
+
+define open concrete class <sql-national-character-varying>
+ (<sql-character-varying>)
+end class;
+
+
+// Bit String datatypes
+
+define open concrete class <sql-bit> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-bit-varying> (<sql-datatype>)
+end class;
+
+
+// Datetimes datatypes
+
+define open concrete class <sql-date> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-time> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-timestamp> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-time-with-time-zone> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-timestamp-with-time-zone> (<sql-datatype>)
+end class;
+
+
+// Intervals
+
+define open concrete class <sql-year-month-interval> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-day-time-interval> (<sql-datatype>)
+end class;
+
+
+// Non-ANSI datatypes in common use.
+
+define open concrete class <sql-bigint> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-binary> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-double> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-longvarbinary> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-longvarchar> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-tinyint> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-varbinary> (<sql-datatype>)
+end class;
+
+define open concrete class <sql-type-timestamp> (<sql-datatype>)
+end class;
+
Added: trunk/libraries/database/sql-odbc/sql/diagnostic.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/sql/diagnostic.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,808 @@
+Module: sql-implementation
+Author: eec
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: Functional Objects Library Public License Version 1.0
+Dual-license: GNU Lesser General Public License
+Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+// $HopeName: !diagnostic.dylan(D-kan.3) $
+
+
+define function detail-info-not-available(detail-info :: <string>)
+ => (str :: <string>)
+ let msg = "information not available";
+
+ signal(msg);
+ msg;
+end function;
+
+
+//---------- Diagnostic Detail ----------
+
+define open abstract class <diagnostic> (<condition>)
+ constant virtual slot class-code :: <string>;
+ constant virtual slot subclass-code :: <string>;
+
+ constant slot condition-number :: <integer> = 1,
+ init-keyword: condition-number:;
+
+ constant slot possible-explanation :: <deque> = make(<deque>);
+end class;
+
+define method subclass-code(cls :: <diagnostic>) => (str :: <string>)
+ "000"
+end method;
+
+
+define method default-handler(diagnostic :: <diagnostic>)
+ // Since <diagnostic> is a subclass of <condition>, a signalled diagnostic
+ // will be dropped on the floor (similar to a warning) and the code will
+ // continue to execute. An unhandled-diagnostic is an error so the debugger
+ // will take notice of it.
+ error(make(<unhandled-diagnostic>,
+ diagnostic: diagnostic));
+end method default-handler;
+
+
+define open class <unknown-sqlstate> (<diagnostic>)
+ constant slot sqlstate :: <string> = "",
+ init-keyword: sqlstate:;
+end class;
+
+define method class-code(cls :: <unknown-sqlstate>) => (str :: <string>)
+ ""
+end method;
+
+define method subclass-code(cls :: <unknown-sqlstate>) => (str :: <string>)
+ ""
+end method;
+
+
+define open generic conditions-not-recorded?(diag :: <diagnostic>)
+ => (not-recorded-status :: <boolean>);
+
+define method conditions-not-recorded?(diag :: <diagnostic>)
+ => (not-recorded-status :: <boolean>)
+ #f;
+end method;
+
+
+define open generic dynamic-function(diag :: <diagnostic>)
+ => (dynamic-function :: <string>);
+
+define method dynamic-function(diag :: <diagnostic>)
+ => (dynamic-function :: <string>)
+ detail-info-not-available("dynamic-function");
+end method;
+
+
+define open generic row-count(diag :: <diagnostic>)
+ => (count :: <integer>);
+
+define method row-count(diag :: <diagnostic>)
+ => (count :: <integer>)
+ 0;
+end method;
+
+
+define open generic command-function(diag :: <diagnostic>)
+ => (command-function :: <string>);
+
+define method command-function(diag :: <diagnostic>)
+ => (command-function :: <string>)
+ detail-info-not-available("command-function");
+end method;
+
+
+define open generic returned-sqlstate(diag :: <diagnostic>)
+ => (sqlstate :: <string>);
+
+define method returned-sqlstate(diag :: <diagnostic>)
+ => (sqlstate :: <string>)
+ detail-info-not-available("returned-sqlstate");
+end method;
+
+
+define open generic class-origin(diag :: <diagnostic>)
+ => (class-origin :: <string>);
+
+define method class-origin(diag :: <diagnostic>)
+ => (class-origin :: <string>)
+ detail-info-not-available("class-origin");
+end method;
+
+
+define open generic subclass-origin(diag :: <diagnostic>)
+ => (subclass-origin :: <string>);
+
+define method subclass-origin(diag :: <diagnostic>)
+ => (subclass-origin :: <string>);
+ detail-info-not-available("subclass-origin");
+end method;
+
+
+define open generic constraint-catalog(diag :: <diagnostic>)
+ => (constraint-catalog :: <string>);
+
+define method constraint-catalog(diag :: <diagnostic>)
+ => (constraint-catalog :: <string>);
+ detail-info-not-available("constraint-catalog");
+end method;
+
+
+define open generic constraint-schema(diag :: <diagnostic>)
+ => (constraint-schema :: <string>);
+
+define method constraint-schema(diag :: <diagnostic>)
+ => (constraint-schema :: <string>);
+ detail-info-not-available("constraint-schema");
+end method;
+
+
+define open generic constraint-name(diag :: <diagnostic>)
+ => (constraint-name :: <string>);
+
+define method constraint-name(diag :: <diagnostic>)
+ => (constraint-name :: <string>);
+ detail-info-not-available("constraint-name");
+end method;
+
+
+define open generic connection-name(diag :: <diagnostic>)
+ => (connection-name :: <string>);
+
+define method connection-name(diag :: <diagnostic>)
+ => (connection-name :: <string>);
+ detail-info-not-available("connection-name");
+end method;
+
+
+define open generic environment-name(diag :: <diagnostic>)
+ => (env-name :: <string>);
+
+define method environment-name(diag :: <diagnostic>)
+ => (env-name :: <string>);
+ detail-info-not-available("environment-name");
+end method;
+
+
+define open generic catalog-name(diag :: <diagnostic>)
+ => (catalog-name :: <string>);
+
+define method catalog-name(diag :: <diagnostic>)
+ => (catalog-name :: <string>);
+ detail-info-not-available("catalog-name");
+end method;
+
+
+define open generic schema-name(diag :: <diagnostic>)
+ => (schema-name :: <string>);
+
+define method schema-name(diag :: <diagnostic>)
+ => (schema-name :: <string>);
+ detail-info-not-available("schema-name");
+end method;
+
+
+define open generic table-name(diag :: <diagnostic>)
+ => (table-name :: <string>);
+
+define method table-name(diag :: <diagnostic>)
+ => (table-name :: <string>);
+ detail-info-not-available("table-name");
+end method;
+
+
+define open generic column-name(diag :: <diagnostic>)
+ => (column-name :: <string>);
+
+define method column-name(diag :: <diagnostic>)
+ => (column-name :: <string>);
+ detail-info-not-available("column-name");
+end method;
+
+
+define open generic cursor-name(diag :: <diagnostic>)
+ => (cursor-name :: <string>);
+
+define method cursor-name(diag :: <diagnostic>)
+ => (cursor-name :: <string>);
+ detail-info-not-available("cursor-name");
+end method;
+
+
+define open generic message-text(diag :: <diagnostic>)
+ => (message-text :: <string>);
+
+define method message-text(diag :: <diagnostic>)
+ => (message-text :: <string>);
+ detail-info-not-available("message-text");
+end method;
+
+
+define open generic next-dbms-diagnostic(diag :: <diagnostic>)
+ => (next-diagnostic :: false-or(<diagnostic>));
+
+define method next-dbms-diagnostic(diag :: <diagnostic>)
+ => (next-diagnostic :: false-or(<diagnostic>))
+ #f;
+end method;
+
+
+define open generic diagnostic-to-string(diag :: <diagnostic>)
+ => (string :: <string>);
+
+define method diagnostic-to-string(diag :: <diagnostic>)
+ => (string :: <string>)
+ format-to-string("Diagnostic - \n"
+ " Conditions not recorded: %=\n"
+ " Command function: %=\n"
+ " Dynamic function: %=\n"
+ " Row count: %=\n"
+ " Condition/Diagnostic number: %=\n"
+ " Returned SQLState: %=\n"
+ " Class origin: %=\n"
+ " Subclass origin: %=\n"
+ " Constraint catalog: %=\n"
+ " Constraint schema: %=\n"
+ " Constraint name: %=\n"
+ " Connection name: %=\n"
+ " Environment name: %=\n"
+ " Catalog name: %=\n"
+ " Schema name: %=\n"
+ " Table name: %=\n"
+ " Column name: %=\n"
+ " Message Text: %=\n",
+ diag.conditions-not-recorded?,
+ diag.command-function,
+ diag.dynamic-function,
+ diag.row-count,
+ diag.condition-number,
+ diag.returned-sqlstate,
+ diag.class-origin,
+ diag.subclass-origin,
+ diag.constraint-catalog,
+ diag.constraint-schema,
+ diag.constraint-name,
+ diag.connection-name,
+ diag.environment-name,
+ diag.catalog-name,
+ diag.schema-name,
+ diag.table-name,
+ diag.column-name,
+ diag.message-text)
+end method;
+
+
+define method print-message
+ (diag :: <diagnostic>, stream :: <stream>)
+ => ()
+ let diag-string :: <string> = make(<string>);
+ let test-diag = diag;
+ while (test-diag ~= #f)
+ diag-string := concatenate(diag-string, diagnostic-to-string(test-diag));
+ test-diag := next-dbms-diagnostic(test-diag);
+ end while;
+ format(stream, diag-string);
+end method print-message;
+
+
+//---------- Specific Diagnostic Detail ----------
+
+define macro diagnostic-class-definer
+ { define diagnostic-class ?:name (?super:name)
+ ?code:name ?:expression
+ end }
+ => { define open class ?name (?super) end class;
+ define method ?code(cls :: ?name) => (str :: <string>)
+ ?expression
+ end method; }
+end macro;
+
+define diagnostic-class <ambiguous-cursor-name> (<diagnostic>)
+ class-code "3C"
+end diagnostic-class;
+
+define diagnostic-class <cardinality-violation> (<diagnostic>)
+ class-code "21"
+end diagnostic-class;
+
+define diagnostic-class <connection-exception> (<diagnostic>)
+ class-code "08"
+end diagnostic-class;
+
+define diagnostic-class <connection-does-not-exist> (<connection-exception>)
+ subclass-code "003"
+end diagnostic-class;
+
+define diagnostic-class <connection-failure> (<connection-exception>)
+ subclass-code "006"
+end diagnostic-class;
+
+define diagnostic-class <connection-name-in-use> (<connection-exception>)
+ subclass-code "002"
+end diagnostic-class;
+
+define diagnostic-class <sql-client-unable-to-establish-connection>
+ (<connection-exception>)
+ subclass-code "001"
+end diagnostic-class;
+
+define diagnostic-class <sql-server-rejected-establishment-of-connection>
+ (<connection-exception>)
+ subclass-code "004"
+end diagnostic-class;
+
+define diagnostic-class <transaction-resolution-unknown> (<connection-exception>)
+ subclass-code "007"
+end diagnostic-class;
+
+define diagnostic-class <cursor-operation-conflict> (<diagnostic>)
+ class-code "09"
+end diagnostic-class;
+
+define diagnostic-class <data-exception> (<diagnostic>)
+ class-code "22"
+end diagnostic-class;
+
+define diagnostic-class <character-not-in-repertoire> (<data-exception>)
+ subclass-code "021"
+end diagnostic-class;
+
+define diagnostic-class <datetime-field-overflow> (<data-exception>)
+ subclass-code "008"
+end diagnostic-class;
+
+define diagnostic-class <division-by-zero> (<data-exception>)
+ subclass-code "012"
+end diagnostic-class;
+
+define diagnostic-class <error-in-assignment> (<data-exception>)
+ subclass-code "005"
+end diagnostic-class;
+
+define diagnostic-class <indicator-overflow> (<data-exception>)
+ subclass-code "022"
+end diagnostic-class;
+
+define diagnostic-class <interval-field-overflow> (<data-exception>)
+ subclass-code "015"
+end diagnostic-class;
+
+define diagnostic-class <invalid-character-value-for-cast> (<data-exception>)
+ subclass-code "018"
+end diagnostic-class;
+
+define diagnostic-class <invalid-datetime-format> (<data-exception>)
+ subclass-code "007"
+end diagnostic-class;
+
+define diagnostic-class <invalid-escape-character> (<data-exception>)
+ subclass-code "019"
+end diagnostic-class;
+
+define diagnostic-class <invalid-escape-sequence> (<data-exception>)
+ subclass-code "025"
+end diagnostic-class;
+
+define diagnostic-class <invalid-fetch-sequence> (<data-exception>)
+ subclass-code "006"
+end diagnostic-class;
+
+define diagnostic-class <invalid-parameter-value> (<data-exception>)
+ subclass-code "023"
+end diagnostic-class;
+
+define diagnostic-class <invalid-time-zone-displacement-value> (<data-exception>)
+ subclass-code "009"
+end diagnostic-class;
+
+define diagnostic-class <null-value-no-indicator-parameter> (<data-exception>)
+ subclass-code "002"
+end diagnostic-class;
+
+define diagnostic-class <numeric-value-out-of-range> (<data-exception>)
+ subclass-code "003"
+end diagnostic-class;
+
+define diagnostic-class <string-data-length-mismatch> (<data-exception>)
+ subclass-code "026"
+end diagnostic-class;
+
+define diagnostic-class <string-data-right-truncation> (<data-exception>)
+ subclass-code "001"
+end diagnostic-class;
+
+define diagnostic-class <substring-error> (<data-exception>)
+ subclass-code "011"
+end diagnostic-class;
+
+define diagnostic-class <trim-error> (<data-exception>)
+ subclass-code "027"
+end diagnostic-class;
+
+define diagnostic-class <unterminated-C-string> (<data-exception>)
+ subclass-code "024"
+end diagnostic-class;
+
+define diagnostic-class <dependent-privilege-descriptors-still-exist>
+ (<diagnostic>)
+ class-code "2B"
+end diagnostic-class;
+
+define diagnostic-class <dynamic-sql-error> (<diagnostic>)
+ class-code "07"
+end diagnostic-class;
+
+define diagnostic-class <cursor-specification-cannot-be-executed>
+ (<dynamic-sql-error>)
+ subclass-code "003"
+end diagnostic-class;
+
+define diagnostic-class <invalid-descriptor-count> (<dynamic-sql-error>)
+ subclass-code "008"
+end diagnostic-class;
+
+define diagnostic-class <invalid-descriptor-index> (<dynamic-sql-error>)
+ subclass-code "009"
+end diagnostic-class;
+
+define diagnostic-class <prepared-statement-not-a-cursor-specification>
+ (<dynamic-sql-error>)
+ subclass-code "005"
+end diagnostic-class;
+
+define diagnostic-class <restricted-data-type-attribute-violation>
+ (<dynamic-sql-error>)
+ subclass-code "006"
+end diagnostic-class;
+
+define diagnostic-class <using-clause-does-not-match-dynamic-parameter-specification>
+ (<dynamic-sql-error>)
+ subclass-code "001"
+end diagnostic-class;
+
+define diagnostic-class <using-clause-does-not-match-target-specification>
+ (<dynamic-sql-error>)
+ subclass-code "002"
+end diagnostic-class;
+
+define diagnostic-class <using-clause-required-for-dynamic-parameters>
+ (<dynamic-sql-error>)
+ subclass-code "004"
+end diagnostic-class;
+
+define diagnostic-class <using-clause-required-for-result-fields>
+ (<dynamic-sql-error>)
+ subclass-code "007"
+end diagnostic-class;
+
+define diagnostic-class <feature-not-supported> (<diagnostic>)
+ class-code "0A"
+end diagnostic-class;
+
+define diagnostic-class <multiple-server-transaction> (<feature-not-supported>)
+ subclass-code "001"
+end diagnostic-class;
+
+define diagnostic-class <integrity-constraint-violation> (<diagnostic>)
+ class-code "23"
+end diagnostic-class;
+
+define diagnostic-class <invalid-authorization-specification> (<diagnostic>)
+ class-code "28"
+end diagnostic-class;
+
+define diagnostic-class <invalid-catalog-name> (<diagnostic>)
+ class-code "3D"
+end diagnostic-class;
+
+define diagnostic-class <invalid-character-set-name> (<diagnostic>)
+ class-code "2C"
+end diagnostic-class;
+
+define diagnostic-class <invalid-condition-number> (<diagnostic>)
+ class-code "35"
+end diagnostic-class;
+
+define diagnostic-class <invalid-cursor-name> (<diagnostic>)
+ class-code "34"
+end diagnostic-class;
+
+define diagnostic-class <invalid-schema-name> (<diagnostic>)
+ class-code "3F"
+end diagnostic-class;
+
+define diagnostic-class <invalid-sql-descriptor-name> (<diagnostic>)
+ class-code "33"
+end diagnostic-class;
+
+define diagnostic-class <invalid-sql-statement-name> (<diagnostic>)
+ class-code "26"
+end diagnostic-class;
+
+define diagnostic-class <invalid-transaction-state> (<diagnostic>)
+ class-code "25"
+end diagnostic-class;
+
+define diagnostic-class <invalid-transaction-termination> (<diagnostic>)
+ class-code "2D"
+end diagnostic-class;
+
+define diagnostic-class <no-data> (<diagnostic>)
+ class-code "02"
+end diagnostic-class;
+
+define diagnostic-class <remote-database-access> (<diagnostic>)
+ class-code "HZ"
+end diagnostic-class;
+
+define diagnostic-class <successful-completion> (<diagnostic>)
+ class-code "00"
+end diagnostic-class;
+
+define diagnostic-class <syntax-error-or-access-rule-violation> (<diagnostic>)
+ class-code "42"
+end diagnostic-class;
+
+define diagnostic-class
+ <syntax-error-or-access-rule-violation-in-direct-sql-statement>
+ (<diagnostic>)
+ class-code "2A"
+end diagnostic-class;
+
+define diagnostic-class
+ <syntax-error-or-access-rule-violation-in-dynamic-sql-statement>
+ (<diagnostic>)
+ class-code "37"
+end diagnostic-class;
+
+define diagnostic-class <transaction-rollback> (<diagnostic>)
+ class-code "40"
+end diagnostic-class;
+
+define diagnostic-class <transaction-rollback-due-to-integrity-constraint-violation>
+ (<transaction-rollback>)
+ subclass-code "002"
+end diagnostic-class;
+
+define diagnostic-class <transaction-rollback-due-to-serialization-failure>
+ (<transaction-rollback>)
+ subclass-code "001"
+end diagnostic-class;
+
+define diagnostic-class <statement-completion-unknown> (<transaction-rollback>)
+ subclass-code "003"
+end diagnostic-class;
+
+define diagnostic-class <triggered-data-change-violation> (<diagnostic>)
+ class-code "27"
+end diagnostic-class;
+
+define diagnostic-class <sql-warning> (<diagnostic>)
+ class-code "01"
+end diagnostic-class;
+
+define diagnostic-class <warning-cursor-operation-conflict> (<sql-warning>)
+ subclass-code "001"
+end diagnostic-class;
+
+define diagnostic-class <disconnect-error> (<sql-warning>)
+ subclass-code "002"
+end diagnostic-class;
+
+define diagnostic-class <implicit-zero-bit-padding> (<sql-warning>)
+ subclass-code "008"
+end diagnostic-class;
+
+define diagnostic-class <insufficient-item-descriptor-areas> (<sql-warning>)
+ subclass-code "005"
+end diagnostic-class;
+
+define diagnostic-class <null-value-eliminated-in-set-function> (<sql-warning>)
+ subclass-code "003"
+end diagnostic-class;
+
+define diagnostic-class <privilege-not-granted> (<sql-warning>)
+ subclass-code "007"
+end diagnostic-class;
+
+define diagnostic-class <privilege-not-revoked> (<sql-warning>)
+ subclass-code "006"
+end diagnostic-class;
+
+define diagnostic-class <query-expression-too-long-for-information-schema>
+ (<sql-warning>)
+ subclass-code "00A"
+end diagnostic-class;
+
+define diagnostic-class <search-condition-too-long-for-information-schema>
+ (<sql-warning>)
+ subclass-code "009"
+end diagnostic-class;
+
+define diagnostic-class <warning-string-data-right-truncation> (<sql-warning>)
+ subclass-code "004"
+end diagnostic-class;
+
+define diagnostic-class <with-check-option-violation> (<diagnostic>)
+ class-code "44"
+end diagnostic-class;
+
+
+//-------------------- Diagnostic Table --------------------
+
+
+define class <diagnostic-table> (<object>)
+ constant slot diagnostics :: <object-table> = make(<object-table>);
+ constant slot general-key :: <symbol>,
+ required-init-keyword: general-key:;
+
+ slot diagnostics-installed? :: <boolean> = #f;
+
+ constant slot installation-functions :: <deque> = make(<deque>);
+end class <diagnostic-table>;
+
+
+define constant $general-dbms = #"general-dbms";
+
+define constant $diagnostic-table :: <diagnostic-table>
+ = make(<diagnostic-table>, general-key: $general-dbms);
+
+
+
+define function register-diagnostic-installer
+ (function :: <function>) => ()
+ push-last($diagnostic-table.installation-functions, function)
+end function register-diagnostic-installer;
+
+define function install-diagnostics
+ (table :: <diagnostic-table>) => ()
+ install-general-diagnostics(table);
+ for (fn in table.installation-functions)
+ fn(table);
+ end for;
+end function;
+
+define function install-diagnostic-key
+ (key :: <symbol>) => ()
+ $diagnostic-table.diagnostics[key] := make(<string-table>);
+end function install-diagnostic-key;
+
+define function install-diagnostic
+ (table :: <diagnostic-table>, class :: subclass(<diagnostic>),
+ #key key :: <symbol> = table.general-key)
+ => ()
+ let diagnostic = make(class);
+ let sqlstate = concatenate(diagnostic.class-code, diagnostic.subclass-code);
+ table.diagnostics[key][sqlstate] := class;
+end function install-diagnostic;
+
+define function install-general-diagnostics(table :: <diagnostic-table>) => ()
+ debug-assert(found?(element(table.diagnostics, table.general-key, default: $unfound)),
+ "There is no subset of diagnostic table for a general dbms.");
+
+ install-diagnostic(table, <ambiguous-cursor-name>);
+ install-diagnostic(table, <cardinality-violation>);
+ install-diagnostic(table, <connection-exception>);
+ install-diagnostic(table, <connection-does-not-exist>);
+ install-diagnostic(table, <connection-failure>);
+ install-diagnostic(table, <connection-name-in-use>);
+ install-diagnostic(table, <sql-client-unable-to-establish-connection>);
+ install-diagnostic(table, <sql-server-rejected-establishment-of-connection>);
+ install-diagnostic(table, <transaction-resolution-unknown>);
+ install-diagnostic(table, <cursor-operation-conflict>);
+ install-diagnostic(table, <character-not-in-repertoire>);
+ install-diagnostic(table, <datetime-field-overflow>);
+ install-diagnostic(table, <division-by-zero>);
+ install-diagnostic(table, <error-in-assignment>);
+ install-diagnostic(table, <indicator-overflow>);
+ install-diagnostic(table, <interval-field-overflow>);
+ install-diagnostic(table, <invalid-character-value-for-cast>);
+ install-diagnostic(table, <invalid-datetime-format>);
+ install-diagnostic(table, <invalid-escape-character>);
+ install-diagnostic(table, <invalid-escape-sequence>);
+ install-diagnostic(table, <invalid-fetch-sequence>);
+ install-diagnostic(table, <invalid-parameter-value>);
+ install-diagnostic(table, <invalid-time-zone-displacement-value>);
+ install-diagnostic(table, <null-value-no-indicator-parameter>);
+ install-diagnostic(table, <numeric-value-out-of-range>);
+ install-diagnostic(table, <string-data-length-mismatch>);
+ install-diagnostic(table, <string-data-right-truncation>);
+ install-diagnostic(table, <substring-error>);
+ install-diagnostic(table, <trim-error>);
+ install-diagnostic(table, <unterminated-C-string>);
+ install-diagnostic(table, <dependent-privilege-descriptors-still-exist>);
+ install-diagnostic(table, <dynamic-sql-error>);
+ install-diagnostic(table, <cursor-specification-cannot-be-executed>);
+ install-diagnostic(table, <invalid-descriptor-count>);
+ install-diagnostic(table, <invalid-descriptor-index>);
+ install-diagnostic(table, <prepared-statement-not-a-cursor-specification>);
+ install-diagnostic(table, <restricted-data-type-attribute-violation>);
+ install-diagnostic(table, <using-clause-does-not-match-dynamic-parameter-specification>);
+ install-diagnostic(table, <using-clause-does-not-match-target-specification>);
+ install-diagnostic(table, <using-clause-required-for-dynamic-parameters>);
+ install-diagnostic(table, <using-clause-required-for-result-fields>);
+ install-diagnostic(table, <feature-not-supported>);
+ install-diagnostic(table, <multiple-server-transaction>);
+ install-diagnostic(table, <integrity-constraint-violation>);
+ install-diagnostic(table, <invalid-authorization-specification>);
+ install-diagnostic(table, <invalid-catalog-name>);
+ install-diagnostic(table, <invalid-character-set-name>);
+ install-diagnostic(table, <invalid-condition-number>);
+ install-diagnostic(table, <invalid-cursor-name>);
+ install-diagnostic(table, <invalid-schema-name>);
+ install-diagnostic(table, <invalid-sql-descriptor-name>);
+ install-diagnostic(table, <invalid-sql-statement-name>);
+ install-diagnostic(table, <invalid-transaction-state>);
+ install-diagnostic(table, <invalid-transaction-termination>);
+ install-diagnostic(table, <no-data>);
+ install-diagnostic(table, <remote-database-access>);
+ install-diagnostic(table, <successful-completion>);
+ install-diagnostic(table, <syntax-error-or-access-rule-violation>);
+ install-diagnostic(table,
+ <syntax-error-or-access-rule-violation-in-direct-sql-statement>);
+ install-diagnostic(table,
+ <syntax-error-or-access-rule-violation-in-dynamic-sql-statement>);
+ install-diagnostic(table, <transaction-rollback>);
+ install-diagnostic(table, <transaction-rollback-due-to-integrity-constraint-violation>);
+ install-diagnostic(table, <transaction-rollback-due-to-serialization-failure>);
+ install-diagnostic(table, <statement-completion-unknown>);
+ install-diagnostic(table, <triggered-data-change-violation>);
+ install-diagnostic(table, <sql-warning>);
+ install-diagnostic(table, <warning-cursor-operation-conflict>);
+ install-diagnostic(table, <disconnect-error>);
+ install-diagnostic(table, <implicit-zero-bit-padding>);
+ install-diagnostic(table, <insufficient-item-descriptor-areas>);
+ install-diagnostic(table, <null-value-eliminated-in-set-function>);
+ install-diagnostic(table, <privilege-not-granted>);
+ install-diagnostic(table, <privilege-not-revoked>);
+ install-diagnostic(table, <query-expression-too-long-for-information-schema>);
+ install-diagnostic(table, <search-condition-too-long-for-information-schema>);
+ install-diagnostic(table, <warning-string-data-right-truncation>);
+ install-diagnostic(table, <with-check-option-violation>);
+end function;
+
+
+//-------------------- find-diagnostic not --------------------
+// Right now, the ODBC installs ODBC specific versions of the general
+// diagnostic details and the ODBC library does not add anything
+// specific. Any overlap probably should be removed and this function
+// should be modified to search for the diagnostic in the general
+// table in the event it isn't found in the specific table.
+
+define function find-diagnostic
+ (table :: <diagnostic-table>,
+ diagnostic-set-key :: <object>,
+ sqlstate :: <string>)
+ => (diagnostic-detail-class :: <object>)
+ if (table.diagnostics-installed? = #f)
+ install-diagnostic-key(table.general-key);
+ install-diagnostics(table);
+ table.diagnostics-installed? := #t;
+ end if;
+
+ let subtable = element(table.diagnostics, diagnostic-set-key, default: $unfound);
+ debug-assert(found?(subtable),
+ "Diagnostic table for key % not found.", diagnostic-set-key);
+
+ let diag-class = element(subtable, sqlstate, default: $unfound);
+
+ if (found?(diag-class))
+ diag-class
+ else
+ let general-table = element(table.diagnostics, table.general-key, default: $unfound);
+ assert(found?(general-table),
+ "The general diagnostic table was not found.");
+
+ let diag-class = element(general-table, sqlstate, default: $unfound);
+
+ if (found?(diag-class))
+ diag-class;
+ else
+ $unfound;
+ end if;
+ end if;
+end function;
+
Added: trunk/libraries/database/sql-odbc/sql/introspection.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/database/sql-odbc/sql/introspection.dylan Fri Sep 28 06:22:17 2007
@@ -0,0 +1,118 @@
+Module: sql-implementation
+Author: eec, yduJ
+Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
+ All rights reserved.
+License: