--- /dev/null
+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")))
--- /dev/null
+;;;; -*- 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)
+
+
--- /dev/null
+;;;; -*- 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))
+
+
--- /dev/null
+;;;; -*- 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)))))
--- /dev/null
+;;;; -*- 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)
+
--- /dev/null
+clsql-uffi.so
+clsql-uffi.dll
+clsql-uffi.lib
+clsql-uffi.dylib
+.bin
+*.fasl
+*.pfsl
+*.dfsl
+*.cfsl
+*.fasla16
+*.fasla8
+*.faslm16
+*.faslm8
+*.fsl
--- /dev/null
+SUBDIRS :=
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean
--- /dev/null
+;;;; -*- 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))))
+
--- /dev/null
+;;;; -*- 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."))
--- /dev/null
+;;;; -*- 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))
+
+
--- /dev/null
+;;;; -*- 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))
+
+
--- /dev/null
+;;;; -*- 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 <kevin@rosenberg.net>"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :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")))
+
--- /dev/null
+;;;; -*- 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 <kevin@rosenberg.net>"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :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))
+++ /dev/null
-;;;; -*- 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 <kevin@rosenberg.net>"
- :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
- :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")))
-
+++ /dev/null
-;;;; -*- 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 <kevin@rosenberg.net>"
- :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
- :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))
+++ /dev/null
-clsql-uffi.so
-clsql-uffi.dll
-clsql-uffi.lib
-clsql-uffi.dylib
-.bin
-*.fasl
-*.pfsl
-*.dfsl
-*.cfsl
-*.fasla16
-*.fasla8
-*.faslm16
-*.faslm8
-*.fsl
+++ /dev/null
-SUBDIRS :=
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean
+++ /dev/null
-;;;; -*- 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))))
-
+++ /dev/null
-;;;; -*- 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."))
+++ /dev/null
-;;;; -*- 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))
-
-
+++ /dev/null
-;;;; -*- 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))
-
-
+++ /dev/null
-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")))
+++ /dev/null
-;;;; -*- 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)
-
-
+++ /dev/null
-;;;; -*- 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))
-
-
+++ /dev/null
-;;;; -*- 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)))))
+++ /dev/null
-;;;; -*- 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)
-
projects / clsql.git / commitdiff