From 2073ba6b66571d3da57523dbdcb30ed6ffb4b161 Mon Sep 17 00:00:00 2001 From: Marc Battyani Date: Fri, 19 Apr 2002 20:25:20 +0000 Subject: [PATCH 01/16] r1781: Large objects support for Postgresql --- interfaces/postgresql/postgresql-api.cl | 65 ++++++++++++++++++++- interfaces/postgresql/postgresql-package.cl | 11 +++- interfaces/postgresql/postgresql-sql.cl | 55 ++++++++++++++++- sql/db-interface.cl | 15 ++++- sql/package.cl | 14 ++++- sql/sql.cl | 17 +++++- test-suite/acl-compat-tester.cl | 3 +- test-suite/tester-clsql.cl | 4 +- 8 files changed, 175 insertions(+), 9 deletions(-) diff --git a/interfaces/postgresql/postgresql-api.cl b/interfaces/postgresql/postgresql-api.cl index 83ba307..5f67961 100644 --- a/interfaces/postgresql/postgresql-api.cl +++ b/interfaces/postgresql/postgresql-api.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-api.cl,v 1.5 2002/03/29 09:37:24 kevin Exp $ +;;;; $Id: postgresql-api.cl,v 1.6 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -202,3 +202,66 @@ ((conn pgsql-conn)) :module "postgresql" :returning :int) + + +;;; Large objects support (MB) + +(defconstant +INV_ARCHIVE+ 65536) ; fe-lobj.c +(defconstant +INV_WRITE+ 131072) +(defconstant +INV_READ+ 262144) + +(declaim (inline lo-creat)) +(uffi:def-function ("lo_creat" lo-create) + ((conn pgsql-conn) + (mode :int)) + :module "postgresql" + :returning pgsql-oid) + +(declaim (inline lo-open)) +(uffi:def-function ("lo_open" lo-open) + ((conn pgsql-conn) + (oid pgsql-oid) + (mode :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-write)) +(uffi:def-function ("lo_write" lo-write) + ((conn pgsql-conn) + (fd :int) + (data :cstring) + (size :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-read)) +(uffi:def-function ("lo_read" lo-read) + ((conn pgsql-conn) + (fd :int) + (data (* :unsigned-char)) + (size :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-lseek)) +(uffi:def-function ("lo_lseek" lo-lseek) + ((conn pgsql-conn) + (fd :int) + (offset :int) + (whence :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-close)) +(uffi:def-function ("lo_close" lo-close) + ((conn pgsql-conn) + (fd :int)) + :module "postgresql" + :returning :int) + +(declaim (inline lo-unlink)) +(uffi:def-function ("lo_unlink" lo-unlink) + ((conn pgsql-conn) + (oid pgsql-oid)) + :module "postgresql" + :returning :int) diff --git a/interfaces/postgresql/postgresql-package.cl b/interfaces/postgresql/postgresql-package.cl index 96f0bfb..22c4a3f 100644 --- a/interfaces/postgresql/postgresql-package.cl +++ b/interfaces/postgresql/postgresql-package.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-package.cl,v 1.6 2002/03/29 09:37:24 kevin Exp $ +;;;; $Id: postgresql-package.cl,v 1.7 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -69,6 +69,15 @@ #:PQgetisnull #:PQclear #:PQisBusy + + ;;Large Objects (Marc B) + #:lo-create + #:lo-open + #:lo-write + #:lo-read + #:lo-lseek + #:lo-close + #:lo-unlink ) (:documentation "This is the low-level interface to PostgreSQL.")) diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index 275ac39..21cb247 100644 --- a/interfaces/postgresql/postgresql-sql.cl +++ b/interfaces/postgresql/postgresql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-sql.cl,v 1.12 2002/03/29 09:37:24 kevin Exp $ +;;;; $Id: postgresql-sql.cl,v 1.13 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -274,3 +274,56 @@ finally (incf (postgresql-result-set-tuple-index result-set)) (return list))))) + +;;; Large objects support (Marc B) + +(defmethod database-create-large-object ((database postgresql-database)) + (lo-create (database-conn-ptr database) + (logior postgresql::+INV_WRITE+ postgresql::+INV_READ+))) + +;; (MB)the begin/commit/rollback stuff will be removed when with-transaction wil be implemented +(defmethod database-write-large-object ( object-id (data string) (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (length (length data)) + (result nil) + (fd nil)) + (unwind-protect + (progn + (database-execute-command "begin" database) + (setf fd (lo-open ptr object-id postgresql::+INV_WRITE+)) + (when (>= fd 0) + (when (= (lo-write ptr fd data length) length) + (setf result t)))) + (progn + (when (and fd (>= fd 0)) + (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) + result)) + +;; (MB) the begin/commit/rollback stuff will be removed when with-transaction wil be implemented +(defmethod database-read-large-object (object-id (database postgresql-database)) + (let ((ptr (database-conn-ptr database)) + (buffer nil) + (result nil) + (length 0) + (fd nil)) + (unwind-protect + (progn + (database-execute-command "begin" database) + (setf fd (lo-open ptr object-id postgresql::+INV_READ+)) + (when (>= fd 0) + (setf length (lo-lseek ptr fd 0 2)) + (lo-lseek ptr fd 0 0) + (when (> length 0) + (setf buffer (uffi:allocate-foreign-string length :type '(:unsigned :byte))) + (when (= (lo-read ptr fd buffer length) length) + (setf result (uffi:convert-from-foreign-string + buffer :length length :null-terminated-p nil)))))) + (progn + (when buffer (uffi:free-foreign-object buffer)) + (when (and fd (>= fd 0)) (lo-close ptr fd)) + (database-execute-command (if result "commit" "rollback") database))) + result)) + +(defmethod database-delete-large-object (object-id (database postgresql-database)) + (lo-unlink (database-conn-ptr database) object-id)) diff --git a/sql/db-interface.cl b/sql/db-interface.cl index 0fac5b2..1ce8681 100644 --- a/sql/db-interface.cl +++ b/sql/db-interface.cl @@ -9,7 +9,7 @@ ;;;; onShoreD to support UncommonSQL front-end ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: db-interface.cl,v 1.5 2002/04/01 05:27:55 kevin Exp $ +;;;; $Id: db-interface.cl,v 1.6 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai, and onShoreD @@ -159,3 +159,16 @@ the given lisp type and parameters.")) (:documentation "Return the unique ID of a database object.")) +;;; Large objects support (Marc Battyani) + +(defgeneric database-create-large-object (database) + (:documentation "Creates a new large object in the database and returns the object identifier")) + +(defgeneric database-write-large-object (object-id (data string) database) + (:documentation "Writes data to the large object")) + +(defgeneric database-read-large-object (object-id database) + (:documentation "Reads the large object content")) + +(defgeneric database-delete-large-object (object-id database) + (:documentation "Deletes the large object in the database")) diff --git a/sql/package.cl b/sql/package.cl index f816764..2db3c44 100644 --- a/sql/package.cl +++ b/sql/package.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: package.cl,v 1.6 2002/04/07 15:23:10 kevin Exp $ +;;;; $Id: package.cl,v 1.7 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -51,6 +51,13 @@ #:database-sequence-next #:sql-escape + + ;; Large objects (Marc B) + #:database-create-large-object + #:database-write-large-object + #:database-read-large-object + #:database-delete-large-object + ;; Shared exports for re-export by CLSQL . #1=(#:clsql-condition @@ -123,6 +130,11 @@ #:drop-sequence #:sequence-next + ;; Large objects (Marc B) + #:create-large-object + #:write-large-object + #:read-large-object + #:delete-large-object )) (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) diff --git a/sql/sql.cl b/sql/sql.cl index f0d5bee..4b88fd5 100644 --- a/sql/sql.cl +++ b/sql/sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: sql.cl,v 1.11 2002/03/29 08:34:44 kevin Exp $ +;;;; $Id: sql.cl,v 1.12 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -270,5 +270,20 @@ specified in output-type-spec and returned like in MAP." ,@body)) (database-dump-result-set ,result-set ,db))))))) +;;; 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/test-suite/acl-compat-tester.cl b/test-suite/acl-compat-tester.cl index 1ce4fef..08c5160 100644 --- a/test-suite/acl-compat-tester.cl +++ b/test-suite/acl-compat-tester.cl @@ -24,7 +24,7 @@ ;; Place, Suite 330, Boston, MA 02111-1307 USA ;; ;;;; from the original ACL 6.1 sources: -;; $Id: acl-compat-tester.cl,v 1.1 2002/04/08 02:46:43 kevin Exp $ +;; $Id: acl-compat-tester.cl,v 1.2 2002/04/19 20:25:20 marc.battyani Exp $ (defpackage :util.test @@ -50,6 +50,7 @@ (in-package :util.test) +#-lispworks (unless (find-class 'break nil) (define-condition break (simple-condition) ())) diff --git a/test-suite/tester-clsql.cl b/test-suite/tester-clsql.cl index f3e6bef..03045fa 100644 --- a/test-suite/tester-clsql.cl +++ b/test-suite/tester-clsql.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: tester-clsql.cl,v 1.4 2002/04/10 04:57:28 kevin Exp $ +;;;; $Id: tester-clsql.cl,v 1.5 2002/04/19 20:25:20 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -23,7 +23,7 @@ ;;; ;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret")) ;;; (:aodbc ("my-dsn" "a-user" "pass")) -;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell")) +;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) ;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) -- 2.34.1 From b02398c77cf6ed65477afc307f94e8a2a85fd48f Mon Sep 17 00:00:00 2001 From: Marc Battyani Date: Fri, 19 Apr 2002 21:28:52 +0000 Subject: [PATCH 02/16] r1782: Large objects support for Postgresql --- ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ChangeLog b/ChangeLog index 8b80def..f2e54ff 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +19 Apr 2002 Marc Battyani (marc.battyani@fractalconcept.com) + * interface/postgresql/postgresql-api.cl: + * interface/postgresql/postgresql-sql.cl: + * sql/sql.cl: + * sql/db-interface.cl: + Added large objects support for postgresql. + 07 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * src/postgresql-socket/postgresql-socket-api.cl: Fixed find-foreign-function call, eliminated crypt warning -- 2.34.1 From f336e8abdec0a7bb25df224df7f8b59cf5562206 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 20 Apr 2002 22:51:42 +0000 Subject: [PATCH 03/16] r1783: *** empty log message *** --- test-suite/old-tests/interactive-test.cl | 138 ++++++++++++++ test-suite/old-tests/xptest-clsql.cl | 224 +++++++++++++++++++++++ 2 files changed, 362 insertions(+) create mode 100644 test-suite/old-tests/interactive-test.cl create mode 100644 test-suite/old-tests/xptest-clsql.cl diff --git a/test-suite/old-tests/interactive-test.cl b/test-suite/old-tests/interactive-test.cl new file mode 100644 index 0000000..c55e75e --- /dev/null +++ b/test-suite/old-tests/interactive-test.cl @@ -0,0 +1,138 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-clsql.cl +;;;; Purpose: Basic test of CLSQL +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: interactive-test.cl,v 1.1 2002/04/20 22:51:42 kevin Exp $ +;;;; +;;;; 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :cl-user) + + +(defvar *config-pathname* (make-pathname :name "test" + :type "config" + :defaults *load-truename*)) +(defparameter *config* nil) + +(defun do-test (&optional (interactive nil)) + (if interactive + (test-interactive) + (if (probe-file *config-pathname*) + (with-open-file (stream *config-pathname* :direction :input) + (setq *config* (read stream)) + (test-automated *config*)) + (test-interactive)))) + +(defun test-interactive () + (do ((done nil)) + (done) + (multiple-value-bind (spec type) (get-spec-and-type) + (if spec + (clsql-test-table spec type) + (setq done t))))) + +(defun test-automated (config) + (dolist (elem config) + (let ((type (car elem)) + (spec (cadr elem))) + #-allegro + (unless (eq type :aodbc) + (clsql-test-table spec type)) + #+allegro + (clsql-test-table spec type))) + ) + + +(defun create-test-table (db) + (ignore-errors + (clsql:execute-command + "DROP TABLE test_clsql" :database db)) + (clsql:execute-command + "CREATE TABLE test_clsql (n integer, n_pi float, n_pi_str CHAR(20))" + :database db) + (dotimes (i 11) + (let ((n (- i 5))) + (clsql:execute-command + (format nil "INSERT INTO test_clsql VALUES (~a,~a,'~a')" + n (clsql:float-to-sql-string (* pi n)) + (clsql:float-to-sql-string (* pi n))) + :database db)))) + +(defun drop-test-table (db) + (clsql:execute-command "DROP TABLE test_clsql")) + +(defun clsql-test-table (spec type) + (when (eq type :mysql) + (test-clsql-mysql spec)) + (let ((db (clsql:connect spec :database-type type :if-exists :new))) + (unwind-protect + (progn + (create-test-table db) + (pprint (clsql:query "select * from test_clsql" + :database db + :types :auto)) + (pprint (clsql:map-query 'vector #'list "select * from test_clsql" + :database db + :types :auto)) ;;'(:int :double t))) + (drop-test-table db)) + (clsql:disconnect :database db))) + ) + +(defun test-clsql-mysql (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 (sqrt i) (format nil "~d" (sqrt i))) + db)) + (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) + (format t "~&Number rows: ~D~%" (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))) + + +(defun get-spec-and-type () + (format t "~&Test CLSQL") + (format t "~&==========~%") + (format t "~&Enter connection type (:mysql :postgresql :postgresql-socket") + #+allegro (format t " :aodbc") + (format t ") [default END]: ") + (let ((type-string (read-line))) + (if (zerop (length type-string)) + (values nil nil) + (get-spec-for-type (read-from-string type-string))))) + +(defun get-spec-for-type (type) + (let ((spec (get-spec-using-format type + (ecase type + ((:mysql :postgresql :postgresql-socket) + '("host" "database" "user" "password")) + (:aodbc + '("dsn" "user" "password")))))) + (values spec type))) + + +(defun get-spec-using-format (type spec-format) + (let (spec) + (format t "~&Connection Spec for ~A" (symbol-name type)) + (format t "~&------------------------------") + + (dolist (elem spec-format) + (format t "~&Enter ~A: " elem) + (push (read-line) spec)) + (nreverse spec))) diff --git a/test-suite/old-tests/xptest-clsql.cl b/test-suite/old-tests/xptest-clsql.cl new file mode 100644 index 0000000..67c5a58 --- /dev/null +++ b/test-suite/old-tests/xptest-clsql.cl @@ -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: xptest-clsql.cl,v 1.1 2002/04/20 22:51:42 kevin Exp $ +;;;; +;;;; 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) + + -- 2.34.1 From c6310e38125bfc4cba4ac8dff25d8637077edf11 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 20 Apr 2002 22:55:02 +0000 Subject: [PATCH 04/16] r1784: refined reader macro --- test-suite/acl-compat-tester.cl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/acl-compat-tester.cl b/test-suite/acl-compat-tester.cl index 08c5160..14b6bc9 100644 --- a/test-suite/acl-compat-tester.cl +++ b/test-suite/acl-compat-tester.cl @@ -24,7 +24,7 @@ ;; Place, Suite 330, Boston, MA 02111-1307 USA ;; ;;;; from the original ACL 6.1 sources: -;; $Id: acl-compat-tester.cl,v 1.2 2002/04/19 20:25:20 marc.battyani Exp $ +;; $Id: acl-compat-tester.cl,v 1.3 2002/04/20 22:55:02 kevin Exp $ (defpackage :util.test @@ -50,7 +50,7 @@ (in-package :util.test) -#-lispworks +#+cmu (unless (find-class 'break nil) (define-condition break (simple-condition) ())) -- 2.34.1 From 2cd008bdbfc4cae8facce08c0a1a961d3fd9b883 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 21 Apr 2002 15:07:56 +0000 Subject: [PATCH 05/16] r1785: Moved old test programs to old-tests directory --- test-suite/interactive-test.cl | 138 -------------------- test-suite/xptest-clsql.cl | 224 --------------------------------- 2 files changed, 362 deletions(-) delete mode 100644 test-suite/interactive-test.cl delete mode 100644 test-suite/xptest-clsql.cl diff --git a/test-suite/interactive-test.cl b/test-suite/interactive-test.cl deleted file mode 100644 index 93d6625..0000000 --- a/test-suite/interactive-test.cl +++ /dev/null @@ -1,138 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: test-clsql.cl -;;;; Purpose: Basic test of CLSQL -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: interactive-test.cl,v 1.1 2002/04/08 02:47:37 kevin Exp $ -;;;; -;;;; 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :cl-user) - - -(defvar *config-pathname* (make-pathname :name "test" - :type "config" - :defaults *load-truename*)) -(defparameter *config* nil) - -(defun do-test (&optional (interactive nil)) - (if interactive - (test-interactive) - (if (probe-file *config-pathname*) - (with-open-file (stream *config-pathname* :direction :input) - (setq *config* (read stream)) - (test-automated *config*)) - (test-interactive)))) - -(defun test-interactive () - (do ((done nil)) - (done) - (multiple-value-bind (spec type) (get-spec-and-type) - (if spec - (clsql-test-table spec type) - (setq done t))))) - -(defun test-automated (config) - (dolist (elem config) - (let ((type (car elem)) - (spec (cadr elem))) - #-allegro - (unless (eq type :aodbc) - (clsql-test-table spec type)) - #+allegro - (clsql-test-table spec type))) - ) - - -(defun create-test-table (db) - (ignore-errors - (clsql:execute-command - "DROP TABLE test_clsql" :database db)) - (clsql:execute-command - "CREATE TABLE test_clsql (n integer, n_pi float, n_pi_str CHAR(20))" - :database db) - (dotimes (i 11) - (let ((n (- i 5))) - (clsql:execute-command - (format nil "INSERT INTO test_clsql VALUES (~a,~a,'~a')" - n (clsql:float-to-sql-string (* pi n)) - (clsql:float-to-sql-string (* pi n))) - :database db)))) - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql")) - -(defun clsql-test-table (spec type) - (when (eq type :mysql) - (test-clsql-mysql spec)) - (let ((db (clsql:connect spec :database-type type :if-exists :new))) - (unwind-protect - (progn - (create-test-table db) - (pprint (clsql:query "select * from test_clsql" - :database db - :types :auto)) - (pprint (clsql:map-query 'vector #'list "select * from test_clsql" - :database db - :types :auto)) ;;'(:int :double t))) - (drop-test-table db)) - (clsql:disconnect :database db))) - ) - -(defun test-clsql-mysql (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 (sqrt i) (format nil "~d" (sqrt i))) - db)) - (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil))) - (format t "~&Number rows: ~D~%" (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))) - - -(defun get-spec-and-type () - (format t "~&Test CLSQL") - (format t "~&==========~%") - (format t "~&Enter connection type (:mysql :postgresql :postgresql-socket") - #+allegro (format t " :aodbc") - (format t ") [default END]: ") - (let ((type-string (read-line))) - (if (zerop (length type-string)) - (values nil nil) - (get-spec-for-type (read-from-string type-string))))) - -(defun get-spec-for-type (type) - (let ((spec (get-spec-using-format type - (ecase type - ((:mysql :postgresql :postgresql-socket) - '("host" "database" "user" "password")) - (:aodbc - '("dsn" "user" "password")))))) - (values spec type))) - - -(defun get-spec-using-format (type spec-format) - (let (spec) - (format t "~&Connection Spec for ~A" (symbol-name type)) - (format t "~&------------------------------") - - (dolist (elem spec-format) - (format t "~&Enter ~A: " elem) - (push (read-line) spec)) - (nreverse spec))) diff --git a/test-suite/xptest-clsql.cl b/test-suite/xptest-clsql.cl deleted file mode 100644 index 2134763..0000000 --- a/test-suite/xptest-clsql.cl +++ /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: xptest-clsql.cl,v 1.8 2002/03/27 12:27:47 kevin Exp $ -;;;; -;;;; 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) - - -- 2.34.1 From 0fe44ce81f47c779d9695c9211668b4780bf4216 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 23 Apr 2002 18:28:02 +0000 Subject: [PATCH 06/16] r1791: * interfaces/postgresql/postgresql-sql.cl: Fix keyword typo in database-read-large-object * interfaces/mysql/mysql-loader.cl Fix loading on Win32 * test-suite/tester-clsql.cl Fix type coercion of double-float --- ChangeLog | 8 +++++++ VERSION | 2 +- interfaces/mysql/mysql-loader.cl | 10 ++++----- interfaces/postgresql/postgresql-sql.cl | 5 +++-- test-suite/tester-clsql.cl | 28 +++++++++++++------------ 5 files changed, 32 insertions(+), 21 deletions(-) diff --git a/ChangeLog b/ChangeLog index f2e54ff..d3e9e09 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * interfaces/postgresql/postgresql-sql.cl: + Fix keyword typo in database-read-large-object + * interfaces/mysql/mysql-loader.cl + Fix loading on Win32 + * test-suite/tester-clsql.cl + Fix type coercion of double-float + 19 Apr 2002 Marc Battyani (marc.battyani@fractalconcept.com) * interface/postgresql/postgresql-api.cl: * interface/postgresql/postgresql-sql.cl: diff --git a/VERSION b/VERSION index b87ff29..e83707c 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -0.6.7 +0.6.8 diff --git a/interfaces/mysql/mysql-loader.cl b/interfaces/mysql/mysql-loader.cl index fcc31e6..0ff1ad2 100644 --- a/interfaces/mysql/mysql-loader.cl +++ b/interfaces/mysql/mysql-loader.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: mysql-loader.cl,v 1.5 2002/04/06 22:27:41 kevin Exp $ +;;;; $Id: mysql-loader.cl,v 1.6 2002/04/23 18:28:02 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -71,12 +71,12 @@ set to the right path before compiling or loading the system.") *mysql-library-candidate-directories* :drive-letters *mysql-library-candidate-drive-letters*))) + ;; zlib required to load mysql on CMUCL Solaris + (uffi:load-foreign-library + (uffi:find-foreign-library '("libz" "zlib") + '("/usr/lib/" "/usr/local/" "/lib/"))) (when (and - ;; zlib required to load mysql on CMUCL Solaris - (uffi:load-foreign-library - (uffi:find-foreign-library '("libz" "zlib") - '("/usr/lib/" "/usr/local/" "/lib/"))) (uffi:load-foreign-library mysql-path :module "mysql" :supporting-libraries diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index 21cb247..4104afa 100644 --- a/interfaces/postgresql/postgresql-sql.cl +++ b/interfaces/postgresql/postgresql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-sql.cl,v 1.13 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: postgresql-sql.cl,v 1.14 2002/04/23 18:28:02 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -315,7 +315,8 @@ (setf length (lo-lseek ptr fd 0 2)) (lo-lseek ptr fd 0 0) (when (> length 0) - (setf buffer (uffi:allocate-foreign-string length :type '(:unsigned :byte))) + (setf buffer (uffi:allocate-foreign-string + length :unsigned t)) (when (= (lo-read ptr fd buffer length) length) (setf result (uffi:convert-from-foreign-string buffer :length length :null-terminated-p nil)))))) diff --git a/test-suite/tester-clsql.cl b/test-suite/tester-clsql.cl index 03045fa..1e3fd78 100644 --- a/test-suite/tester-clsql.cl +++ b/test-suite/tester-clsql.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: tester-clsql.cl,v 1.5 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: tester-clsql.cl,v 1.6 2002/04/23 18:28:02 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -137,7 +137,7 @@ ;;;; Testing functions (defun transform-float-1 (i) - (* i (abs (/ i 2)) (expt 10 (* 2 i)))) + (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float)) (defun transform-bigint-1 (i) (* i (expt 10 (* 3 (abs i))))) @@ -202,13 +202,14 @@ (format nil "Invalid types field (~S) passed to test-table-row" types)))) (test (transform-float-1 int) float - :test #'= + :test #'eql :fail-info (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) - (test (parse-double str) - float - :test #'eql - :fail-info (format nil "Wrong string value ~A" str)))) + (test (parse-double str) + float + :test #'eql + :fail-info (format nil "Wrong string value ~A for double ~A (row ~S)" + float str row)))) (defun drop-test-table (db) @@ -218,12 +219,13 @@ (defun do-test () (let ((specs (read-specs))) - (mysql-low-level specs) - (mysql-table-test specs) - (pgsql-table-test specs) - (pgsql-socket-table-test specs) - (aodbc-table-test specs) - )) + (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) + ))) (do-test) -- 2.34.1 From c973096a041ffecf4f1588f38f43f177b3b97ce1 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 23 Apr 2002 21:31:51 +0000 Subject: [PATCH 07/16] r1792: *** empty log message *** --- doc/Makefile | 23 +++++++---------------- doc/catalog.debian | 4 ++++ doc/{catalog => catalog.redhat} | 0 3 files changed, 11 insertions(+), 16 deletions(-) create mode 100644 doc/catalog.debian rename doc/{catalog => catalog.redhat} (100%) diff --git a/doc/Makefile b/doc/Makefile index 0ea0a99..6942bcc 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.5 2002/04/07 09:24:22 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.6 2002/04/23 21:25:51 kevin Exp $ # # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -13,27 +13,18 @@ # as governed by the terms of the Lisp Lesser GNU Public License # (http://opensource.franz.com/preamble.html), also known as the LLGPL. +# System variable to select catalog file +SYSTEM=debian +# SYSTEM=redhat +# Nothing to configure beyond this point -# Set to DSSSL -# For RedHat 6.x -#DSSSL_HTML=/usr/lib/sgml/stylesheets/nwalsh-modular/html/docbook.dsl -#DSSL_PRINT=/usr/lib/sgml/stylesheets/nwalsh-modular/print/docbook.dsl - -# For RedHat 7.2 -DSSSL_HTML=/usr/share/sgml/docbook/dsssl-stylesheets-1.64/html/docbook.dsl -DSSSL_PRINT=/usr/share/sgml/docbook/dsssl-stylesheets-1.64/print/docbook.dsl - -# Latest version -DSSSL_HTML=/usr/share/sgml/docbook/dsssl-stylesheets-1.76/html/docbook.dsl -DSSSL_PRINT=/usr/share/sgml/docbook/dsssl-stylesheets-1.76/print/docbook.dsl +CATALOG=catalog.$(SYSTEM) -# Custom version +# Custom DSSSL's DSSSL_HTML=../dsssl/html/docbook.dsl DSSSL_PRINT=dsssl/print/docbook.dsl -# Nothing to configure beyond this point - DOCFILE_BASE_DEFAULT=clsql DOCFILE_EXT_DEFAULT=sgml diff --git a/doc/catalog.debian b/doc/catalog.debian new file mode 100644 index 0000000..404a9ef --- /dev/null +++ b/doc/catalog.debian @@ -0,0 +1,4 @@ +CATALOG /etc/sgml/docbook.cat +CATALOG /etc/sgml/docbook-dsssl.cat +CATALOG /etc/sgml/openjade.cat +DOCUMENT clsql.sgml diff --git a/doc/catalog b/doc/catalog.redhat similarity index 100% rename from doc/catalog rename to doc/catalog.redhat -- 2.34.1 From a8074fe2035d97f5178c41104dd44c839987c380 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 23 Apr 2002 21:32:25 +0000 Subject: [PATCH 08/16] r1794: Debian docbook updates --- ChangeLog | 2 ++ Makefile | 4 ++-- doc/Makefile | 12 ++++++------ 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/ChangeLog b/ChangeLog index d3e9e09..b8b7f3d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -5,6 +5,8 @@ Fix loading on Win32 * test-suite/tester-clsql.cl Fix type coercion of double-float + * doc/* + Added debian docbook catalog, made it the default 19 Apr 2002 Marc Battyani (marc.battyani@fractalconcept.com) * interface/postgresql/postgresql-api.cl: diff --git a/Makefile b/Makefile index 763758b..01d6ee9 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.13 2002/04/07 09:26:20 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.14 2002/04/23 21:32:25 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -65,7 +65,7 @@ dist: distclean tagcvs -name \*.system -or -name Makefile -or -name ChangeLog -or \ -name COPYRIGHT -or -name TODO -or -name README -or -name INSTALL \ -or -name NEWS -or -name \*.sgml -or -name COPYING\* -or -name catalog \ - | xargs unix2dos -q + | xargs unix2dos @zip -rq $(DIST_ZIP) $(DISTDIR) @rm -r $(DISTDIR) diff --git a/doc/Makefile b/doc/Makefile index 6942bcc..85a9f02 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -5,11 +5,11 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.6 2002/04/23 21:25:51 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.7 2002/04/23 21:32:25 kevin Exp $ # -# This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +# This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # -# UFFI users are granted the rights to distribute and use this software +# 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. @@ -52,7 +52,7 @@ all: html pdf ps dvi dist: html pdf -CHECK=nsgmls -s -C catalog || exit 1 +CHECK=nsgmls -s -C ${CATALOG} || exit 1 check: $(CHECK) @@ -61,13 +61,13 @@ html: html/book1.htm html/book1.htm: ${DOCFILES} $(CHECK) - ( rm -rf html ; mkdir html; cd html ; jade -t sgml -c ../catalog -d ${DSSSL_HTML} ../${DOCFILE}; cd ..) + ( rm -rf html ; mkdir html; cd html ; jade -t sgml -c ../${CATALOG} -d ${DSSSL_HTML} ../${DOCFILE}; cd ..) tex: ${TEXFILE} ${TEXFILE}: ${DOCFILES} $(CHECK) - @jade -t tex -c catalog -d ${DSSSL_PRINT} ${DOCFILE} + @jade -t tex -c ${CATALOG} -d ${DSSSL_PRINT} ${DOCFILE} pdf: ${PDFFILE} -- 2.34.1 From 3228710cd1c7c67628085f4d079d7deab3da47bc Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 24 Apr 2002 16:10:55 +0000 Subject: [PATCH 09/16] r1795: *** empty log message *** --- test-suite/tester-clsql.cl | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/test-suite/tester-clsql.cl b/test-suite/tester-clsql.cl index 1e3fd78..00c2e7e 100644 --- a/test-suite/tester-clsql.cl +++ b/test-suite/tester-clsql.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: tester-clsql.cl,v 1.6 2002/04/23 18:28:02 kevin Exp $ +;;;; $Id: tester-clsql.cl,v 1.7 2002/04/24 16:10:55 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -205,13 +205,23 @@ :test #'eql :fail-info (format nil "Wrong float value ~A for int ~A (row ~S)" float int row)) - (test (parse-double str) - float - :test #'eql - :fail-info (format nil "Wrong string value ~A for double ~A (row ~S)" - float str 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")) -- 2.34.1 From f8478421f5a0440246f70aa4234ff25f416be7e3 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 27 Apr 2002 20:58:11 +0000 Subject: [PATCH 10/16] r1798: Initial support for pooled connections --- ChangeLog | 4 + Makefile | 12 +- VERSION | 2 +- clsql.system | 5 +- doc/Makefile | 6 +- doc/ref.sgml | 265 ++++++++++++------ interfaces/mysql/mysql-sql.cl | 6 +- .../postgresql-socket-sql.cl | 18 +- interfaces/postgresql/postgresql-sql.cl | 6 +- sql/classes.cl | 6 +- sql/db-interface.cl | 10 +- sql/package.cl | 5 +- sql/pool.cl | 59 ++++ sql/sql.cl | 77 ++--- 14 files changed, 326 insertions(+), 155 deletions(-) create mode 100644 sql/pool.cl diff --git a/ChangeLog b/ChangeLog index b8b7f3d..5c9411c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Multiple files: + Added initial support for connection pool + 23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * interfaces/postgresql/postgresql-sql.cl: Fix keyword typo in database-read-large-object diff --git a/Makefile b/Makefile index 01d6ee9..131c689 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.14 2002/04/23 21:32:25 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.15 2002/04/27 20:58:11 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -17,19 +17,19 @@ PKG=clsql .PHONY: all libs clean distclean doc tagcvs dist wwwdist -SUBDIRS=interfaces/mysql interfaces/clsql-uffi -.PHONY: subdirs $(SUBDIRS) +LIBSUBDIRS=interfaces/mysql interfaces/clsql-uffi +.PHONY: subdirs $(LIBSUBDIRS) -all: $(SUBDIRS) +all: $(LIBSUBDIRS) -$(SUBDIRS): +$(LIBSUBDIRS): $(MAKE) -C $@ clean: @rm -f $(PKG)-*.tar.gz $(PKG)-*.zip @find . -type d -name .bin |xargs rm -rf @find . -type f -name "#*" -or -name \*~ -exec rm {} \; - @for i in $(SUBDIRS) ; do $(MAKE) -C $$i $@ ; done + @for i in $(LIBSUBDIRS) ; do $(MAKE) -C $$i $@ ; done distclean: clean diff --git a/VERSION b/VERSION index e83707c..671a34c 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -0.6.8 +0.7.0 diff --git a/clsql.system b/clsql.system index 41ba9f2..82e6d53 100644 --- a/clsql.system +++ b/clsql.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql.system,v 1.5 2002/04/01 05:27:55 kevin Exp $ +;;;; $Id: clsql.system,v 1.6 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -40,7 +40,8 @@ (:file "classes") (:file "conditions" :depends-on ("classes")) (:file "db-interface" :depends-on ("conditions")) - (:file "sql" :depends-on ("db-interface")) + (:file "pool" :depends-on ("db-interface")) + (:file "sql" :depends-on ("pool")) (:file "utils" :depends-on ("package")) (:file "functional" :depends-on ("sql")) (:file "usql" :depends-on ("sql"))) diff --git a/doc/Makefile b/doc/Makefile index 85a9f02..3b6f584 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.7 2002/04/23 21:32:25 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.8 2002/04/27 20:58:11 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -95,7 +95,7 @@ clean: @rm -f ${PSFILE} ${PDFFILE} ${DVIFILE} ${TEXFILE} @rm -f ${TMPFILES} -realclean: clean - @rm -f *~ +distclean: clean + @rm -f *~ .#* *.bak *.orig diff --git a/doc/ref.sgml b/doc/ref.sgml index a24ae22..89113a8 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -10,7 +10,7 @@ &clsql;. - + CLSQL-CONDITION the super-type of all @@ -22,7 +22,7 @@ Class Precedence List - maisql-condition + clsql-condition condition t @@ -37,7 +37,7 @@ initialization arguments nor any accessors. - + CLSQL-ERROR the super-type of all @@ -49,10 +49,10 @@ Class Precedence List - maisql-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -68,7 +68,7 @@ initialization arguments nor any accessors. - + CLSQL-SIMPLE-ERROR Unspecific simple @@ -79,12 +79,12 @@ Class Precedence List - maisql-simple-error + clsql-simple-error simple-condition - maisql-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -99,7 +99,7 @@ simple-condition. - + CLSQL-WARNING the super-type of all @@ -111,9 +111,9 @@ Class Precedence List - maisql-warning + clsql-warning warning - maisql-condition + clsql-condition condition t @@ -129,7 +129,7 @@ initialization arguments nor any accessors. - + CLSQL-SIMPLE-WARNING Unspecific simple @@ -140,11 +140,11 @@ Class Precedence List - maisql-simple-warning + clsql-simple-warning simple-condition - maisql-warning + clsql-warning warning - maisql-condition + clsql-condition condition t @@ -161,7 +161,7 @@ - + CLSQL-INVALID-SPEC-ERROR condition representing errors because of invalid @@ -172,11 +172,11 @@ Class Precedence List - maisql-invalid-spec-error - maisql-error + clsql-invalid-spec-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -195,24 +195,24 @@ Description :connection-spec - maisql-invalid-spec-error-connection-spec + clsql-invalid-spec-error-connection-spec The invalid connection specification used. :database-type - maisql-invalid-spec-error-database-type + clsql-invalid-spec-error-database-type The Database type used in the attempt. :template - maisql-invalid-spec-error-template + clsql-invalid-spec-error-template An argument describing the template that a valid connection specification must match for this database type. - + CLSQL-CONNECT-ERROR condition representing errors during @@ -223,11 +223,11 @@ Class Precedence List - maisql-connect-error - maisql-error + clsql-connect-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -244,32 +244,32 @@ Description :database-type - maisql-connect-error-database-type + clsql-connect-error-database-type Database type for the connection attempt :connection-spec - maisql-connect-error-connection-spec + clsql-connect-error-connection-spec The connection specification used in the connection attempt. :errno - maisql-connect-error-errno + clsql-connect-error-errno The numeric or symbolic error specification returned by the database back-end. The values and semantics of this are interface specific. :error - maisql-connect-error-error + clsql-connect-error-error A string describing the problem that occurred, possibly one returned by the database back-end. - + CLSQL-SQL-ERROR condition representing errors during query or @@ -280,11 +280,11 @@ Class Precedence List - maisql-sql-error - maisql-error + clsql-sql-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -303,32 +303,32 @@ Description :database - maisql-sql-error-database + clsql-sql-error-database The database object that was involved in the incident. :expression - maisql-sql-error-expression + clsql-sql-error-expression The SQL expression whose execution caused the error. :errno - maisql-sql-error-errno + clsql-sql-error-errno The numeric or symbolic error specification returned by the database back-end. The values and semantics of this are interface specific. :error - maisql-sql-error-error + clsql-sql-error-error A string describing the problem that occurred, possibly one returned by the database back-end. - + CLSQL-EXISTS-CONDITION condition indicating situations arising because of @@ -339,8 +339,8 @@ Class Precedence List - maisql-exists-condition - maisql-condition + clsql-exists-condition + clsql-condition condition t @@ -356,13 +356,13 @@ connect, either a warning, an error or no condition at all is signalled. If a warning or error is signalled, either - maisql-exists-warning or - maisql-exists-error is signalled, + clsql-exists-warning or + clsql-exists-error is signalled, which are subtypes of - maisql-exists-condition and - maisql-warning or - maisql-error. - maisql-exists-condition is never + clsql-exists-condition and + clsql-warning or + clsql-error. + clsql-exists-condition is never signalled itself. The following initialization arguments and accessors exist: @@ -372,13 +372,13 @@ Description :old-db - maisql-exists-condition-old-db + clsql-exists-condition-old-db The database object that represents the existing connection. This slot is always filled. :new-db - maisql-exists-condition-new-db + clsql-exists-condition-new-db The database object that will be used and returned by this call to connect, if execution continues normally. This can be either nil, indicating that @@ -392,7 +392,7 @@ - + CLSQL-EXISTS-WARNING condition representing warnings arising because of @@ -403,11 +403,11 @@ Class Precedence List - maisql-exists-warning - maisql-exists-condition - maisql-warning + clsql-exists-warning + clsql-exists-condition + clsql-warning warning - maisql-condition + clsql-condition condition t @@ -416,7 +416,7 @@ Description This condition is a subtype of - maisql-exists-condition, and is + clsql-exists-condition, and is signalled during calls to connect when there is an existing connection, and if-exists is either @@ -426,10 +426,10 @@ the existing old database object. The initialization arguments and accessors are the same as - for maisql-exists-condition. + for clsql-exists-condition. - + CLSQL-EXISTS-ERROR condition representing errors arising because of @@ -440,12 +440,12 @@ Class Precedence List - maisql-exists-error - maisql-exists-condition - maisql-error + clsql-exists-error + clsql-exists-condition + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -454,7 +454,7 @@ Description This condition is a subtype of - maisql-exists-condition, and is + clsql-exists-condition, and is signalled during calls to connect when there is an existing connection, and if-exists is :error. @@ -464,10 +464,10 @@ action in continuing from this correctable error. The initialization arguments and accessors are the same as - for maisql-exists-condition. + for clsql-exists-condition. - + CLSQL-CLOSED-ERROR condition representing errors because the database @@ -478,11 +478,11 @@ Class Precedence List - maisql-closed-error - maisql-error + clsql-closed-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -507,7 +507,7 @@ Description :database - maisql-closed-error-database + clsql-closed-error-database The database object that was involved in the incident. @@ -674,7 +674,7 @@ already present. If initialization fails, the function returns nil, and/or signals an error of type - maisql-error. The kind of action + clsql-error. The kind of action taken depends on the back-end and the cause of the problem. @@ -724,7 +724,7 @@ Exceptional Situations If an error is encountered during the initialization attempt, the back-end may signal errors of kind - maisql-error. + clsql-error. See Also @@ -1036,7 +1036,7 @@ disconnect. All functions and generic functions that take database objects as arguments will signal errors of type - maisql-closed-error when they are + clsql-closed-error when they are called on instances of closed-database, with the exception of database-name, which will continue to work as for instances of @@ -1208,7 +1208,7 @@ database. If it succeeds, it returns the first database found. If it fails to find a matching database, it will signal - an error of type maisql-error if + an error of type clsql-error if errorp is true. If errorp is nil, it will return nil instead. @@ -1258,7 +1258,7 @@ Exceptional Situations Will signal an error of type - maisql-error if no matching database + clsql-error if no matching database can be found, and errorp is true. Will signal an error if the value of database is neither an object of type @@ -1280,6 +1280,7 @@ None. + CONNECT @@ -1288,7 +1289,7 @@ Syntax - connect connection-spec &key if-exists database-type => database + connect connection-spec &key if-exists database-type pool => database Arguments and Values @@ -1316,6 +1317,14 @@ *default-database-type* + + pool + + A boolean flag. If &t;, acquire connection from a + pool of open connections. If the pool is empty, a new + connection is created. The default is &nil;. + + database @@ -1350,7 +1359,7 @@ This is just like :new, but also signals a warning of type - maisql-exists-warning, + clsql-exists-warning, indicating the old and newly created databases. @@ -1360,7 +1369,7 @@ This will cause connect to signal a correctable error of type - maisql-exists-error. The + clsql-exists-error. The user may choose to proceed, either by indicating that a new connection shall be created, via the restart create-new, or by @@ -1381,7 +1390,7 @@ This is just like :old, but also signals a warning of type - maisql-exists-warning, + clsql-exists-warning, indicating the old database used, via the slots old-db and new-db @@ -1448,11 +1457,11 @@ Exceptional Situations If the connection specification is not syntactically or semantically correct for the given database type, an error - of type maisql-invalid-spec-error is + of type clsql-invalid-spec-error is signalled. If during the connection attempt an error is detected (e.g. because of permission problems, network trouble or any other cause), an error of type - maisql-connect-error is + clsql-connect-error is signalled. If a connection to the database specified by connection-spec exists already, @@ -1474,6 +1483,7 @@ None. + DISCONNECT @@ -1482,11 +1492,21 @@ Syntax - disconnect &key database => t + disconnect &key database pool => t Arguments and Values + + pool + + A boolean flag indicating whether to put the database into a +pool of opened databases. If &t;, rather than terminating the database connection, the +connection is left open and the connection is placed into a pool of connections. Subsequent +calls to connect can then reuse this connection. +The default is &nil;. + + database @@ -1508,7 +1528,7 @@ with the exception of database-name. If the user does pass a closed database object to any other &clsql; function, an error of type - maisql-closed-error is + clsql-closed-error is signalled. @@ -1545,7 +1565,65 @@ Exceptional Situations If during the disconnection attempt an error is detected (e.g. because of network trouble or any other - cause), an error of type maisql-error + cause), an error of type clsql-error + might be signalled. + + + See Also + + + connect + closed-database + + + + + Notes + None. + + + + + + DISCONNECT-POOLED + closes all pooled database connections + Function + + + Syntax + disconnect-pool => t + + + Description + This function disconnects all database connections + that have been placed into the pool. Connections are placed + in the pool by calling + disconnection. + + + Examples + +(disconnect-pool) +=> T + + + + Side Effects + Database connections will be closed and entries in the pool are removed. + + + Affected by + + + disconnect + + + + + Exceptional Situations + If during the disconnection attempt an error is + detected (e.g. because of network trouble or any other + cause), an error of type clsql-error might be signalled. @@ -1562,6 +1640,7 @@ None. + DATABASE-NAME-FROM-SPEC @@ -1654,7 +1733,7 @@ If the value of connection-spec is not a valid connection specification for the given database type, an error of type - maisql-invalid-spec-error might be + clsql-invalid-spec-error might be signalled. @@ -1710,7 +1789,7 @@ sql-expression in the database specified. If the execution succeeds it will return t, otherwise an - error of type maisql-sql-error will + error of type clsql-sql-error will be signalled. @@ -1756,7 +1835,7 @@ Exceptional Situations If the execution of the SQL statement leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. See Also @@ -1863,7 +1942,7 @@ database specified. If the execution succeeds it will return the result set returned by the database, otherwise an error of type - maisql-sql-error will + clsql-sql-error will be signalled. @@ -1906,7 +1985,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. See Also @@ -2067,7 +2146,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. An error of type type-error must be signaled if the output-type-spec is not a recognizable subtype of list, not a @@ -2201,7 +2280,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. If the number of variable names in args and the number of attributes in the tuples in the result set don't match up, an error is @@ -2338,7 +2417,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. Otherwise, any of the exceptional situations of loop applies. @@ -2416,7 +2495,7 @@ initialization by returning t from their method, and nil otherwise. Methods for this generic function are allowed to signal errors of type - maisql-error or subtypes thereof. + clsql-error or subtypes thereof. They may also signal other types of conditions, if appropriate, but have to document this. @@ -2435,7 +2514,7 @@ Exceptional Situations - Conditions of type maisql-error + Conditions of type clsql-error or other conditions may be signalled, depending on the database back-end. diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl index b88e054..264c71b 100644 --- a/interfaces/mysql/mysql-sql.cl +++ b/interfaces/mysql/mysql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: mysql-sql.cl,v 1.18 2002/03/30 05:07:02 kevin Exp $ +;;;; $Id: mysql-sql.cl,v 1.19 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -90,6 +90,9 @@ ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr :type mysql-mysql-ptr-def))) +(defmethod database-type ((database mysql-database)) + :mysql) + (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql))) (check-connection-spec connection-spec database-type (host db user password)) (destructuring-bind (host db user password) connection-spec @@ -129,6 +132,7 @@ (make-instance 'mysql-database :name (database-name-from-spec connection-spec database-type) + :connection-spec connection-spec :mysql-ptr mysql-ptr)) (when error-occurred (mysql-close mysql-ptr))))))))) diff --git a/interfaces/postgresql-socket/postgresql-socket-sql.cl b/interfaces/postgresql-socket/postgresql-socket-sql.cl index 3a0d491..777a095 100644 --- a/interfaces/postgresql-socket/postgresql-socket-sql.cl +++ b/interfaces/postgresql-socket/postgresql-socket-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-socket-sql.cl,v 1.10 2002/03/29 09:37:24 kevin Exp $ +;;;; $Id: postgresql-socket-sql.cl,v 1.11 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -137,16 +137,19 @@ doesn't depend on UFFI." ;; KMR - removed double @@ ,@body)))) -(defmethod database-initialize-database-type - ((database-type (eql :postgresql-socket))) +(defmethod database-initialize-database-type ((database-type + (eql :postgresql-socket))) t) (defclass postgresql-socket-database (database) ((connection :accessor database-connection :initarg :connection :type postgresql-connection))) -(defmethod database-name-from-spec - (connection-spec (database-type (eql :postgresql-socket))) +(defmethod database-type ((database postgresql-socket-database)) + :postgresql-socket) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :postgresql-socket))) (check-connection-spec connection-spec database-type (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional port options tty) @@ -154,8 +157,8 @@ doesn't depend on UFFI." (declare (ignore password options tty)) (concatenate 'string host (if port ":") (if port port) "/" db "/" user))) -(defmethod database-connect - (connection-spec (database-type (eql :postgresql-socket))) +(defmethod database-connect (connection-spec + (database-type (eql :postgresql-socket))) (check-connection-spec connection-spec database-type (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional @@ -178,6 +181,7 @@ doesn't depend on UFFI." (make-instance 'postgresql-socket-database :name (database-name-from-spec connection-spec database-type) + :connection-spec connection-spec :connection connection)) (postgresql-error (c) ;; Connect failed diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index 4104afa..809507c 100644 --- a/interfaces/postgresql/postgresql-sql.cl +++ b/interfaces/postgresql/postgresql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-sql.cl,v 1.14 2002/04/23 18:28:02 kevin Exp $ +;;;; $Id: postgresql-sql.cl,v 1.15 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -87,6 +87,9 @@ ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr :type pgsql-conn-def))) +(defmethod database-type ((database postgresql-database)) + :postgresql) + (defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql))) (check-connection-spec connection-spec database-type @@ -125,6 +128,7 @@ (make-instance 'postgresql-database :name (database-name-from-spec connection-spec database-type) + :connection-spec connection-spec :conn-ptr connection))))) diff --git a/sql/classes.cl b/sql/classes.cl index 8ba8c26..7a3f336 100644 --- a/sql/classes.cl +++ b/sql/classes.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: classes.cl,v 1.1 2002/03/29 08:13:02 kevin Exp $ +;;;; $Id: classes.cl,v 1.2 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -23,7 +23,9 @@ (defclass database () - ((name :initarg :name :reader database-name)) + ((name :initarg :name :reader database-name) + (connection-spec :initarg :connection-spec :reader connection-spec + :documentation "Require to use connection pool")) (:documentation "This class is the supertype of all databases handled by CLSQL.")) diff --git a/sql/db-interface.cl b/sql/db-interface.cl index 1ce8681..b2dd41e 100644 --- a/sql/db-interface.cl +++ b/sql/db-interface.cl @@ -9,7 +9,7 @@ ;;;; onShoreD to support UncommonSQL front-end ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: db-interface.cl,v 1.6 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: db-interface.cl,v 1.7 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai, and onShoreD @@ -31,6 +31,14 @@ "The internal generic implementation for checking if database type library loaded successfully.")) +(defgeneric database-type (database-type) + (:documentation + "Returns database type") + (:method (database-type) + (declare (ignore database-type)) + (signal-nodb-error database))) + + (defgeneric database-initialize-database-type (database-type) (:documentation "The internal generic implementation of initialize-database-type.")) diff --git a/sql/package.cl b/sql/package.cl index 2db3c44..3624819 100644 --- a/sql/package.cl +++ b/sql/package.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: package.cl,v 1.7 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: package.cl,v 1.8 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -58,6 +58,9 @@ #:database-read-large-object #:database-delete-large-object + ;; Pooled connections + #:disconnect-pooled + ;; Shared exports for re-export by CLSQL . #1=(#:clsql-condition diff --git a/sql/pool.cl b/sql/pool.cl new file mode 100644 index 0000000..298f1e3 --- /dev/null +++ b/sql/pool.cl @@ -0,0 +1,59 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pool.cl +;;;; Purpose: Support function for connection pool +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: pool.cl,v 1.1 2002/04/27 20:58:11 kevin Exp $ +;;;; +;;;; 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +(defvar *db-pool* (make-hash-table :test #'equal)) + +(defun make-conn-vector () + "Creates an empty connection vector" + (make-array 5 :fill-pointer 0 :adjustable t)) + +(defun find-or-create-conn-vector (connection-spec database-type) + "Find connection vector in hash table, creates a new conn-vector if not found" + (let* ((key (list connection-spec database-type)) + (conn-vector (gethash *db-pool* key))) + (unless conn-vector + (setq conn-vector (make-conn-vector)) + (setf (gethash *db-pool* key) conn-vector)) + conn-vector)) + +(defun acquire-from-pool (connection-spec database-type) + (let ((conn-vector (find-or-create-conn-vector connection-spec database-type))) + (when (zerop (length conn-vector)) + (vector-push-extend + (connect connection-spec :database-type database-type :if-exists :new) + conn-vector)) + (vector-pop conn-vector))) + +(defun release-to-pool (database) + (let ((conn-vector (find-or-create-conn-vector (connection-spec database) + (database-type database)))) + (vector-push-extend database conn-vector))) + +(defun disconnect-pooled () + "Disconnects all connections in the pool" + (maphash + #'(lambda (key conn-vector) + (declare (ignore key)) + (dotimes (i (length conn-vector)) + (disconnect (aref conn-vector i))) + (setf (fill-pointer conn-vector) 0)) + *db-pool*) + t) diff --git a/sql/sql.cl b/sql/sql.cl index 4b88fd5..f5eebd7 100644 --- a/sql/sql.cl +++ b/sql/sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: sql.cl,v 1.12 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: sql.cl,v 1.13 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -95,56 +95,59 @@ initialized, as indicated by `*initialized-database-types*'." (defun connect (connection-spec &key (if-exists *connect-if-exists*) - (database-type *default-database-type*)) + (database-type *default-database-type*) + (pool nil)) "Connects to a database of the given database-type, using the type-specific connection-spec. if-exists is currently ignored." (let* ((db-name (database-name-from-spec connection-spec database-type)) (old-db (find-database db-name nil)) (result nil)) - (if old-db - (case if-exists - (:new - (setq result - (database-connect connection-spec database-type))) - (:warn-new - (setq result - (database-connect connection-spec database-type)) - (warn 'clsql-exists-warning :old-db old-db :new-db result)) - (:error - (restart-case - (error 'clsql-exists-error :old-db old-db) - (create-new () - :report "Create a new connection." - (setq result - (database-connect connection-spec database-type))) - (use-old () - :report "Use the existing connection." - (setq result old-db)))) - (:warn-old - (setq result old-db) - (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) - (:old - (setq result old-db))) + (if pool + (setq result (acquire-from-pool connection-spec database-type)) + (if old-db + (case if-exists + (:new + (setq result + (database-connect connection-spec database-type))) + (:warn-new + (setq result + (database-connect connection-spec database-type)) + (warn 'clsql-exists-warning :old-db old-db :new-db result)) + (:error + (restart-case + (error 'clsql-exists-error :old-db old-db) + (create-new () + :report "Create a new connection." + (setq result + (database-connect connection-spec database-type))) + (use-old () + :report "Use the existing connection." + (setq result old-db)))) + (:warn-old + (setq result old-db) + (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) + (:old + (setq result old-db))) (setq result - (database-connect connection-spec database-type))) + (database-connect connection-spec database-type)))) (when result (pushnew result *connected-databases*) (setq *default-database* result) result))) - -(defun disconnect (&key (database *default-database*)) +(defun disconnect (&key (database *default-database*) + (pool nil)) "Closes the connection to database. Resets *default-database* if that database was disconnected and only one other connection exists." - (when (database-disconnect database) - (setq *connected-databases* (delete database *connected-databases*)) - (when (eq database *default-database*) - (setq *default-database* (car *connected-databases*))) - (change-class database 'closed-database) - t)) - - + (if pool + (release-to-pool database) + (when (database-disconnect database) + (setq *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setq *default-database* (car *connected-databases*))) + (change-class database 'closed-database) + t))) ;;; Basic operations on databases -- 2.34.1 From 6ba23404433eaf240f37e2905aed999a4d4bf342 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 27 Apr 2002 21:12:32 +0000 Subject: [PATCH 11/16] r1799: added transaction support --- interfaces/mysql/mysql-usql.cl | 216 ++++++++++++++++++--------------- 1 file changed, 117 insertions(+), 99 deletions(-) diff --git a/interfaces/mysql/mysql-usql.cl b/interfaces/mysql/mysql-usql.cl index 10413a6..ea2b12e 100644 --- a/interfaces/mysql/mysql-usql.cl +++ b/interfaces/mysql/mysql-usql.cl @@ -1,99 +1,117 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: mysql-usql.cl -;;;; Purpose: MySQL interface functions to support UncommonSQL -;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc -;;;; Date Started: Mar 2002 -;;;; -;;;; $Id: mysql-usql.cl,v 1.3 2002/04/07 15:11:04 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and by 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-mysql) - -(defmethod database-list-tables ((database mysql-database) - &key (system-tables nil)) - (declare (ignore system-tables)) - (mapcar #'car (database-query "show tables" database :auto))) - - - -(defmethod database-list-attributes ((table string) (database mysql-database)) - (mapcar #'car - (database-query - (format nil "SHOW COLUMNS FROM ~A" table) - database nil))) - -(defmethod database-attribute-type (attribute (table string) - (database mysql-database)) - (let ((result - (mapcar #'cadr - (database-query - (format nil - "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) - database nil)))) - (let* ((str (car result)) - (end-str (position #\( str)) - (substr (subseq str 0 end-str))) - (if substr - (intern (string-upcase substr) :keyword) nil)))) - - -(defun %sequence-name-to-table (sequence-name) - (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) - -(defmethod database-create-sequence (sequence-name - (database mysql-database)) - (let ((table-name (%sequence-name-to-table sequence-name))) - (database-execute-command - (concatenate 'string "CREATE TABLE " table-name - " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") - database) - (database-execute-command - (concatenate 'string "INSERT INTO " table-name - " VALUES (0)") - database))) - -(defmethod database-drop-sequence (sequence-name - (database mysql-database)) - (database-execute-command - (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) - database)) - -(defmethod database-sequence-next (sequence-name (database mysql-database)) - (database-execute-command - (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) - " SET id=LAST_INSERT_ID(id+1)") - database) - (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) - -#+ignore -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database mysql-database)) - (with-slots (clsql-sys::modifier clsql-sys::components) - expr - (if clsql-sys::modifier - (progn - (clsql-sys::output-sql clsql-sys::components database) - (write-char #\: sql-sys::*sql-stream*) - (write-char #\: sql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -#+ignore -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database mysql-database)) - ;; typecast it so it uses the indexes - (when val - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql-usql.cl +;;;; Purpose: MySQL interface functions to support UncommonSQL +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: mysql-usql.cl,v 1.4 2002/04/27 21:12:32 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-mysql) + +;; Table and attribute introspection + +(defmethod database-list-tables ((database mysql-database) + &key (system-tables nil)) + (declare (ignore system-tables)) + (mapcar #'car (database-query "show tables" database :auto))) + + +(defmethod database-list-attributes ((table string) (database mysql-database)) + (mapcar #'car + (database-query + (format nil "SHOW COLUMNS FROM ~A" table) + database nil))) + +(defmethod database-attribute-type (attribute (table string) + (database mysql-database)) + (let ((result + (mapcar #'cadr + (database-query + (format nil + "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) + database nil)))) + (let* ((str (car result)) + (end-str (position #\( str)) + (substr (subseq str 0 end-str))) + (if substr + (intern (string-upcase substr) :keyword) nil)))) + +;;; Sequence functions + +(defun %sequence-name-to-table (sequence-name) + (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) + +(defmethod database-create-sequence (sequence-name + (database mysql-database)) + (let ((table-name (%sequence-name-to-table sequence-name))) + (database-execute-command + (concatenate 'string "CREATE TABLE " table-name + " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)") + database) + (database-execute-command + (concatenate 'string "INSERT INTO " table-name + " VALUES (0)") + database))) + +(defmethod database-drop-sequence (sequence-name + (database mysql-database)) + (database-execute-command + (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) + database)) + +(defmethod database-sequence-next (sequence-name (database mysql-database)) + (database-execute-command + (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) + " SET id=LAST_INSERT_ID(id+1)") + database) + (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) + +;; Transactions + +(defmethod database-start-transaction ((database mysql-database)) + "Start a transaction in DATABASE." + (database-execute-command "BEGIN" database)) + +(defmethod database-commit-transaction ((database mysql-database)) + "Commit current transaction in DATABASE." + (database-execute-command "COMMIT" database)) + +(defmethod database-abort-transaction ((database mysql-database)) + "Abort current transaction in DATABASE." + (database-execute-command "ROLLBACK" database)) + +;; Misc USQL functions + +#+ignore +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database mysql-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: sql-sys::*sql-stream*) + (write-char #\: sql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +#+ignore +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database mysql-database)) + ;; typecast it so it uses the indexes + (when val + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) -- 2.34.1 From 70bb533caf487a64e186513583954681abf64f33 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 27 Apr 2002 21:13:05 +0000 Subject: [PATCH 12/16] r1800: transaction update --- ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ChangeLog b/ChangeLog index 5c9411c..514d644 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,7 @@ -23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) +27 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * Multiple files: Added initial support for connection pool + Added transactions for MySQL 23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * interfaces/postgresql/postgresql-sql.cl: -- 2.34.1 From d302d2db4f7ff7a31bce893e31aecbc2a84a162f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 27 Apr 2002 21:48:08 +0000 Subject: [PATCH 13/16] r1801: Added transaction code --- ChangeLog | 5 +- clsql.system | 3 +- interfaces/mysql/mysql-usql.cl | 16 +---- sql/classes.cl | 12 ++-- sql/package.cl | 14 ++-- sql/transactions.cl | 123 +++++++++++++++++++++++++++++++++ 6 files changed, 147 insertions(+), 26 deletions(-) create mode 100644 sql/transactions.cl diff --git a/ChangeLog b/ChangeLog index 514d644..fb92c48 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,10 @@ 27 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * Multiple files: Added initial support for connection pool - Added transactions for MySQL + * sql/transactions.cl + Took transaction code from UncommonSQL and integrated + into CLSQL code. See file for disclaimer about why this + was added. 23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * interfaces/postgresql/postgresql-sql.cl: diff --git a/clsql.system b/clsql.system index 82e6d53..9cc76b7 100644 --- a/clsql.system +++ b/clsql.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql.system,v 1.6 2002/04/27 20:58:11 kevin Exp $ +;;;; $Id: clsql.system,v 1.7 2002/04/27 21:48:08 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -42,6 +42,7 @@ (:file "db-interface" :depends-on ("conditions")) (:file "pool" :depends-on ("db-interface")) (:file "sql" :depends-on ("pool")) + (:file "transactions" :depends-on ("sql")) (:file "utils" :depends-on ("package")) (:file "functional" :depends-on ("sql")) (:file "usql" :depends-on ("sql"))) diff --git a/interfaces/mysql/mysql-usql.cl b/interfaces/mysql/mysql-usql.cl index ea2b12e..59a23b4 100644 --- a/interfaces/mysql/mysql-usql.cl +++ b/interfaces/mysql/mysql-usql.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: mysql-usql.cl,v 1.4 2002/04/27 21:12:32 kevin Exp $ +;;;; $Id: mysql-usql.cl,v 1.5 2002/04/27 21:48:08 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and by onShore Development Inc. @@ -78,20 +78,6 @@ database) (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) -;; Transactions - -(defmethod database-start-transaction ((database mysql-database)) - "Start a transaction in DATABASE." - (database-execute-command "BEGIN" database)) - -(defmethod database-commit-transaction ((database mysql-database)) - "Commit current transaction in DATABASE." - (database-execute-command "COMMIT" database)) - -(defmethod database-abort-transaction ((database mysql-database)) - "Abort current transaction in DATABASE." - (database-execute-command "ROLLBACK" database)) - ;; Misc USQL functions #+ignore diff --git a/sql/classes.cl b/sql/classes.cl index 7a3f336..72e44c7 100644 --- a/sql/classes.cl +++ b/sql/classes.cl @@ -5,10 +5,10 @@ ;;;; Name: classes.cl ;;;; Purpose: Classes for High-level SQL interface ;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai +;;;; original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: classes.cl,v 1.2 2002/04/27 20:58:11 kevin Exp $ +;;;; $Id: classes.cl,v 1.3 2002/04/27 21:48:08 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -25,7 +25,9 @@ (defclass database () ((name :initarg :name :reader database-name) (connection-spec :initarg :connection-spec :reader connection-spec - :documentation "Require to use connection pool")) + :documentation "Require to use connection pool") + (transaction-level :accessor transaction-level)) + (:default-initargs :name nil :connection-spec nil :transaction-level 0) (:documentation "This class is the supertype of all databases handled by CLSQL.")) @@ -36,12 +38,12 @@ "") stream))) +;; Closed database idea and original code comes from UncommonSQL (defclass closed-database () ((name :initarg :name :reader database-name)) (:documentation - "This class represents all databases after they are closed via -`disconnect'.")) + "This class represents databases after they are closed via 'disconnect'.")) (defmethod print-object ((object closed-database) stream) (print-unreadable-object (object stream :type t :identity t) diff --git a/sql/package.cl b/sql/package.cl index 3624819..e5097ae 100644 --- a/sql/package.cl +++ b/sql/package.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: package.cl,v 1.8 2002/04/27 20:58:11 kevin Exp $ +;;;; $Id: package.cl,v 1.9 2002/04/27 21:48:08 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -58,9 +58,6 @@ #:database-read-large-object #:database-delete-large-object - ;; Pooled connections - #:disconnect-pooled - ;; Shared exports for re-export by CLSQL . #1=(#:clsql-condition @@ -132,7 +129,16 @@ #:create-sequence #:drop-sequence #:sequence-next + #:transaction-start + #:transaction-commit + #:transaction-abort + ;; Pooled connections + #:disconnect-pooled + + ;; Transactions + #:with-transaction + ;; Large objects (Marc B) #:create-large-object #:write-large-object diff --git a/sql/transactions.cl b/sql/transactions.cl new file mode 100644 index 0000000..19066c2 --- /dev/null +++ b/sql/transactions.cl @@ -0,0 +1,123 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: transactions.cl +;;;; Purpose: Transaction support +;;;; Programmers: Kevin M. Rosenberg based +;;;; Original code by onShore Development Inc. +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: transactions.cl,v 1.1 2002/04/27 21:48:08 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 2000-2002 by onShore Development +;;;; +;;;; 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. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :clsql-sys) + +;; This code is copied verbatim from UncommonSQL. It is intended to +;; provide transaction support to CLSQL users that, for whatever reason, +;; don't want to use the upcoming UncommonSQL/CLSQL combination. + +(defmethod database-start-transaction ((database closed-database)) + (signal-closed-database-error database)) + +(defmethod database-start-transaction (database) + (unless database + (error 'clsql-nodb-error)) + (with-accessors ((level transaction-level)) + database + (incf level) + (when (= level 1) + (execute-command "BEGIN" :database database)))) + +(defmethod database-commit-transaction ((database closed-database)) + (signal-closed-database-error database)) + +(defmethod database-commit-transaction (database) + (with-accessors ((level transaction-level)) + database + (if (< 0 level) + (progn + (decf level) + (when (= level 0) + (execute-command "COMMIT" :database database))) + (warn "Continue without commit." + 'clsql-simple-error + :format-control "Cannot commit transaction against ~A because there is no transaction in progress." + :format-arguments (list database))))) + +(defmethod database-abort-transaction ((database closed-database)) + (signal-closed-database-error database)) + +(defmethod database-abort-transaction (database) + (with-accessors ((level transaction-level)) + database + (if (< 0 level) + (progn + (setf level 0) + (execute-command "ROLLBACK" :database database)) + (warn "Continue without abort." + 'clsql-simple-error + :format-control "Cannot abort transaction against ~A because there is no transaction in progress." + :format-arguments (list database))))) + +(defvar *transaction-level* 0) +(defvar *transaction-id* nil) + +(defvar *transaction-aborts* (make-hash-table)) +(defvar *transaction-completes* (make-hash-table)) + +(defun on-txn-abort (fn) + (push (cons *transaction-level* fn) (gethash *transaction-id* *transaction-aborts*))) + +(defun on-txn-complete (fn) + (if (> *transaction-level* 0) + (push fn (gethash *transaction-id* *transaction-completes*)) + (warn "Cannot define on-txn-complete actions outside of transactions."))) + +(defun run-abort-hooks () + (let ((remainder (remove-if (lambda (hook) + (< (car hook) *transaction-level*)) + (gethash *transaction-id* *transaction-aborts*)))) + (mapcar #'(lambda (hook) + (funcall (cdr hook))) + (gethash *transaction-id* *transaction-aborts*)) + (setf (gethash *transaction-id* *transaction-aborts*) remainder))) + + +(defmacro with-transaction ((&key database) + &rest body) + (let ((dbsym (gensym "db")) + (transym (gensym "tran"))) + `(let ((,dbsym (or ,database *default-database*)) + (,transym nil) + (*transaction-id* (or *transaction-id* + (gensym "txn"))) + (*transaction-level* (1+ *transaction-level*))) + (unwind-protect + (progn + (database-start-transaction ,dbsym) + (setf ,transym t) + ,@body + (database-commit-transaction ,dbsym) + (setf ,transym nil)) + (if ,transym + (progn ; was aborted + (database-abort-transaction ,dbsym) + ;; (format t "~&;; Transaction Abort, level ~d~%" *transaction-level*) + (run-abort-hooks) + (when (= 1 *transaction-level*) + (remhash *transaction-id* *transaction-aborts*))) + (when (= 1 *transaction-level*) + (let ((completes (gethash *transaction-id* *transaction-completes*))) + ;; (format t "~&;; Running ~d post actions.~%" (length completes)) + (mapcar #'funcall completes) + (remhash *transaction-id* *transaction-completes*)))))))) + -- 2.34.1 From b92e0259d32da34329245e9ed96f31dc52d04d8b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 28 Apr 2002 00:50:17 +0000 Subject: [PATCH 14/16] r1802: fix typos with pooled connections --- sql/classes.cl | 4 ++-- sql/package.cl | 5 ++++- sql/pool.cl | 6 +++--- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/sql/classes.cl b/sql/classes.cl index 72e44c7..0a195a8 100644 --- a/sql/classes.cl +++ b/sql/classes.cl @@ -8,7 +8,7 @@ ;;;; original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: classes.cl,v 1.3 2002/04/27 21:48:08 kevin Exp $ +;;;; $Id: classes.cl,v 1.4 2002/04/28 00:50:17 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -26,7 +26,7 @@ ((name :initarg :name :reader database-name) (connection-spec :initarg :connection-spec :reader connection-spec :documentation "Require to use connection pool") - (transaction-level :accessor transaction-level)) + (transaction-level :initarg :transaction-level :accessor transaction-level)) (:default-initargs :name nil :connection-spec nil :transaction-level 0) (:documentation "This class is the supertype of all databases handled by CLSQL.")) diff --git a/sql/package.cl b/sql/package.cl index e5097ae..166e42a 100644 --- a/sql/package.cl +++ b/sql/package.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: package.cl,v 1.9 2002/04/27 21:48:08 kevin Exp $ +;;;; $Id: package.cl,v 1.10 2002/04/28 00:50:17 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -51,6 +51,9 @@ #:database-sequence-next #:sql-escape + + ;; Support for pooled connections + #:database-type ;; Large objects (Marc B) #:database-create-large-object diff --git a/sql/pool.cl b/sql/pool.cl index 298f1e3..14efa23 100644 --- a/sql/pool.cl +++ b/sql/pool.cl @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: Apr 2002 ;;;; -;;;; $Id: pool.cl,v 1.1 2002/04/27 20:58:11 kevin Exp $ +;;;; $Id: pool.cl,v 1.2 2002/04/28 00:50:17 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -28,10 +28,10 @@ (defun find-or-create-conn-vector (connection-spec database-type) "Find connection vector in hash table, creates a new conn-vector if not found" (let* ((key (list connection-spec database-type)) - (conn-vector (gethash *db-pool* key))) + (conn-vector (gethash key *db-pool*))) (unless conn-vector (setq conn-vector (make-conn-vector)) - (setf (gethash *db-pool* key) conn-vector)) + (setf (gethash key *db-pool*) conn-vector)) conn-vector)) (defun acquire-from-pool (connection-spec database-type) -- 2.34.1 From d615b6b735d50870d9e9437801e94e2c169595aa Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 28 Apr 2002 10:51:12 +0000 Subject: [PATCH 15/16] r1825: *** empty log message *** --- debian/.cvsignore | 4 ++ debian/README.Debian | 9 ++++ debian/changelog | 6 +++ debian/cl-sql.doc-base | 15 ++++++ debian/control | 13 +++++ debian/copyright | 22 +++++++++ debian/docs | 3 ++ debian/postinst | 53 ++++++++++++++++++++ debian/prerm | 43 ++++++++++++++++ debian/rules | 109 +++++++++++++++++++++++++++++++++++++++++ debian/watch | 5 ++ make-dist.sh | 66 +++++++++++++++++++++++++ 12 files changed, 348 insertions(+) create mode 100644 debian/.cvsignore create mode 100644 debian/README.Debian create mode 100644 debian/changelog create mode 100644 debian/cl-sql.doc-base create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/docs create mode 100644 debian/postinst create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100644 debian/watch create mode 100755 make-dist.sh diff --git a/debian/.cvsignore b/debian/.cvsignore new file mode 100644 index 0000000..3cca6d1 --- /dev/null +++ b/debian/.cvsignore @@ -0,0 +1,4 @@ +cl-sql +files +cl-sql.prerm.debhelper +cl-sql.postinst.debhelper diff --git a/debian/README.Debian b/debian/README.Debian new file mode 100644 index 0000000..b995a3b --- /dev/null +++ b/debian/README.Debian @@ -0,0 +1,9 @@ +The Debian Package CL-SQL +-------------------------- + +This is the CLSQL Common Lisp system packaged for Debian. + +Anonymous CVS for this code is available at: +:pserver:anoncvs@cvs.med-info.com:/pubcvs clsql + +Kevin Rosenberg , Thu, 25 Apr 2002 19:13:41 -0600 diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..183240c --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-sql (0.7.0-1) unstable; urgency=low + + * Initial Release. + + -- Kevin Rosenberg Thu, 25 Apr 2002 19:13:41 -0600 + diff --git a/debian/cl-sql.doc-base b/debian/cl-sql.doc-base new file mode 100644 index 0000000..4034263 --- /dev/null +++ b/debian/cl-sql.doc-base @@ -0,0 +1,15 @@ +Document: cl-sql +Title: CLSQL Manual +Author: Kevin M. Rosenberg +Abstract: Describes the + use the CLSQL Common Lisp library. +Section: lisp + +Format: postscript +Files: /usr/share/doc/cl-sql/cl-sql.ps.gz + +Format: HTML +Index: /usr/share/doc/cl-sql/html/index.html +Files: /usr/share/doc/cl-sql/html/*.html + + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..2f84810 --- /dev/null +++ b/debian/control @@ -0,0 +1,13 @@ +Source: cl-uffi +Section: devel +Priority: optional +Maintainer: Kevin Rosenberg +Build-Depends-Indep: debhelper (>> 3.0.0) +Standards-Version: 3.5.2 + +Package: cl-uffi +Architecture: all +Depends: common-lisp-controller, cmucl | lisp-compiler +Description: Universal Foreign Function Library for Common Lisp + UFFI provides a universal foreign function interface (FFI) for Common Lisp. + UFFI supports CMUCL, Lispworks, and AllegroCL. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..3a08824 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,22 @@ +The home site for UFFI is http://uffi.med-info.com. The package +may be downloaded from that site. + +UFFI has been packaged by Kevin M. Rosenberg who is also the +upstream author. + +Copyright: + +UFFI is written and Copyright (c) 2002 by Kevin M. Rosenberg. + +UFFI is licensed under the terms of the Lisp Lesser GNU +Public License (http://opensource.franz.com/preamble.html), known as +the LLGPL. The LLGPL consists of a preamble (see above URL) and the +LGPL. Where these conflict, the preamble takes precedence. +UFFI is referenced in the preamble as the "LIBRARY." + +UFFI 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. + + + diff --git a/debian/docs b/debian/docs new file mode 100644 index 0000000..5502ed8 --- /dev/null +++ b/debian/docs @@ -0,0 +1,3 @@ +NEWS +README +TODO diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..b3dd8b6 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,53 @@ +#! /bin/sh +# postinst script for uffi +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=uffi + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + ln -sf ../repositories/uffi /usr/share/common-lisp/source/uffi + /usr/sbin/register-common-lisp-source ${LISP_PKG} + + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..86f8f66 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,43 @@ +#! /bin/sh +# prerm script for uffi +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=uffi + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + rm -rf /usr/share/common-lisp/source/uffi /usr/share/common-lisp/repositories/uffi + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..84910cc --- /dev/null +++ b/debian/rules @@ -0,0 +1,109 @@ +#!/usr/bin/make -f +# Sample debian/rules that uses debhelper. +# GNU copyright 1997 to 1999 by Joey Hess. + +# Uncomment this to turn on verbose mode. +export DH_VERBOSE=1 + +# This is the debhelper compatibility version to use. +export DH_COMPAT=3 + +pkg := cl-uffi +prefix := debian/$(pkg) + +INSTALL := install +INSTALLFLAGS := -g root -o root -m 0644 +INSTALLDIRFLAGS := -d -g root -o root -m 0755 + +SOURCEDIR := $(prefix)/usr/share/common-lisp/source +REPOSITORYDIR := $(prefix)/usr/share/common-lisp/repositories/uffi +SYSDIR := $(prefix)/usr/share/common-lisp/systems +DOCDIR := $(prefix)/usr/share/doc/cl-uffi + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + + # Add here commands to compile the package. + $(MAKE) doc + #/usr/bin/docbook-to-man debian/uffi.sgml > uffi.1 + + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + + # Add here commands to clean up after the build process. + -$(MAKE) clean + + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs + + # Add here commands to install the package into debian/uffi. + $(INSTALL) $(INSTALLDIRFLAGS) $(REPOSITORYDIR) $(REPOSITORYDIR)/mcl $(SYSDIR) $(DOCDIR) $(DOCDIR)/html $(SOURCEDIR) + $(INSTALL) $(INSTALLFLAGS) uffi.system.debian $(SYSDIR) + mv $(SYSDIR)/uffi.system.debian $(SYSDIR)/uffi.system + $(INSTALL) $(INSTALLFLAGS) $(shell echo src/*.cl) $(REPOSITORYDIR) + $(INSTALL) $(INSTALLFLAGS) $(shell echo src/mcl/*.cl) $(REPOSITORYDIR)/mcl + $(INSTALL) $(INSTALLFLAGS) doc/html/* $(DOCDIR)/html + cp doc/uffi.ps doc/cl-uffi.ps + rm -f doc/cl-uffi.ps.gz + gzip doc/cl-uffi.ps + $(INSTALL) $(INSTALLFLAGS) doc/cl-uffi.ps.gz $(DOCDIR) + rm -f doc/cl-uffi.ps.gz + +# Build architecture-independent files here. +binary-indep: build install + + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs + dh_installexamples examples/*.cl +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs ChangeLog + dh_link + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl +# dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/watch b/debian/watch new file mode 100644 index 0000000..1a7f6a2 --- /dev/null +++ b/debian/watch @@ -0,0 +1,5 @@ +# Example watch control file for uscan +# Rename this file to "watch" and then you can run the "uscan" command +# to check for upstream updates and more. +# Site Directory Pattern Version Script +ftp.med-info.com /pub/uffi uffi-(.*)\.tar\.gz debian uupdate diff --git a/make-dist.sh b/make-dist.sh new file mode 100755 index 0000000..2d2a11f --- /dev/null +++ b/make-dist.sh @@ -0,0 +1,66 @@ +#!/bin/sh + +# Creates debian and system-independent archive files +# Programmer: Kevin Rosenberg based on script used by onShore Development + +set -e + +VERSION=`cat VERSION` +DEBPKG=cl-sql +PKG=clsql +TOPDIR=`basename $PWD` + +DISTDIR=${PKG}-${VERSION} +DEBDIR=${DEBPKG}-${VERSION} + +TAG=upstream_version_`echo $VERSION | tr . _` +echo "(re)tagging with release tag '$TAG'" +cvs -q rtag -d $TAG $PKG +cvs -q tag -F $TAG + + +# build the tarball +echo "building tarballs" +cd .. +rm -f ${PKG}_${VERSION}.tar.gz ${DEBPKG}_${VERSION}.orig.tar.gz +rm -rf ${DISTDIR} ${DEBDIR} ${DISTDIR}.zip +cp -a ${TOPDIR} ${DISTDIR} + +# Remove junk from distribution dir +find ${DISTDIR} -type f -name .cvsignore -exec rm {} \; +find ${DISTDIR} -type d -name CVS | xargs rm -r +find ${DISTDIR}/doc -type f -name \*.tex -or -name \*.aux -or \ + -name \*.log -or -name \*.out -or -name \*.dvi -or \ + -name \*~ -or -name .\#\* -or -name \#*\# |xargs rm -f + +# Copy dist dir to debian directory +cp -a ${DISTDIR} ${DEBDIR} +rm -f ${DEBDIR}/${PKG}.system +mv ${DEBDIR}/${PKG}.system.debian ${DEBDIR}/${PKG}.system + +# Create original distribution archive +rm -rf ${DISTDIR}/debian ${DISTDIR}/*.system.debian + +GZIP=-9 tar czf ${DISTDIR}.tar.gz ${DISTDIR} + +cp ${DISTDIR}.tar.gz ${DEBPKG}_${VERSION}.orig.tar.gz +find ${DISTDIR} -type f -and -name \*.cl -or -name \*.list -or \ + -name \*.system -or -name Makefile -or -name ChangeLog -or \ + -name COPYRIGHT -or -name TODO -or -name README -or -name INSTALL \ + -or -name NEWS -or -name \*.sgml -or -name COPYING\* -or -name catalog \ + | xargs unix2dos +zip -rq ${DISTDIR}.zip ${DISTDIR} + + +cp ${TOPDIR}/${PKG}.system.debian ${DEBDIR} +cd ${DEBDIR} +dpkg-buildpackage -rfakeroot -kkevin@b9.com + +cd .. +rm -rf ${DISTDIR} +rm -rf ${DEBDIR} + +lintian ${DEBPKG}_${VERSION}-*.changes + +cd ${TOPDIR} +exit 0 -- 2.34.1 From 949ecae2e659ee76895debdf3e6b6bf01c7a4e3b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 28 Apr 2002 10:58:07 +0000 Subject: [PATCH 16/16] r1826: *** empty log message *** --- Makefile | 9 +++++++-- Makefile.common | 16 ++++++++++++++++ VERSION | 5 ----- copy | 2 ++ debian/control | 13 +++++++------ debian/copyright | 12 ++++++------ debian/postinst | 6 +++--- debian/prerm | 6 +++--- debian/watch | 2 +- 9 files changed, 45 insertions(+), 26 deletions(-) create mode 100644 Makefile.common create mode 100755 copy diff --git a/Makefile b/Makefile index 131c689..3fca755 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.15 2002/04/27 20:58:11 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.16 2002/04/28 10:58:07 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -13,7 +13,12 @@ # as governed by the terms of the Lisp Lesser GNU Public License # (http://opensource.franz.com/preamble.html), also known as the LLGPL. -PKG=clsql +PKG:=clsql +DEBPKG=cl-sql +SUBDIRS:=interfaces sql cmucl-compat +DOCSUBDIRS:=doc + +include Makefile.common .PHONY: all libs clean distclean doc tagcvs dist wwwdist diff --git a/Makefile.common b/Makefile.common new file mode 100644 index 0000000..a7f36a2 --- /dev/null +++ b/Makefile.common @@ -0,0 +1,16 @@ +all: + + +.PHONY: clean +clean: + @rm -rf .bin + @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl + @rm -f *~ *.bak *.orig *.err \#*\# .#* + @rm -f *.so *.a + @rm -rf debian/cl-sql +ifneq ($(SUBDIRS)$(DOCSUBDIRS),) + @set -e; for i in $(SUBDIRS) $(DOCSUBDIRS); do \ + $(MAKE) -C $$i $@; done +endif + +.SUFFIXES: # No default suffixes diff --git a/VERSION b/VERSION index 671a34c..faef31a 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1 @@ 0.7.0 - - - - - diff --git a/copy b/copy new file mode 100755 index 0000000..20cdba7 --- /dev/null +++ b/copy @@ -0,0 +1,2 @@ +scp clsql-*.tar.gz clsql-*.zip ftp.med-info.com:/home/ftp/pub/clsql/. +ssh ftp.med-info.com "(cd /opt/apache/htdocs/clsql.med-info.com; make)" diff --git a/debian/control b/debian/control index 2f84810..4701fb2 100644 --- a/debian/control +++ b/debian/control @@ -1,13 +1,14 @@ -Source: cl-uffi +Source: cl-sql Section: devel Priority: optional Maintainer: Kevin Rosenberg Build-Depends-Indep: debhelper (>> 3.0.0) Standards-Version: 3.5.2 -Package: cl-uffi +Package: cl-sql Architecture: all -Depends: common-lisp-controller, cmucl | lisp-compiler -Description: Universal Foreign Function Library for Common Lisp - UFFI provides a universal foreign function interface (FFI) for Common Lisp. - UFFI supports CMUCL, Lispworks, and AllegroCL. +Depends: common-lisp-controller, cl-uffi, cmucl | lisp-compiler +Description: SQL Interface for Common Lisp + CLSQL uses the UFFI library to provide SQL to multiple SQL databases + on multiple Common Lisp implementations. + diff --git a/debian/copyright b/debian/copyright index 3a08824..9b1d537 100644 --- a/debian/copyright +++ b/debian/copyright @@ -1,20 +1,20 @@ -The home site for UFFI is http://uffi.med-info.com. The package +The home site for CLSQL is http://clsql.med-info.com. The package may be downloaded from that site. -UFFI has been packaged by Kevin M. Rosenberg who is also the +CLSQL has been packaged by Kevin M. Rosenberg who is also the upstream author. Copyright: -UFFI is written and Copyright (c) 2002 by Kevin M. Rosenberg. +CLSQL is written and Copyright (c) 2002 by Kevin M. Rosenberg. -UFFI is licensed under the terms of the Lisp Lesser GNU +CLSQL is licensed under the terms of the Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), known as the LLGPL. The LLGPL consists of a preamble (see above URL) and the LGPL. Where these conflict, the preamble takes precedence. -UFFI is referenced in the preamble as the "LIBRARY." +CLSQL is referenced in the preamble as the "LIBRARY." -UFFI is distributed in the hope that it will be useful, +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. diff --git a/debian/postinst b/debian/postinst index b3dd8b6..33de95a 100644 --- a/debian/postinst +++ b/debian/postinst @@ -1,12 +1,12 @@ #! /bin/sh -# postinst script for uffi +# postinst script for clsql # # see: dh_installdeb(1) set -e # package name according to lisp -LISP_PKG=uffi +LISP_PKG=clsql # summary of how this script can be called: # * `configure' @@ -28,7 +28,7 @@ LISP_PKG=uffi case "$1" in configure) - ln -sf ../repositories/uffi /usr/share/common-lisp/source/uffi + ln -sf ../repositories/clsql /usr/share/common-lisp/source/clsql /usr/sbin/register-common-lisp-source ${LISP_PKG} ;; diff --git a/debian/prerm b/debian/prerm index 86f8f66..722d8f0 100644 --- a/debian/prerm +++ b/debian/prerm @@ -1,12 +1,12 @@ #! /bin/sh -# prerm script for uffi +# prerm script for clsql # # see: dh_installdeb(1) set -e # package name according to lisp -LISP_PKG=uffi +LISP_PKG=clsql # summary of how this script can be called: # * `remove' @@ -23,7 +23,7 @@ LISP_PKG=uffi case "$1" in remove|upgrade|deconfigure) /usr/sbin/unregister-common-lisp-source ${LISP_PKG} - rm -rf /usr/share/common-lisp/source/uffi /usr/share/common-lisp/repositories/uffi + rm -rf /usr/share/common-lisp/source/clsql /usr/share/common-lisp/repositories/clsql ;; failed-upgrade) ;; diff --git a/debian/watch b/debian/watch index 1a7f6a2..1d91de5 100644 --- a/debian/watch +++ b/debian/watch @@ -2,4 +2,4 @@ # Rename this file to "watch" and then you can run the "uscan" command # to check for upstream updates and more. # Site Directory Pattern Version Script -ftp.med-info.com /pub/uffi uffi-(.*)\.tar\.gz debian uupdate +ftp.med-info.com /pub/clsql clsql-(.*)\.tar\.gz debian uupdate -- 2.34.1