From: Kevin M. Rosenberg Date: Wed, 7 Apr 2004 14:38:14 +0000 (+0000) Subject: r8847: rename clsql to clsql-classic X-Git-Tag: v3.8.6~728 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=39d3fefaebf35a19a211d1ab6552d7ff54faccd2 r8847: rename clsql to clsql-classic --- diff --git a/classic-tests/README b/classic-tests/README new file mode 100644 index 0000000..3e1b561 --- /dev/null +++ b/classic-tests/README @@ -0,0 +1,20 @@ +These tests require the setup of a configuration file with account +information for MySQL and PostgreSQL SQL servers. Additionally, the +Debian package acl-installer must be installed and a license +downloaded to use the AODBC tests. + +Furthermore, if you are not using the Debian package of CLSQL, these +tests require the downloading of the rtest and ptester packages from +http://files.b9.com/. + +This test suite looks for a configuration file named +".clsql-test.config" located in the users home directory. + +This file contains a single a-list that specifies the connection + specs for each database type to be tested. For example, to test all +platforms, a sample file might look like this: + +((:mysql ("localhost" "a-mysql-db" "user1" "secret")) + (:aodbc ("my-dsn" "a-user" "pass")) + (:postgresql ("localhost" "another-db" "user2" "dont-tell")) + (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) diff --git a/classic-tests/old-tests/xptest-clsql.lisp b/classic-tests/old-tests/xptest-clsql.lisp new file mode 100644 index 0000000..51fad13 --- /dev/null +++ b/classic-tests/old-tests/xptest-clsql.lisp @@ -0,0 +1,224 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: xptest-clsql.cl +;;;; Purpose: Test of CLSQL using XPTest package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; The XPTest package can be downloaded from +;;;; http://alpha.onshored.com/lisp-software/ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +;;; This test suite looks for a configuration file named "test.config" +;;; This file contains a single a-list that specifies the connection +;;; specs for each database type to be tested. For example, to test all +;;; platforms, a sample "test.config" may look like: +;;; +;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) +;;; (:aodbc ("my-dsn" "a-user" "pass")) +;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) +(mk:load-system "XPTest") + +(in-package :clsql-user) +(use-package :xptest) + +(def-test-fixture clsql-fixture () + ((aodbc-spec :accessor aodbc-spec) + (mysql-spec :accessor mysql-spec) + (pgsql-spec :accessor pgsql-spec) + (pgsql-socket-spec :accessor pgsql-socket-spec)) + (:documentation "Test fixture for CLSQL testing")) + +(defvar *config-pathname* (make-pathname :name "test" + :type "config" + :defaults *load-truename*)) +(defmethod setup ((fix clsql-fixture)) + (if (probe-file *config-pathname*) + (let (config) + (with-open-file (stream *config-pathname* :direction :input) + (setq config (read stream))) + (setf (aodbc-spec fix) (cadr (assoc :aodbc config))) + (setf (mysql-spec fix) (cadr (assoc :mysql config))) + (setf (pgsql-spec fix) (cadr (assoc :postgresql config))) + (setf (pgsql-socket-spec fix) + (cadr (assoc :postgresql-socket config)))) + (error "XPTest Config file ~S not found" *config-pathname*))) + +(defmethod teardown ((fix clsql-fixture)) + t) + +(defmethod mysql-table-test ((test clsql-fixture)) + (test-table (mysql-spec test) :mysql)) + +(defmethod aodbc-table-test ((test clsql-fixture)) + (test-table (aodbc-spec test) :aodbc)) + +(defmethod pgsql-table-test ((test clsql-fixture)) + (test-table (pgsql-spec test) :postgresql)) + +(defmethod pgsql-socket-table-test ((test clsql-fixture)) + (test-table (pgsql-socket-spec test) :postgresql-socket)) + + +(defmethod test-table (spec type) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types :auto)) + (test-table-row row :auto)) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto)) + (when (map-query nil #'list "select * from test_clsql" + :database db :types :auto) + (failure "Expected NIL result from map-query nil")) + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto)) + (drop-test-table db) + ) + (disconnect :database db))))) + + +(defmethod mysql-low-level ((test clsql-fixture)) + (let ((spec (mysql-spec test))) + (when spec + (let ((db (clsql-mysql::database-connect spec :mysql))) + (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) + (clsql-mysql::database-execute-command + "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) + (dotimes (i 10) + (clsql-mysql::database-execute-command + (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" + i (number-to-sql-string (sqrt i)) + (number-to-sql-string (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) + (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res))) + (failure "Error calling mysql-num-rows")) + (clsql-mysql::database-dump-result-set res db)) + (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) + (clsql-mysql::database-disconnect db))))) + +(defparameter clsql-test-suite + (make-test-suite + "CLSQL Test Suite" + "Basic test suite for database operations." + ("MySQL Low Level Interface" 'clsql-fixture + :test-thunk 'mysql-low-level + :description "A test of MySQL low-level interface") + ("MySQL Table" 'clsql-fixture + :test-thunk 'mysql-table-test + :description "A test of MySQL") + ("PostgreSQL Table" 'clsql-fixture + :test-thunk 'pgsql-table-test + :description "A test of PostgreSQL tables") + ("PostgreSQL Socket Table" 'clsql-fixture + :test-thunk 'pgsql-socket-table-test + :description "A test of PostgreSQL Socket tables") + )) + +#+allegro +(add-test (make-test-case "AODBC table test" 'clsql-fixture + :test-thunk 'aodbc-table-test + :description "Test AODBC table") + clsql-test-suite) + +;;;; Testing functions + +(defun transform-float-1 (i) + (* i (abs (/ i 2)) (expt 10 (* 2 i)))) + +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" + :database db) + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" + test-int + (number-to-sql-string test-flt) + (transform-bigint-1 test-int) + (number-to-sql-string test-flt) + ) + :database db)))) + +(defun parse-double (num-str) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string num-str) 'double-float))) + +(defun test-table-row (row types) + (unless (and (listp row) + (= 4 (length row))) + (failure "Row ~S is incorrect format" row)) + (destructuring-bind (int float bigint str) row + (cond + ((eq types :auto) + (unless (and (integerp int) + (typep float 'double-float) + (integerp bigint) + (stringp str)) + (failure "Incorrect field type for row ~S" row))) + ((null types) + (unless (and (stringp int) + (stringp float) + (stringp bigint) + (stringp str)) + (failure "Incorrect field type for row ~S" row)) + (setq int (parse-integer int)) + (setq bigint (parse-integer bigint)) + (setq float (parse-double float))) + ((listp types) + (error "NYI") + ) + (t + (failure "Invalid types field (~S) passed to test-table-row" types))) + (unless (= float (transform-float-1 int)) + (failure "Wrong float value ~A for int ~A (row ~S)" float int row)) + (unless (= float (parse-double str)) + (failure "Wrong string value ~A" str)))) + + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql")) + +(report-result (run-test clsql-test-suite :handle-errors nil) :verbose t) + + diff --git a/classic-tests/package.lisp b/classic-tests/package.lisp new file mode 100644 index 0000000..84f5e0a --- /dev/null +++ b/classic-tests/package.lisp @@ -0,0 +1,18 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package file clsql testing suite +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:clsql-tests + (:use #:asdf #:cl #:clsql #:ptester)) + + diff --git a/classic-tests/tables.lisp b/classic-tests/tables.lisp new file mode 100644 index 0000000..7d5daa5 --- /dev/null +++ b/classic-tests/tables.lisp @@ -0,0 +1,262 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: tables.cl +;;;; Purpose: Table creation tests in CLSQL +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +;;; This test suite looks for a configuration file named ".clsql-test.config" +;;; located in the users home directory. +;;; +;;; This file contains a single a-list that specifies the connection +;;; specs for each database type to be tested. For example, to test all +;;; platforms, a sample "test.config" may look like: +;;; +;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) +;;; (:aodbc ("my-dsn" "a-user" "pass")) +;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) + +(in-package :clsql-tests) + +(defvar *config-pathname* + (make-pathname :default (user-homedir-pathname) + :name ".clsql-test" + :type ".config")) + +(defclass conn-specs () + ((aodbc-spec :accessor aodbc-spec) + (mysql-spec :accessor mysql-spec) + (pgsql-spec :accessor pgsql-spec) + (pgsql-socket-spec :accessor pgsql-socket-spec)) + (:documentation "Test fixture for CLSQL testing")) + + +(defun read-specs (&optional (path *config-pathname*)) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (let ((config (read stream)) + (specs (make-instance 'conn-specs))) + (setf (aodbc-spec specs) (cadr (assoc :aodbc config))) + (setf (mysql-spec specs) (cadr (assoc :mysql config))) + (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) + (setf (pgsql-socket-spec specs) + (cadr (assoc :postgresql-socket config))) + specs)) + (warn "CLSQL tester config file ~S not found" path))) + +(defvar *conn-specs* (read-specs)) + +(defmethod mysql-table-test ((test conn-specs)) + (test-table (mysql-spec test) :mysql)) + +(defmethod aodbc-table-test ((test conn-specs)) + (test-table (aodbc-spec test) :aodbc)) + +(defmethod pgsql-table-test ((test conn-specs)) + (test-table (pgsql-spec test) :postgresql)) + +(defmethod pgsql-socket-table-test ((test conn-specs)) + (test-table (pgsql-socket-spec test) :postgresql-socket)) + +(defmethod test-table (spec type) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types :auto)) + (test-table-row row :auto type)) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (test (map-query nil #'list "select * from test_clsql" + :database db :types :auto) + nil + :fail-info "Expected NIL result from map-query nil") + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil type)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto type)) + (drop-test-table db) + ) + (disconnect :database db))))) + + +;;;; Testing functions + +(defun transform-float-1 (i) + (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) + +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" + :database db) + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" + test-int + (number-to-sql-string test-flt) + (transform-bigint-1 test-int) + (number-to-sql-string test-flt) + ) + :database db)))) + +(defun parse-double (num-str) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string num-str) 'double-float))) + +(defun test-table-row (row types db-type) + (test (and (listp row) + (= 4 (length row))) + t + :fail-info + (format nil "Row ~S is incorrect format" row)) + (destructuring-bind (int float bigint str) row + (cond + ((eq types :auto) + (test (and (integerp int) + (typep float 'double-float) + (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions + (integerp bigint)) + (stringp str)) + t + :fail-info + (format nil "Incorrect field type for row ~S (types :auto)" row))) + ((null types) + (test (and (stringp int) + (stringp float) + (stringp bigint) + (stringp str)) + t + :fail-info + (format nil "Incorrect field type for row ~S (types nil)" row)) + (setq int (parse-integer int)) + (setq bigint (parse-integer bigint)) + (setq float (parse-double float))) + ((listp types) + (error "NYI") + ) + (t + (test t nil + :fail-info + (format nil "Invalid types field (~S) passed to test-table-row" types)))) + (test (transform-float-1 int) + float + :test #'eql + :fail-info + (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) + (test float + (parse-double str) + :test #'double-float-equal + :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" + str float row)))) + + +(defun double-float-equal (a b) + (if (zerop a) + (if (zerop b) + t + nil) + (let ((diff (abs (/ (- a b) a)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t)))) + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql" :database db)) + + +(deftest lowlevel.mysql.table.1 + (let ((spec (mysql-spec *conn-specs*)) + (result)) + (when spec + (let ((db (clsql-mysql::database-connect spec :mysql))) + (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) + (clsql-mysql::database-execute-command + "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) + (dotimes (i 10) + (clsql-mysql::database-execute-command + (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" + i (clsql:number-to-sql-string (sqrt i)) + (clsql:number-to-sql-string (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) + (setq result (mysql:mysql-num-rows + (clsql-mysql::mysql-result-set-res-ptr res))) + (clsql-mysql::database-dump-result-set res db)) + (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) + (clsql-mysql::database-disconnect db)))) + 10) + +;(mysql-table-test specs) +;(pgsql-table-test specs) +;(pgsql-socket-table-test specs) +;(aodbc-table-test specs) + + + +(defmacro def-test-table (name spec type) + (deftest ,name + (when ,spec + (let ((db (clsql:connect ,spec :database-type ,type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types :auto)) + (test-table-row row :auto type)) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (test (map-query nil #'list "select * from test_clsql" + :database db :types :auto) + nil + :fail-info "Expected NIL result from map-query nil") + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil type)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto type)) + (drop-test-table db) + ) + (disconnect :database db))))) diff --git a/classic-tests/tests.lisp b/classic-tests/tests.lisp new file mode 100644 index 0000000..76d0dd9 --- /dev/null +++ b/classic-tests/tests.lisp @@ -0,0 +1,270 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: tests.lisp +;;;; Purpose: Automated test of CLSQL using ACL's tester +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +;;; This test suite looks for a configuration file named ".clsql-test.config" +;;; located in the users home directory. +;;; +;;; This file contains a single a-list that specifies the connection +;;; specs for each database type to be tested. For example, to test all +;;; platforms, a sample "test.config" may look like: +;;; +;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) +;;; (:aodbc ("my-dsn" "a-user" "pass")) +;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")) +;;; (:sqlite ("path-to-sqlite-db"))) + +(in-package :clsql-tests) + +(defvar *config-pathname* + (make-pathname :defaults (user-homedir-pathname) + :name ".clsql-test" + :type "config")) + + +(defclass conn-specs () + ((aodbc-spec :accessor aodbc-spec) + (mysql-spec :accessor mysql-spec) + (pgsql-spec :accessor pgsql-spec) + (pgsql-socket-spec :accessor pgsql-socket-spec) + (sqlite-spec :accessor sqlite-spec)) + (:documentation "Test fixture for CLSQL testing")) + + +(defun read-specs (&optional (path *config-pathname*)) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (let ((config (read stream)) + (specs (make-instance 'conn-specs))) + (setf (aodbc-spec specs) (cadr (assoc :aodbc config))) + (setf (mysql-spec specs) (cadr (assoc :mysql config))) + (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) + (setf (pgsql-socket-spec specs) + (cadr (assoc :postgresql-socket config))) + (setf (sqlite-spec specs) (cadr (assoc :sqlite config))) + specs)) + (progn + (warn "CLSQL tester config file ~S not found" path) + nil))) + +(defmethod mysql-table-test ((test conn-specs)) + (test-table (mysql-spec test) :mysql)) + +(defmethod aodbc-table-test ((test conn-specs)) + (test-table (aodbc-spec test) :aodbc)) + +(defmethod pgsql-table-test ((test conn-specs)) + (test-table (pgsql-spec test) :postgresql)) + +(defmethod pgsql-socket-table-test ((test conn-specs)) + (test-table (pgsql-socket-spec test) :postgresql-socket)) + +(defmethod sqlite-table-test ((test conn-specs)) + (test-table (sqlite-spec test) :sqlite)) + +(defmethod test-table (spec type) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types :auto)) + (test-table-row row :auto type)) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types :auto) + do (test-table-row row :auto type)) + (test (map-query nil #'list "select * from test_clsql" + :database db :types :auto) + nil + :fail-info "Expected NIL result from map-query nil") + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil type)) + (do-query ((int float bigint str) "select * from test_clsql" :types :auto) + (test-table-row (list int float bigint str) :auto type)) + (drop-test-table db) + ) + (disconnect :database db))))) + +;;; +;;; SQLite is typeless: execute untyped tests only. +;;; +(defmethod test-table (spec (type (eql :sqlite))) + (when spec + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (dolist (row (query "select * from test_clsql" :database db :types nil)) + (test-table-row row nil type)) + (loop for row across (map-query 'vector #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + (loop for row in (map-query 'list #'list "select * from test_clsql" + :database db :types nil) + do (test-table-row row nil type)) + + (do-query ((int float bigint str) "select * from test_clsql") + (test-table-row (list int float bigint str) nil type)) + (drop-test-table db) + ) + (disconnect :database db))))) + +(defmethod mysql-low-level ((test conn-specs)) + #-clisp + (let ((spec (mysql-spec test))) + (when spec + (let ((db (clsql-mysql::database-connect spec :mysql))) + (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) + (clsql-mysql::database-execute-command + "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) + (dotimes (i 10) + (clsql-mysql::database-execute-command + (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" + i (clsql:number-to-sql-string (sqrt i)) + (clsql:number-to-sql-string (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) + (test (mysql:mysql-num-rows + (clsql-mysql::mysql-result-set-res-ptr res)) + 10 + :test #'eql + :fail-info "Error calling mysql-num-rows") + (clsql-mysql::database-dump-result-set res db)) + (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) + (clsql-mysql::database-disconnect db))))) + + + +;;;; Testing functions + +(defun transform-float-1 (i) + (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) + +(defun transform-bigint-1 (i) + (* i (expt 10 (* 3 (abs i))))) + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" + :database db) + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" + test-int + (number-to-sql-string test-flt) + (transform-bigint-1 test-int) + (number-to-sql-string test-flt) + ) + :database db)))) + +(defun parse-double (num-str) + (let ((*read-default-float-format* 'double-float)) + (coerce (read-from-string num-str) 'double-float))) + +(defun test-table-row (row types db-type) + (test (and (listp row) + (= 4 (length row))) + t + :fail-info + (format nil "Row ~S is incorrect format" row)) + (destructuring-bind (int float bigint str) row + (cond + ((eq types :auto) + (test (and (integerp int) + (typep float 'double-float) + (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions + (integerp bigint)) + (stringp str)) + t + :fail-info + (format nil "Incorrect field type for row ~S (types :auto)" row))) + ((null types) + (test (and (stringp int) + (stringp float) + (stringp bigint) + (stringp str)) + t + :fail-info + (format nil "Incorrect field type for row ~S (types nil)" row)) + (setq int (parse-integer int)) + (setq bigint (parse-integer bigint)) + (setq float (parse-double float))) + ((listp types) + (error "NYI") + ) + (t + (test t nil + :fail-info + (format nil "Invalid types field (~S) passed to test-table-row" types)))) + (unless (eq db-type :sqlite) ; SQLite is typeless. + (test (transform-float-1 int) + float + :test #'eql + :fail-info + (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))) + (test float + (parse-double str) + :test #'double-float-equal + :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" + str float row)))) + + +(defun double-float-equal (a b) + (if (zerop a) + (if (zerop b) + t + nil) + (let ((diff (abs (/ (- a b) a)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t)))) + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql" :database db)) + +(defun run-tests () + (let ((specs (read-specs))) + (unless specs + (warn "Not running test because test configuration file is missing") + (return-from run-tests :skipped)) + (with-tests (:name "CLSQL") + (mysql-low-level specs) + (mysql-table-test specs) + (pgsql-table-test specs) + (pgsql-socket-table-test specs) + (aodbc-table-test specs) + (sqlite-table-test specs) + )) + t) + diff --git a/classic/.gitignore b/classic/.gitignore new file mode 100644 index 0000000..1d27afc --- /dev/null +++ b/classic/.gitignore @@ -0,0 +1,14 @@ +clsql-uffi.so +clsql-uffi.dll +clsql-uffi.lib +clsql-uffi.dylib +.bin +*.fasl +*.pfsl +*.dfsl +*.cfsl +*.fasla16 +*.fasla8 +*.faslm16 +*.faslm8 +*.fsl diff --git a/classic/Makefile b/classic/Makefile new file mode 100644 index 0000000..31dc910 --- /dev/null +++ b/classic/Makefile @@ -0,0 +1,6 @@ +SUBDIRS := + +include ../Makefile.common + +.PHONY: distclean +distclean: clean diff --git a/classic/functional.lisp b/classic/functional.lisp new file mode 100644 index 0000000..bf38a12 --- /dev/null +++ b/classic/functional.lisp @@ -0,0 +1,89 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: functional.lisp +;;;; Purpose: Functional interface +;;;; Programmer: Pierre R. Mai +;;;; +;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; +;;;; $Id$ +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License (version 2) as +;;;; published by the Free Software Foundation. +;;;; +;;;; CLSQL is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc., +;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; ************************************************************************* + +(in-package #:clsql-sys) + + +;;; This file implements the more advanced functions of the +;;; functional SQL interface, which are just nicer layers above the +;;; basic SQL interface. + +;;; With the integration of CLSQL-USQL, these functions are no +;;; longer exported by the CLSQL package since they conflict with names +;;; exported by CLSQL-USQL + +(defun insert-records + (&key into attributes values av-pairs query (database *default-database*)) + "Insert records into the given table according to the given options." + (cond + ((and av-pairs (or attributes values)) + (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records.")) + ((and (or av-pairs values) query) + (error + "Supply either query or values/av-pairs to call of insert-records.")) + ((and attributes (not query) + (or (not (listp values)) (/= (length attributes) (length values)))) + (error "You must supply a matching values list when using attributes in call of insert-records.")) + (query + (execute-command + (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query) + :database database)) + (t + (execute-command + (multiple-value-bind (attributes values) + (if av-pairs + (values (mapcar #'first av-pairs) (mapcar #'second av-pairs)) + (values attributes values)) + (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})" + into attributes values)) + :database database)))) + +(defun delete-records (&key from where (database *default-database*)) + "Delete the indicated records from the given database." + (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where) + :database database)) + +(defun update-records (table &key attributes values av-pairs where (database *default-database*)) + "Update the specified records in the given database." + (cond + ((and av-pairs (or attributes values)) + (error "Supply either av-pairs or values (and possibly attributes) to call of update-records.")) + ((and attributes + (or (not (listp values)) (/= (length attributes) (length values)))) + (error "You must supply a matching values list when using attributes in call of update-records.")) + ((or (and attributes (not values)) (and values (not attributes))) + (error "You must supply both values and attributes in call of update-records.")) + (t + (execute-command + (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]" + table + (or av-pairs + (mapcar #'list attributes values)) + where) + :database database)))) + diff --git a/classic/package.lisp b/classic/package.lisp new file mode 100644 index 0000000..44eecaa --- /dev/null +++ b/classic/package.lisp @@ -0,0 +1,145 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for CLSQL (high-level) interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:clsql-sys + (:nicknames #:clsql) + (:use #:cl #:clsql-base-sys) + (:import-from + #:clsql-base + . + #1=( + #:clsql-condition + #:clsql-error + #:clsql-simple-error + #:clsql-warning + #:clsql-simple-warning + #:clsql-invalid-spec-error + #:clsql-invalid-spec-error-connection-spec + #:clsql-invalid-spec-error-database-type + #:clsql-invalid-spec-error-template + #:clsql-connect-error + #:clsql-connect-error-database-type + #:clsql-connect-error-connection-spec + #:clsql-connect-error-errno + #:clsql-connect-error-error + #:clsql-sql-error + #:clsql-sql-error-database + #:clsql-sql-error-expression + #:clsql-sql-error-errno + #:clsql-sql-error-error + #:clsql-database-warning + #:clsql-database-warning-database + #:clsql-database-warning-message + #:clsql-exists-condition + #:clsql-exists-condition-new-db + #:clsql-exists-condition-old-db + #:clsql-exists-warning + #:clsql-exists-error + #:clsql-closed-error + #:clsql-closed-error-database + + #:*loaded-database-types* + #:reload-database-types + #:*default-database-type* + #:*initialized-database-types* + #:initialize-database-type + + #:database + #:database-name + #:closed-database + #:database-name-from-spec + + ;; utils.lisp + #:number-to-sql-string + #:float-to-sql-string + #:sql-escape-quotes + + ;; database.lisp -- Connection + #:*default-database-type* ; clsql-base xx + #:*default-database* ; classes xx + #:connect ; database xx + #:*connect-if-exists* ; database xx + #:connected-databases ; database xx + #:database ; database xx + #:database-name ; database xx + #:disconnect ; database xx + #:reconnect ; database + #:find-database ; database xx + #:status ; database xx + #:with-database + #:with-default-database + + ;; basic-sql.lisp + #:query + #:execute-command + #:write-large-object + #:read-large-object + #:delete-large-object + #:do-query + #:map-query + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:commit ; transact xx + #:rollback ; transact xx + #:with-transaction ; transact xx . + #:start-transaction ; transact xx + #:in-transaction-p ; transact xx + #:database-start-transaction + #:database-abort-transaction + #:database-commit-transaction + #:transaction-level + #:transaction + #:disconnect-pooled + )) + (:export + ;; sql.cl + #:for-each-row + + ;; Large objects (Marc B) + #:create-large-object + #:write-large-object + #:read-large-object + #:delete-large-object + + ;; functional.lisp + ;; These are no longer export since different functions are + ;; exported by the CLSQL-USQL package + ;; #:insert-records + ;; #:delete-records + ;; #:update-records + + . + #1# + ) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) + + ) ;eval-when + +(defpackage #:clsql-user + (:use #:common-lisp #:clsql) + (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/classic/sql.lisp b/classic/sql.lisp new file mode 100644 index 0000000..c207a8f --- /dev/null +++ b/classic/sql.lisp @@ -0,0 +1,111 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sql.lisp +;;;; Purpose: High-level SQL interface +;;;; Authors: Kevin M. Rosenberg based on code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + + +;;; Row processing macro + +(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) + (let ((d (gensym "DISTINCT-")) + (bind-fields (loop for f in fields collect (car f))) + (w (gensym "WHERE-")) + (o (gensym "ORDER-BY-")) + (frm (gensym "FROM-")) + (l (gensym "LIMIT-")) + (q (gensym "QUERY-"))) + `(let ((,frm ,from) + (,w ,where) + (,d ,distinct) + (,l ,limit) + (,o ,order-by)) + (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l))) + (loop for tuple in (query ,q) + collect (destructuring-bind ,bind-fields tuple + ,@body)))))) + +(defun query-string (fields from where distinct order-by limit) + (concatenate + 'string + (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" + (if distinct "distinct " "") (field-names fields) + (from-names from)) + (if where (format nil " where ~{~A~^ ~}" + (where-strings where)) "") + (if order-by (format nil " order by ~{~A~^, ~}" + (order-by-strings order-by))) + (if limit (format nil " limit ~D" limit) ""))) + +(defun lisp->sql-name (field) + (typecase field + (string field) + (symbol (string-upcase (symbol-name field))) + (cons (cadr field)) + (t (format nil "~A" field)))) + +(defun field-names (field-forms) + "Return a list of field name strings from a fields form" + (loop for field-form in field-forms + collect + (lisp->sql-name + (if (cadr field-form) + (cadr field-form) + (car field-form))))) + +(defun from-names (from) + "Return a list of field name strings from a fields form" + (loop for table in (if (atom from) (list from) from) + collect (lisp->sql-name table))) + + +(defun where-strings (where) + (loop for w in (if (atom (car where)) (list where) where) + collect + (if (consp w) + (format nil "~A ~A ~A" (second w) (first w) (third w)) + (format nil "~A" w)))) + +(defun order-by-strings (order-by) + (loop for o in order-by + collect + (if (atom o) + (lisp->sql-name o) + (format nil "~A ~A" (lisp->sql-name (car o)) + (lisp->sql-name (cadr o)))))) + + +;;; Marc Battyani : Large objects support + +(defun create-large-object (&key (database *default-database*)) + "Creates a new large object in the database and returns the object identifier" + (database-create-large-object database)) + +(defun write-large-object (object-id data &key (database *default-database*)) + "Writes data to the large object" + (database-write-large-object object-id data database)) + +(defun read-large-object (object-id &key (database *default-database*)) + "Reads the large object content" + (database-read-large-object object-id database)) + +(defun delete-large-object (object-id &key (database *default-database*)) + "Deletes the large object in the database" + (database-delete-large-object object-id database)) + + diff --git a/classic/usql.lisp b/classic/usql.lisp new file mode 100644 index 0000000..1acd88a --- /dev/null +++ b/classic/usql.lisp @@ -0,0 +1,58 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: usql.lisp +;;;; Purpose: High-level interface to SQL driver routines needed for +;;;; UncommonSQL +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg +;;;; and onShore Development Inc +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +;;; Minimal high-level routines to enable low-level interface for USQL +;;; Thse functions are not exported. If you application depends on these +;;; consider using the clsql-usql package. + + +(in-package #:clsql-sys) + +(defun list-tables (&key (database *default-database*)) + "List all tables in *default-database*, or if the :database keyword arg +is given, the specified database. If the keyword arg :system-tables +is true, then it will not filter out non-user tables. Table names are +given back as a list of strings." + (database-list-tables database)) + + +(defun list-attributes (table &key (database *default-database*)) + "List the attributes of TABLE in *default-database, or if the +:database keyword is given, the specified database. Attributes are +returned as a list of strings." + (database-list-attributes table database)) + +(defun attribute-type (attribute table &key (database *default-database*)) + "Return the field type of the ATTRIBUTE in TABLE. The optional +keyword argument :database specifies the database to query, defaulting +to *default-database*." + (database-attribute-type attribute table database)) + +(defun create-sequence (name &key (database *default-database*)) + (database-create-sequence name database)) + +(defun drop-sequence (name &key (database *default-database*)) + (database-drop-sequence name database)) + +(defun sequence-next (name &key (database *default-database*)) + (database-sequence-next name database)) + + diff --git a/clsql-classic-tests.asd b/clsql-classic-tests.asd new file mode 100644 index 0000000..5b96d2a --- /dev/null +++ b/clsql-classic-tests.asd @@ -0,0 +1,42 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-classic-tests.asd +;;;; Purpose: ASDF system definitionf for clsql testing package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:cl-user) +(defpackage #:clsql-classic-tests-system (:use #:asdf #:cl)) +(in-package #:clsql-classic-tests-system) + +(defsystem clsql-classic-tests + :name "clsql-classic-tests" + :author "Kevin Rosenberg " + :maintainer "Kevin M. Rosenberg " + :licence "Lessor Lisp General Public License" + :description "Testing suite for CLSQL" + + :depends-on (:clsql #-clisp :clsql-mysql + #-clisp :clsql-postgresql + #-clisp :clsql-postgresql-socket + :ptester + #+(and allegro (not allegro-cl-trial)) :clsql-aodbc + :clsql-sqlite) + :components + ((:module :classic-tests + :components + ((:file "package") +;; (:file "tables" :depends-on ("package"))) + (:file "tests" :depends-on ("package"))) + ))) + +(defmethod perform ((o test-op) (c (eql (find-system 'clsql-classic-tests)))) + (unless (funcall (intern (symbol-name '#:run-tests) + (find-package '#:clsql-classic-tests))) + (error "test-op failed"))) + diff --git a/clsql-classic.asd b/clsql-classic.asd new file mode 100644 index 0000000..75cffe2 --- /dev/null +++ b/clsql-classic.asd @@ -0,0 +1,46 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-classic.asd +;;;; Purpose: System definition for CLSQL-CLASSIC +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(defpackage #:clsql-classic-system (:use #:asdf #:cl)) +(in-package #:clsql-classic-system) + +#+(or allegro lispworks cmu sbcl openmcl mcl scl) +(defsystem clsql-classic + :name "clsql-classic" + :author "Kevin Rosenberg " + :maintainer "Kevin M. Rosenberg " + :version "2.1.x" + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL Interface Library" + :long-description "cl-sql package provides the high-level interface for the CLSQL system." + + :components + ((:module :classic + :components + ((:file "package") + (:file "sql" :depends-on ("package")) + (:file "functional" :depends-on ("sql")) + (:file "usql" :depends-on ("sql")) + ))) + :depends-on (:clsql-base) + ) + +#+(or allegro lispworks cmu sbcl openmcl mcl scl) +(defmethod perform ((o test-op) (c (eql (find-system :clsql-classic)))) + (oos 'load-op 'clsql-classic-tests) + (oos 'test-op 'clsql-classic-tests)) diff --git a/clsql-tests.asd b/clsql-tests.asd deleted file mode 100644 index 6da0173..0000000 --- a/clsql-tests.asd +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-tests.asd -;;;; Purpose: ASDF system definitionf for clsql testing package -;;;; Author: Kevin M. Rosenberg -;;;; Date Started: Apr 2003 -;;;; -;;;; $Id$ -;;;; ************************************************************************* - -(in-package #:cl-user) -(defpackage #:clsql-tests-system (:use #:asdf #:cl)) -(in-package #:clsql-tests-system) - -(defsystem clsql-tests - :name "clsql-tests" - :author "Kevin Rosenberg " - :maintainer "Kevin M. Rosenberg " - :licence "Lessor Lisp General Public License" - :description "Testing suite for CLSQL" - - :depends-on (:clsql #-clisp :clsql-mysql - #-clisp :clsql-postgresql - #-clisp :clsql-postgresql-socket - :ptester - #+(and allegro (not allegro-cl-trial)) :clsql-aodbc - :clsql-sqlite) - :components - ((:module tests - :components - ((:file "package") -;; (:file "tables" :depends-on ("package"))) - (:file "tests" :depends-on ("package"))) - ))) - -(defmethod perform ((o test-op) (c (eql (find-system 'clsql-tests)))) - (unless (funcall (intern (symbol-name '#:run-tests) - (find-package '#:clsql-tests))) - (error "test-op failed"))) - diff --git a/clsql.asd b/clsql.asd deleted file mode 100644 index 324ff5d..0000000 --- a/clsql.asd +++ /dev/null @@ -1,46 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql.asd -;;;; Purpose: System definition for CLSQL -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(defpackage #:clsql-system (:use #:asdf #:cl)) -(in-package #:clsql-system) - -#+(or allegro lispworks cmu sbcl openmcl mcl scl) -(defsystem clsql - :name "clsql" - :author "Kevin Rosenberg " - :maintainer "Kevin M. Rosenberg " - :version "2.1.x" - :licence "Lessor Lisp General Public License" - :description "Common Lisp SQL Interface Library" - :long-description "cl-sql package provides the high-level interface for the CLSQL system." - - :components - ((:module :sql - :components - ((:file "package") - (:file "sql" :depends-on ("package")) - (:file "functional" :depends-on ("sql")) - (:file "usql" :depends-on ("sql")) - ))) - :depends-on (:clsql-base) - ) - -#+(or allegro lispworks cmu sbcl openmcl mcl scl) -(defmethod perform ((o test-op) (c (eql (find-system :clsql)))) - (oos 'load-op 'clsql-tests) - (oos 'test-op 'clsql-tests)) diff --git a/sql/.gitignore b/sql/.gitignore deleted file mode 100644 index 1d27afc..0000000 --- a/sql/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -clsql-uffi.so -clsql-uffi.dll -clsql-uffi.lib -clsql-uffi.dylib -.bin -*.fasl -*.pfsl -*.dfsl -*.cfsl -*.fasla16 -*.fasla8 -*.faslm16 -*.faslm8 -*.fsl diff --git a/sql/Makefile b/sql/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/sql/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/sql/functional.lisp b/sql/functional.lisp deleted file mode 100644 index bf38a12..0000000 --- a/sql/functional.lisp +++ /dev/null @@ -1,89 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: functional.lisp -;;;; Purpose: Functional interface -;;;; Programmer: Pierre R. Mai -;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id$ -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License (version 2) as -;;;; published by the Free Software Foundation. -;;;; -;;;; CLSQL is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc., -;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;;;; ************************************************************************* - -(in-package #:clsql-sys) - - -;;; This file implements the more advanced functions of the -;;; functional SQL interface, which are just nicer layers above the -;;; basic SQL interface. - -;;; With the integration of CLSQL-USQL, these functions are no -;;; longer exported by the CLSQL package since they conflict with names -;;; exported by CLSQL-USQL - -(defun insert-records - (&key into attributes values av-pairs query (database *default-database*)) - "Insert records into the given table according to the given options." - (cond - ((and av-pairs (or attributes values)) - (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records.")) - ((and (or av-pairs values) query) - (error - "Supply either query or values/av-pairs to call of insert-records.")) - ((and attributes (not query) - (or (not (listp values)) (/= (length attributes) (length values)))) - (error "You must supply a matching values list when using attributes in call of insert-records.")) - (query - (execute-command - (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query) - :database database)) - (t - (execute-command - (multiple-value-bind (attributes values) - (if av-pairs - (values (mapcar #'first av-pairs) (mapcar #'second av-pairs)) - (values attributes values)) - (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})" - into attributes values)) - :database database)))) - -(defun delete-records (&key from where (database *default-database*)) - "Delete the indicated records from the given database." - (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where) - :database database)) - -(defun update-records (table &key attributes values av-pairs where (database *default-database*)) - "Update the specified records in the given database." - (cond - ((and av-pairs (or attributes values)) - (error "Supply either av-pairs or values (and possibly attributes) to call of update-records.")) - ((and attributes - (or (not (listp values)) (/= (length attributes) (length values)))) - (error "You must supply a matching values list when using attributes in call of update-records.")) - ((or (and attributes (not values)) (and values (not attributes))) - (error "You must supply both values and attributes in call of update-records.")) - (t - (execute-command - (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]" - table - (or av-pairs - (mapcar #'list attributes values)) - where) - :database database)))) - diff --git a/sql/package.lisp b/sql/package.lisp deleted file mode 100644 index 44eecaa..0000000 --- a/sql/package.lisp +++ /dev/null @@ -1,145 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.lisp -;;;; Purpose: Package definition for CLSQL (high-level) interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:cl-user) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:clsql-sys - (:nicknames #:clsql) - (:use #:cl #:clsql-base-sys) - (:import-from - #:clsql-base - . - #1=( - #:clsql-condition - #:clsql-error - #:clsql-simple-error - #:clsql-warning - #:clsql-simple-warning - #:clsql-invalid-spec-error - #:clsql-invalid-spec-error-connection-spec - #:clsql-invalid-spec-error-database-type - #:clsql-invalid-spec-error-template - #:clsql-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec - #:clsql-connect-error-errno - #:clsql-connect-error-error - #:clsql-sql-error - #:clsql-sql-error-database - #:clsql-sql-error-expression - #:clsql-sql-error-errno - #:clsql-sql-error-error - #:clsql-database-warning - #:clsql-database-warning-database - #:clsql-database-warning-message - #:clsql-exists-condition - #:clsql-exists-condition-new-db - #:clsql-exists-condition-old-db - #:clsql-exists-warning - #:clsql-exists-error - #:clsql-closed-error - #:clsql-closed-error-database - - #:*loaded-database-types* - #:reload-database-types - #:*default-database-type* - #:*initialized-database-types* - #:initialize-database-type - - #:database - #:database-name - #:closed-database - #:database-name-from-spec - - ;; utils.lisp - #:number-to-sql-string - #:float-to-sql-string - #:sql-escape-quotes - - ;; database.lisp -- Connection - #:*default-database-type* ; clsql-base xx - #:*default-database* ; classes xx - #:connect ; database xx - #:*connect-if-exists* ; database xx - #:connected-databases ; database xx - #:database ; database xx - #:database-name ; database xx - #:disconnect ; database xx - #:reconnect ; database - #:find-database ; database xx - #:status ; database xx - #:with-database - #:with-default-database - - ;; basic-sql.lisp - #:query - #:execute-command - #:write-large-object - #:read-large-object - #:delete-large-object - #:do-query - #:map-query - - ;; Transactions - #:with-transaction - #:commit-transaction - #:rollback-transaction - #:add-transaction-commit-hook - #:add-transaction-rollback-hook - #:commit ; transact xx - #:rollback ; transact xx - #:with-transaction ; transact xx . - #:start-transaction ; transact xx - #:in-transaction-p ; transact xx - #:database-start-transaction - #:database-abort-transaction - #:database-commit-transaction - #:transaction-level - #:transaction - #:disconnect-pooled - )) - (:export - ;; sql.cl - #:for-each-row - - ;; Large objects (Marc B) - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object - - ;; functional.lisp - ;; These are no longer export since different functions are - ;; exported by the CLSQL-USQL package - ;; #:insert-records - ;; #:delete-records - ;; #:update-records - - . - #1# - ) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) - - ) ;eval-when - -(defpackage #:clsql-user - (:use #:common-lisp #:clsql) - (:documentation "This is the user package for experimenting with CLSQL.")) diff --git a/sql/sql.lisp b/sql/sql.lisp deleted file mode 100644 index c207a8f..0000000 --- a/sql/sql.lisp +++ /dev/null @@ -1,111 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: sql.lisp -;;;; Purpose: High-level SQL interface -;;;; Authors: Kevin M. Rosenberg based on code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-sys) - - -;;; Row processing macro - -(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) - (let ((d (gensym "DISTINCT-")) - (bind-fields (loop for f in fields collect (car f))) - (w (gensym "WHERE-")) - (o (gensym "ORDER-BY-")) - (frm (gensym "FROM-")) - (l (gensym "LIMIT-")) - (q (gensym "QUERY-"))) - `(let ((,frm ,from) - (,w ,where) - (,d ,distinct) - (,l ,limit) - (,o ,order-by)) - (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l))) - (loop for tuple in (query ,q) - collect (destructuring-bind ,bind-fields tuple - ,@body)))))) - -(defun query-string (fields from where distinct order-by limit) - (concatenate - 'string - (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" - (if distinct "distinct " "") (field-names fields) - (from-names from)) - (if where (format nil " where ~{~A~^ ~}" - (where-strings where)) "") - (if order-by (format nil " order by ~{~A~^, ~}" - (order-by-strings order-by))) - (if limit (format nil " limit ~D" limit) ""))) - -(defun lisp->sql-name (field) - (typecase field - (string field) - (symbol (string-upcase (symbol-name field))) - (cons (cadr field)) - (t (format nil "~A" field)))) - -(defun field-names (field-forms) - "Return a list of field name strings from a fields form" - (loop for field-form in field-forms - collect - (lisp->sql-name - (if (cadr field-form) - (cadr field-form) - (car field-form))))) - -(defun from-names (from) - "Return a list of field name strings from a fields form" - (loop for table in (if (atom from) (list from) from) - collect (lisp->sql-name table))) - - -(defun where-strings (where) - (loop for w in (if (atom (car where)) (list where) where) - collect - (if (consp w) - (format nil "~A ~A ~A" (second w) (first w) (third w)) - (format nil "~A" w)))) - -(defun order-by-strings (order-by) - (loop for o in order-by - collect - (if (atom o) - (lisp->sql-name o) - (format nil "~A ~A" (lisp->sql-name (car o)) - (lisp->sql-name (cadr o)))))) - - -;;; Marc Battyani : Large objects support - -(defun create-large-object (&key (database *default-database*)) - "Creates a new large object in the database and returns the object identifier" - (database-create-large-object database)) - -(defun write-large-object (object-id data &key (database *default-database*)) - "Writes data to the large object" - (database-write-large-object object-id data database)) - -(defun read-large-object (object-id &key (database *default-database*)) - "Reads the large object content" - (database-read-large-object object-id database)) - -(defun delete-large-object (object-id &key (database *default-database*)) - "Deletes the large object in the database" - (database-delete-large-object object-id database)) - - diff --git a/sql/usql.lisp b/sql/usql.lisp deleted file mode 100644 index 1acd88a..0000000 --- a/sql/usql.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: usql.lisp -;;;; Purpose: High-level interface to SQL driver routines needed for -;;;; UncommonSQL -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg -;;;; and onShore Development Inc -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - - -;;; Minimal high-level routines to enable low-level interface for USQL -;;; Thse functions are not exported. If you application depends on these -;;; consider using the clsql-usql package. - - -(in-package #:clsql-sys) - -(defun list-tables (&key (database *default-database*)) - "List all tables in *default-database*, or if the :database keyword arg -is given, the specified database. If the keyword arg :system-tables -is true, then it will not filter out non-user tables. Table names are -given back as a list of strings." - (database-list-tables database)) - - -(defun list-attributes (table &key (database *default-database*)) - "List the attributes of TABLE in *default-database, or if the -:database keyword is given, the specified database. Attributes are -returned as a list of strings." - (database-list-attributes table database)) - -(defun attribute-type (attribute table &key (database *default-database*)) - "Return the field type of the ATTRIBUTE in TABLE. The optional -keyword argument :database specifies the database to query, defaulting -to *default-database*." - (database-attribute-type attribute table database)) - -(defun create-sequence (name &key (database *default-database*)) - (database-create-sequence name database)) - -(defun drop-sequence (name &key (database *default-database*)) - (database-drop-sequence name database)) - -(defun sequence-next (name &key (database *default-database*)) - (database-sequence-next name database)) - - diff --git a/tests/README b/tests/README deleted file mode 100644 index 3e1b561..0000000 --- a/tests/README +++ /dev/null @@ -1,20 +0,0 @@ -These tests require the setup of a configuration file with account -information for MySQL and PostgreSQL SQL servers. Additionally, the -Debian package acl-installer must be installed and a license -downloaded to use the AODBC tests. - -Furthermore, if you are not using the Debian package of CLSQL, these -tests require the downloading of the rtest and ptester packages from -http://files.b9.com/. - -This test suite looks for a configuration file named -".clsql-test.config" located in the users home directory. - -This file contains a single a-list that specifies the connection - specs for each database type to be tested. For example, to test all -platforms, a sample file might look like this: - -((:mysql ("localhost" "a-mysql-db" "user1" "secret")) - (:aodbc ("my-dsn" "a-user" "pass")) - (:postgresql ("localhost" "another-db" "user2" "dont-tell")) - (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) diff --git a/tests/old-tests/xptest-clsql.lisp b/tests/old-tests/xptest-clsql.lisp deleted file mode 100644 index 51fad13..0000000 --- a/tests/old-tests/xptest-clsql.lisp +++ /dev/null @@ -1,224 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: xptest-clsql.cl -;;;; Purpose: Test of CLSQL using XPTest package -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id$ -;;;; -;;;; The XPTest package can be downloaded from -;;;; http://alpha.onshored.com/lisp-software/ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - - -;;; This test suite looks for a configuration file named "test.config" -;;; This file contains a single a-list that specifies the connection -;;; specs for each database type to be tested. For example, to test all -;;; platforms, a sample "test.config" may look like: -;;; -;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) -;;; (:aodbc ("my-dsn" "a-user" "pass")) -;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell")) -;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) -(mk:load-system "XPTest") - -(in-package :clsql-user) -(use-package :xptest) - -(def-test-fixture clsql-fixture () - ((aodbc-spec :accessor aodbc-spec) - (mysql-spec :accessor mysql-spec) - (pgsql-spec :accessor pgsql-spec) - (pgsql-socket-spec :accessor pgsql-socket-spec)) - (:documentation "Test fixture for CLSQL testing")) - -(defvar *config-pathname* (make-pathname :name "test" - :type "config" - :defaults *load-truename*)) -(defmethod setup ((fix clsql-fixture)) - (if (probe-file *config-pathname*) - (let (config) - (with-open-file (stream *config-pathname* :direction :input) - (setq config (read stream))) - (setf (aodbc-spec fix) (cadr (assoc :aodbc config))) - (setf (mysql-spec fix) (cadr (assoc :mysql config))) - (setf (pgsql-spec fix) (cadr (assoc :postgresql config))) - (setf (pgsql-socket-spec fix) - (cadr (assoc :postgresql-socket config)))) - (error "XPTest Config file ~S not found" *config-pathname*))) - -(defmethod teardown ((fix clsql-fixture)) - t) - -(defmethod mysql-table-test ((test clsql-fixture)) - (test-table (mysql-spec test) :mysql)) - -(defmethod aodbc-table-test ((test clsql-fixture)) - (test-table (aodbc-spec test) :aodbc)) - -(defmethod pgsql-table-test ((test clsql-fixture)) - (test-table (pgsql-spec test) :postgresql)) - -(defmethod pgsql-socket-table-test ((test clsql-fixture)) - (test-table (pgsql-socket-spec test) :postgresql-socket)) - - -(defmethod test-table (spec type) - (when spec - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types :auto)) - (test-table-row row :auto)) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto)) - (when (map-query nil #'list "select * from test_clsql" - :database db :types :auto) - (failure "Expected NIL result from map-query nil")) - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil)) - (do-query ((int float bigint str) "select * from test_clsql" :types :auto) - (test-table-row (list int float bigint str) :auto)) - (drop-test-table db) - ) - (disconnect :database db))))) - - -(defmethod mysql-low-level ((test clsql-fixture)) - (let ((spec (mysql-spec test))) - (when spec - (let ((db (clsql-mysql::database-connect spec :mysql))) - (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) - (clsql-mysql::database-execute-command - "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) - (dotimes (i 10) - (clsql-mysql::database-execute-command - (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" - i (number-to-sql-string (sqrt i)) - (number-to-sql-string (sqrt i))) - db)) - (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) - (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res))) - (failure "Error calling mysql-num-rows")) - (clsql-mysql::database-dump-result-set res db)) - (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) - (clsql-mysql::database-disconnect db))))) - -(defparameter clsql-test-suite - (make-test-suite - "CLSQL Test Suite" - "Basic test suite for database operations." - ("MySQL Low Level Interface" 'clsql-fixture - :test-thunk 'mysql-low-level - :description "A test of MySQL low-level interface") - ("MySQL Table" 'clsql-fixture - :test-thunk 'mysql-table-test - :description "A test of MySQL") - ("PostgreSQL Table" 'clsql-fixture - :test-thunk 'pgsql-table-test - :description "A test of PostgreSQL tables") - ("PostgreSQL Socket Table" 'clsql-fixture - :test-thunk 'pgsql-socket-table-test - :description "A test of PostgreSQL Socket tables") - )) - -#+allegro -(add-test (make-test-case "AODBC table test" 'clsql-fixture - :test-thunk 'aodbc-table-test - :description "Test AODBC table") - clsql-test-suite) - -;;;; Testing functions - -(defun transform-float-1 (i) - (* i (abs (/ i 2)) (expt 10 (* 2 i)))) - -(defun transform-bigint-1 (i) - (* i (expt 10 (* 3 (abs i))))) - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" - :database db) - (dotimes (i 11) - (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" - test-int - (number-to-sql-string test-flt) - (transform-bigint-1 test-int) - (number-to-sql-string test-flt) - ) - :database db)))) - -(defun parse-double (num-str) - (let ((*read-default-float-format* 'double-float)) - (coerce (read-from-string num-str) 'double-float))) - -(defun test-table-row (row types) - (unless (and (listp row) - (= 4 (length row))) - (failure "Row ~S is incorrect format" row)) - (destructuring-bind (int float bigint str) row - (cond - ((eq types :auto) - (unless (and (integerp int) - (typep float 'double-float) - (integerp bigint) - (stringp str)) - (failure "Incorrect field type for row ~S" row))) - ((null types) - (unless (and (stringp int) - (stringp float) - (stringp bigint) - (stringp str)) - (failure "Incorrect field type for row ~S" row)) - (setq int (parse-integer int)) - (setq bigint (parse-integer bigint)) - (setq float (parse-double float))) - ((listp types) - (error "NYI") - ) - (t - (failure "Invalid types field (~S) passed to test-table-row" types))) - (unless (= float (transform-float-1 int)) - (failure "Wrong float value ~A for int ~A (row ~S)" float int row)) - (unless (= float (parse-double str)) - (failure "Wrong string value ~A" str)))) - - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql")) - -(report-result (run-test clsql-test-suite :handle-errors nil) :verbose t) - - diff --git a/tests/package.lisp b/tests/package.lisp deleted file mode 100644 index 84f5e0a..0000000 --- a/tests/package.lisp +++ /dev/null @@ -1,18 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.lisp -;;;; Purpose: Package file clsql testing suite -;;;; Author: Kevin M. Rosenberg -;;;; Date Started: Apr 2003 -;;;; -;;;; $Id$ -;;;; ************************************************************************* - -(in-package #:cl-user) - -(defpackage #:clsql-tests - (:use #:asdf #:cl #:clsql #:ptester)) - - diff --git a/tests/tables.lisp b/tests/tables.lisp deleted file mode 100644 index 7d5daa5..0000000 --- a/tests/tables.lisp +++ /dev/null @@ -1,262 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: tables.cl -;;;; Purpose: Table creation tests in CLSQL -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -;;; This test suite looks for a configuration file named ".clsql-test.config" -;;; located in the users home directory. -;;; -;;; This file contains a single a-list that specifies the connection -;;; specs for each database type to be tested. For example, to test all -;;; platforms, a sample "test.config" may look like: -;;; -;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) -;;; (:aodbc ("my-dsn" "a-user" "pass")) -;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) -;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) - -(in-package :clsql-tests) - -(defvar *config-pathname* - (make-pathname :default (user-homedir-pathname) - :name ".clsql-test" - :type ".config")) - -(defclass conn-specs () - ((aodbc-spec :accessor aodbc-spec) - (mysql-spec :accessor mysql-spec) - (pgsql-spec :accessor pgsql-spec) - (pgsql-socket-spec :accessor pgsql-socket-spec)) - (:documentation "Test fixture for CLSQL testing")) - - -(defun read-specs (&optional (path *config-pathname*)) - (if (probe-file path) - (with-open-file (stream path :direction :input) - (let ((config (read stream)) - (specs (make-instance 'conn-specs))) - (setf (aodbc-spec specs) (cadr (assoc :aodbc config))) - (setf (mysql-spec specs) (cadr (assoc :mysql config))) - (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) - (setf (pgsql-socket-spec specs) - (cadr (assoc :postgresql-socket config))) - specs)) - (warn "CLSQL tester config file ~S not found" path))) - -(defvar *conn-specs* (read-specs)) - -(defmethod mysql-table-test ((test conn-specs)) - (test-table (mysql-spec test) :mysql)) - -(defmethod aodbc-table-test ((test conn-specs)) - (test-table (aodbc-spec test) :aodbc)) - -(defmethod pgsql-table-test ((test conn-specs)) - (test-table (pgsql-spec test) :postgresql)) - -(defmethod pgsql-socket-table-test ((test conn-specs)) - (test-table (pgsql-socket-spec test) :postgresql-socket)) - -(defmethod test-table (spec type) - (when spec - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types :auto)) - (test-table-row row :auto type)) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (test (map-query nil #'list "select * from test_clsql" - :database db :types :auto) - nil - :fail-info "Expected NIL result from map-query nil") - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil type)) - (do-query ((int float bigint str) "select * from test_clsql" :types :auto) - (test-table-row (list int float bigint str) :auto type)) - (drop-test-table db) - ) - (disconnect :database db))))) - - -;;;; Testing functions - -(defun transform-float-1 (i) - (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) - -(defun transform-bigint-1 (i) - (* i (expt 10 (* 3 (abs i))))) - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" - :database db) - (dotimes (i 11) - (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" - test-int - (number-to-sql-string test-flt) - (transform-bigint-1 test-int) - (number-to-sql-string test-flt) - ) - :database db)))) - -(defun parse-double (num-str) - (let ((*read-default-float-format* 'double-float)) - (coerce (read-from-string num-str) 'double-float))) - -(defun test-table-row (row types db-type) - (test (and (listp row) - (= 4 (length row))) - t - :fail-info - (format nil "Row ~S is incorrect format" row)) - (destructuring-bind (int float bigint str) row - (cond - ((eq types :auto) - (test (and (integerp int) - (typep float 'double-float) - (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions - (integerp bigint)) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types :auto)" row))) - ((null types) - (test (and (stringp int) - (stringp float) - (stringp bigint) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types nil)" row)) - (setq int (parse-integer int)) - (setq bigint (parse-integer bigint)) - (setq float (parse-double float))) - ((listp types) - (error "NYI") - ) - (t - (test t nil - :fail-info - (format nil "Invalid types field (~S) passed to test-table-row" types)))) - (test (transform-float-1 int) - float - :test #'eql - :fail-info - (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) - (test float - (parse-double str) - :test #'double-float-equal - :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" - str float row)))) - - -(defun double-float-equal (a b) - (if (zerop a) - (if (zerop b) - t - nil) - (let ((diff (abs (/ (- a b) a)))) - (if (> diff (* 10 double-float-epsilon)) - nil - t)))) - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql" :database db)) - - -(deftest lowlevel.mysql.table.1 - (let ((spec (mysql-spec *conn-specs*)) - (result)) - (when spec - (let ((db (clsql-mysql::database-connect spec :mysql))) - (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) - (clsql-mysql::database-execute-command - "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) - (dotimes (i 10) - (clsql-mysql::database-execute-command - (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" - i (clsql:number-to-sql-string (sqrt i)) - (clsql:number-to-sql-string (sqrt i))) - db)) - (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) - (setq result (mysql:mysql-num-rows - (clsql-mysql::mysql-result-set-res-ptr res))) - (clsql-mysql::database-dump-result-set res db)) - (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) - (clsql-mysql::database-disconnect db)))) - 10) - -;(mysql-table-test specs) -;(pgsql-table-test specs) -;(pgsql-socket-table-test specs) -;(aodbc-table-test specs) - - - -(defmacro def-test-table (name spec type) - (deftest ,name - (when ,spec - (let ((db (clsql:connect ,spec :database-type ,type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types :auto)) - (test-table-row row :auto type)) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (test (map-query nil #'list "select * from test_clsql" - :database db :types :auto) - nil - :fail-info "Expected NIL result from map-query nil") - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil type)) - (do-query ((int float bigint str) "select * from test_clsql" :types :auto) - (test-table-row (list int float bigint str) :auto type)) - (drop-test-table db) - ) - (disconnect :database db))))) diff --git a/tests/tests.lisp b/tests/tests.lisp deleted file mode 100644 index 76d0dd9..0000000 --- a/tests/tests.lisp +++ /dev/null @@ -1,270 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: tests.lisp -;;;; Purpose: Automated test of CLSQL using ACL's tester -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -;;; This test suite looks for a configuration file named ".clsql-test.config" -;;; located in the users home directory. -;;; -;;; This file contains a single a-list that specifies the connection -;;; specs for each database type to be tested. For example, to test all -;;; platforms, a sample "test.config" may look like: -;;; -;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) -;;; (:aodbc ("my-dsn" "a-user" "pass")) -;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) -;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")) -;;; (:sqlite ("path-to-sqlite-db"))) - -(in-package :clsql-tests) - -(defvar *config-pathname* - (make-pathname :defaults (user-homedir-pathname) - :name ".clsql-test" - :type "config")) - - -(defclass conn-specs () - ((aodbc-spec :accessor aodbc-spec) - (mysql-spec :accessor mysql-spec) - (pgsql-spec :accessor pgsql-spec) - (pgsql-socket-spec :accessor pgsql-socket-spec) - (sqlite-spec :accessor sqlite-spec)) - (:documentation "Test fixture for CLSQL testing")) - - -(defun read-specs (&optional (path *config-pathname*)) - (if (probe-file path) - (with-open-file (stream path :direction :input) - (let ((config (read stream)) - (specs (make-instance 'conn-specs))) - (setf (aodbc-spec specs) (cadr (assoc :aodbc config))) - (setf (mysql-spec specs) (cadr (assoc :mysql config))) - (setf (pgsql-spec specs) (cadr (assoc :postgresql config))) - (setf (pgsql-socket-spec specs) - (cadr (assoc :postgresql-socket config))) - (setf (sqlite-spec specs) (cadr (assoc :sqlite config))) - specs)) - (progn - (warn "CLSQL tester config file ~S not found" path) - nil))) - -(defmethod mysql-table-test ((test conn-specs)) - (test-table (mysql-spec test) :mysql)) - -(defmethod aodbc-table-test ((test conn-specs)) - (test-table (aodbc-spec test) :aodbc)) - -(defmethod pgsql-table-test ((test conn-specs)) - (test-table (pgsql-spec test) :postgresql)) - -(defmethod pgsql-socket-table-test ((test conn-specs)) - (test-table (pgsql-socket-spec test) :postgresql-socket)) - -(defmethod sqlite-table-test ((test conn-specs)) - (test-table (sqlite-spec test) :sqlite)) - -(defmethod test-table (spec type) - (when spec - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types :auto)) - (test-table-row row :auto type)) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types :auto) - do (test-table-row row :auto type)) - (test (map-query nil #'list "select * from test_clsql" - :database db :types :auto) - nil - :fail-info "Expected NIL result from map-query nil") - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil type)) - (do-query ((int float bigint str) "select * from test_clsql" :types :auto) - (test-table-row (list int float bigint str) :auto type)) - (drop-test-table db) - ) - (disconnect :database db))))) - -;;; -;;; SQLite is typeless: execute untyped tests only. -;;; -(defmethod test-table (spec (type (eql :sqlite))) - (when spec - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (dolist (row (query "select * from test_clsql" :database db :types nil)) - (test-table-row row nil type)) - (loop for row across (map-query 'vector #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - (loop for row in (map-query 'list #'list "select * from test_clsql" - :database db :types nil) - do (test-table-row row nil type)) - - (do-query ((int float bigint str) "select * from test_clsql") - (test-table-row (list int float bigint str) nil type)) - (drop-test-table db) - ) - (disconnect :database db))))) - -(defmethod mysql-low-level ((test conn-specs)) - #-clisp - (let ((spec (mysql-spec test))) - (when spec - (let ((db (clsql-mysql::database-connect spec :mysql))) - (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) - (clsql-mysql::database-execute-command - "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db) - (dotimes (i 10) - (clsql-mysql::database-execute-command - (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')" - i (clsql:number-to-sql-string (sqrt i)) - (clsql:number-to-sql-string (sqrt i))) - db)) - (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) - (test (mysql:mysql-num-rows - (clsql-mysql::mysql-result-set-res-ptr res)) - 10 - :test #'eql - :fail-info "Error calling mysql-num-rows") - (clsql-mysql::database-dump-result-set res db)) - (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db) - (clsql-mysql::database-disconnect db))))) - - - -;;;; Testing functions - -(defun transform-float-1 (i) - (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) - -(defun transform-bigint-1 (i) - (* i (expt 10 (* 3 (abs i))))) - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))" - :database db) - (dotimes (i 11) - (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')" - test-int - (number-to-sql-string test-flt) - (transform-bigint-1 test-int) - (number-to-sql-string test-flt) - ) - :database db)))) - -(defun parse-double (num-str) - (let ((*read-default-float-format* 'double-float)) - (coerce (read-from-string num-str) 'double-float))) - -(defun test-table-row (row types db-type) - (test (and (listp row) - (= 4 (length row))) - t - :fail-info - (format nil "Row ~S is incorrect format" row)) - (destructuring-bind (int float bigint str) row - (cond - ((eq types :auto) - (test (and (integerp int) - (typep float 'double-float) - (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions - (integerp bigint)) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types :auto)" row))) - ((null types) - (test (and (stringp int) - (stringp float) - (stringp bigint) - (stringp str)) - t - :fail-info - (format nil "Incorrect field type for row ~S (types nil)" row)) - (setq int (parse-integer int)) - (setq bigint (parse-integer bigint)) - (setq float (parse-double float))) - ((listp types) - (error "NYI") - ) - (t - (test t nil - :fail-info - (format nil "Invalid types field (~S) passed to test-table-row" types)))) - (unless (eq db-type :sqlite) ; SQLite is typeless. - (test (transform-float-1 int) - float - :test #'eql - :fail-info - (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))) - (test float - (parse-double str) - :test #'double-float-equal - :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S" - str float row)))) - - -(defun double-float-equal (a b) - (if (zerop a) - (if (zerop b) - t - nil) - (let ((diff (abs (/ (- a b) a)))) - (if (> diff (* 10 double-float-epsilon)) - nil - t)))) - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql" :database db)) - -(defun run-tests () - (let ((specs (read-specs))) - (unless specs - (warn "Not running test because test configuration file is missing") - (return-from run-tests :skipped)) - (with-tests (:name "CLSQL") - (mysql-low-level specs) - (mysql-table-test specs) - (pgsql-table-test specs) - (pgsql-socket-table-test specs) - (aodbc-table-test specs) - (sqlite-table-test specs) - )) - t) -