From c4da3cfcbb955395d8a556e1f89aadad696302b7 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sat, 10 Apr 2004 21:12:52 +0000 Subject: [PATCH] r8926: add database-create database-destroy database-probe --- ChangeLog | 13 ++++ base/conditions.lisp | 27 ++++--- base/database.lisp | 16 ++++ base/db-interface.lisp | 13 +++- base/loop-extension.lisp | 25 +++---- base/package.lisp | 16 ++-- base/utils.lisp | 4 +- classic-tests/tests.lisp | 8 +- classic/package.lisp | 10 ++- clsql.asd | 2 +- db-mysql/mysql-sql.lisp | 71 ++++++++++++------ .../postgresql-socket-sql.lisp | 44 +++++------ db-postgresql/postgresql-sql.lisp | 74 +++++++++++++------ db-sqlite/sqlite-sql.lisp | 18 +++++ sql/package.lisp | 10 ++- tests/test-connection.lisp | 12 ++- tests/test-init.lisp | 9 ++- 17 files changed, 265 insertions(+), 107 deletions(-) diff --git a/ChangeLog b/ChangeLog index aad7993..06760e8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.5.3 released: + * base/database.lisp: Added CREATE-DATABASE, + DESTROY-DATABASE, PROBE-DATABASE commands + * base/conditions.lisp: Added CLSQL-ACCESS-ERROR + * db-*/*-sql.lisp: Added DATABASE-CREATE, + DATABASE-DESTORY, PROBE-DATABASE methods + * tests/test-init.lisp, clasic-tests/tests.lisp: + Use destroy-database and create-database to ensure + testing with empty database + * tests/test-connection.lisp: Add tests for + parsing of string connection-specs + 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.5.1 released: * tests/*.lisp: Rework so tests are run diff --git a/base/conditions.lisp b/base/conditions.lisp index c70f288..d5a918a 100644 --- a/base/conditions.lisp +++ b/base/conditions.lisp @@ -61,21 +61,30 @@ and signal an clsql-invalid-spec-error if they don't match." :database-type ,database-type :template (quote ,template))))) -(define-condition clsql-connect-error (clsql-error) +(define-condition clsql-access-error (clsql-error) ((database-type :initarg :database-type - :reader clsql-connect-error-database-type) + :reader clsql-access-error-database-type) (connection-spec :initarg :connection-spec - :reader clsql-connect-error-connection-spec) - (errno :initarg :errno :reader clsql-connect-error-errno) - (error :initarg :error :reader clsql-connect-error-error)) + :reader clsql-access-error-connection-spec) + (error :initarg :error :reader clsql-access-error-error)) + (:report (lambda (c stream) + (format stream "While trying to access database ~A~% using database-type ~A:~% Error ~A~% has occurred." + (database-name-from-spec + (clsql-access-error-connection-spec c) + (clsql-access-error-database-type c)) + (clsql-access-error-database-type c) + (clsql-access-error-error c))))) + +(define-condition clsql-connect-error (clsql-access-error) + ((errno :initarg :errno :reader clsql-connect-error-errno)) (:report (lambda (c stream) (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred." (database-name-from-spec - (clsql-connect-error-connection-spec c) - (clsql-connect-error-database-type c)) - (clsql-connect-error-database-type c) + (clsql-access-error-connection-spec c) + (clsql-access-error-database-type c)) + (clsql-access-error-database-type c) (clsql-connect-error-errno c) - (clsql-connect-error-error c))))) + (clsql-access-error-error c))))) (define-condition clsql-sql-error (clsql-error) ((database :initarg :database :reader clsql-sql-error-database) diff --git a/base/database.lisp b/base/database.lisp index a7313eb..7cf45f1 100644 --- a/base/database.lisp +++ b/base/database.lisp @@ -206,6 +206,21 @@ of full is NIL." (print-separator total-size)))) (values))) +(defun create-database (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-create connection-spec database-type)) + +(defun probe-database (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-probe connection-spec database-type)) + +(defun destroy-database (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-destory connection-spec database-type)) + (defmacro with-database ((db-var connection-spec &rest connect-args) &body body) "Evaluate the body in an environment, where `db-var' is bound to the @@ -227,3 +242,4 @@ The connection is automatically closed or released to the pool on exit from the `(progv '(*default-database*) (list ,database) ,@body)) + diff --git a/base/db-interface.lisp b/base/db-interface.lisp index 2904f3d..9c8d363 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -121,8 +121,19 @@ function should signal a clsql-sql-error.")) "Returns t and stores the next row in the result set in list or returns nil when result-set is finished.")) +(defgeneric database-create (connection-spec type) + (:documentation + "Creates a database, returns T if successfull or signals an error.")) + +(defgeneric database-probe (connection-spec type) + (:documentation + "Probes for the existence of a database, returns T if database found or NIL +if not found. May signal an error if unable to communicate with database server.")) -;; Interfaces to support UncommonSQL +(defgeneric database-destory (connection-spec type) + (:documentation + "Destroys a database, returns T if successfull or signals an error +if unable to destory.")) (defgeneric database-create-sequence (name database) (:documentation "Create a sequence in DATABASE.")) diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp index 76010e4..5214488 100644 --- a/base/loop-extension.lisp +++ b/base/loop-extension.lisp @@ -34,21 +34,14 @@ #:*epilogue*))) #+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package '#:ansi-loop) - (let ((excl::*enable-package-locked-errors* nil)) - (rename-package '#:excl '#:excl - (cons '#:ansi-loop - (package-nicknames (find-package '#:excl))))))) - -#+lispworks -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package '#:ansi-loop) - (rename-package '#:loop '#:loop - (cons '#:ansi-loop - (package-nicknames (find-package '#:loop)))))) +(defpackage #:ansi-loop + (:import-from #:excl + #:loop-error + #:*loop-epilogue* + #:*loop-ansi-universe* + #:add-loop-path)) -#+(or sbcl lispworks) +#+sbcl (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) (gensym (string pref))) @@ -135,6 +128,10 @@ #+lispworks (in-package loop) +#+lispworks +(defun loop::loop-gentemp (&optional (pref 'loopva-)) + (gensym (string pref))) + #+lispworks (cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from)) diff --git a/base/package.lisp b/base/package.lisp index 58a2eea..70b1e25 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -39,8 +39,10 @@ #:database-query-result-set #:database-dump-result-set #:database-store-next-row - - ;; For UncommonSQL support + #:database-create + #:database-destroy + #:database-probe + #:database-list-tables #:database-list-attributes #:database-attribute-type @@ -75,11 +77,12 @@ #:clsql-invalid-spec-error-connection-spec #:clsql-invalid-spec-error-database-type #:clsql-invalid-spec-error-template + #:clsql-access-error + #:clsql-access-error-database-type + #:clsql-access-error-connection-spec + #:clsql-access-error-error #:clsql-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec #:clsql-connect-error-errno - #:clsql-connect-error-error #:clsql-sql-error #:clsql-sql-error-database #:clsql-sql-error-expression @@ -227,6 +230,9 @@ #:with-database #:with-default-database #:disconnect-pooled + #:create-database + #:destroy-database + #:probe-database ;; basic-sql.lisp #:query diff --git a/base/utils.lisp b/base/utils.lisp index 729109b..d409977 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -117,8 +117,8 @@ (cond ((and at-pos (> (length str) at-pos)) ;; Connection spec is SQL*NET format - (append (delimited-string-to-list (subseq str 0 at-pos) #\/) - (list (subseq str (1+ at-pos))))) + (cons (subseq str (1+ at-pos)) + (delimited-string-to-list (subseq str 0 at-pos) #\/))) (t (delimited-string-to-list str #\/))))) diff --git a/classic-tests/tests.lisp b/classic-tests/tests.lisp index 94db68c..d94ed47 100644 --- a/classic-tests/tests.lisp +++ b/classic-tests/tests.lisp @@ -81,6 +81,8 @@ (warn "CLSQL test config file ~S not found" path) nil))) +(defgeneric test-table (spec type)) + (defmethod test-table (spec type) (when spec (let ((db (clsql:connect spec :database-type type :if-exists :new))) @@ -139,9 +141,9 @@ ) (disconnect :database db))))) -(defmethod mysql-low-level ((test conn-specs)) +(defun mysql-low-level (specs) #-clisp - (let ((spec (mysql-spec test))) + (let ((spec (mysql-spec specs))) (when spec (let ((db (clsql-mysql::database-connect spec :mysql))) (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db) @@ -281,5 +283,7 @@ (let ((spec (db-type-spec db-type specs))) (when spec (db-type-ensure-system db-type) + (ignore-errors (destroy-database spec db-type)) + (ignore-errors (create-database spec db-type)) (test-table spec db-type)))))) t) diff --git a/classic/package.lisp b/classic/package.lisp index dd51927..e1253bd 100644 --- a/classic/package.lisp +++ b/classic/package.lisp @@ -37,11 +37,12 @@ #:clsql-invalid-spec-error-connection-spec #:clsql-invalid-spec-error-database-type #:clsql-invalid-spec-error-template + #:clsql-access-error + #:clsql-access-error-database-type + #:clsql-access-error-connection-spec + #:clsql-access-error-error #:clsql-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec #:clsql-connect-error-errno - #:clsql-connect-error-error #:clsql-sql-error #:clsql-sql-error-database #:clsql-sql-error-expression @@ -88,6 +89,9 @@ #:status ; database xx #:with-database #:with-default-database + #:create-database + #:destroy-database + #:probe-database ;; basic-sql.lisp #:query diff --git a/clsql.asd b/clsql.asd index f7c9d36..366859a 100644 --- a/clsql.asd +++ b/clsql.asd @@ -57,4 +57,4 @@ a functional and an object oriented interface." (defmethod perform ((o test-op) (c (eql (find-system 'clsql)))) (operate 'load-op 'clsql-tests) - (operate 'test-op 'clsql-tests)) + (operate 'test-op 'clsql-tests :force t)) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 0f50e6c..12279c3 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -78,7 +78,9 @@ (check-connection-spec connection-spec database-type (host db user password)) (destructuring-bind (host db user password) connection-spec (declare (ignore password)) - (concatenate 'string host "/" db "/" user))) + (concatenate 'string + (if host host "localhost") + "/" db "/" user))) (defmethod database-connect (connection-spec (database-type (eql :mysql))) (check-connection-spec connection-spec database-type (host db user password)) @@ -391,28 +393,51 @@ (defmethod database-sequence-last (sequence-name (database mysql-database)) (declare (ignore sequence-name))) -;; Functions depending upon high-level CommonSQL classes/functions -#| -(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*))))) - -(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))) -|# + + +(defmethod database-create (connection-spec (type (eql :mysql))) + (destructuring-bind (host name user password) connection-spec + (let ((asdf::*verbose-out* (make-string-output-stream))) + (unwind-protect + (let* ((status (asdf:run-shell-command + "mysqladmin create -u~A -p~A -h~A ~A" + user password + (if host host "localhost") + name)) + (result (get-output-stream-string asdf::*verbose-out*))) + + (if (search "CREATE DATABASE failed;" result) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-create failed: ~s" result)) + t)) + (close asdf::*verbose-out*))))) + +(defmethod database-destory (connection-spec (type (eql :mysql))) + (destructuring-bind (host name user password) connection-spec + (let ((asdf::*verbose-out* (make-string-output-stream))) + (unwind-protect + (let* ((status (asdf:run-shell-command + "mysqladmin drop -f -u~A -p~A -h~A ~A" + user password + (if host host "localhost") + name)) + (result (get-output-stream-string asdf::*verbose-out*))) + + (if (search "DROP DATABASE failed;" result) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-destory failed: ~s" result)) + t)) + (close asdf::*verbose-out*))))) + +(defmethod database-probe (connection-spec (type (eql :mysql))) + (destructuring-bind (name user password) connection-spec + (error "not-yet-implemented"))) (when (clsql-base-sys:database-type-library-loaded :mysql) (clsql-base-sys:initialize-database-type :database-type :mysql)) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 7cb1eba..7df3dc7 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -151,6 +151,8 @@ doesn't depend on UFFI." (declare (ignore password options tty)) (concatenate 'string (etypecase host + (null + "localhost") (pathname (namestring host)) (string host)) (when port @@ -427,27 +429,27 @@ doesn't depend on UFFI." database nil))))) -;; Functions depending upon high-level CommonSQL classes/functions -#| -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database postgresql-socket-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 #\: clsql-sys::*sql-stream*) - (write-char #\: clsql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database postgresql-socket-database)) - (when val ;; typecast it so it uses the indexes - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# +(defmethod database-create (connection-spec (type (eql :postgresql-socket))) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error "Unable to create databases on a socket connection.")) + +(defmethod database-destroy (connection-spec (type (eql :postgresql-socket))) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error "Unable to create databases on a socket connection.")) + +(defmethod database-probe (connection-spec (type (eql :postgresql-socket))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "template1" user password) + type))) + (unwind-protect + (find name (database-query "select datname from pg_database" + database :auto) + :key #'car :test #'string-equal) + (database-disconnect database))))) (when (clsql-base-sys:database-type-library-loaded :postgresql-socket) (clsql-base-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 373d55c..76cab66 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -93,6 +93,7 @@ (declare (ignore password options tty)) (concatenate 'string (etypecase host + (null "localhost") (pathname (namestring host)) (string host)) (when port @@ -476,28 +477,59 @@ (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") database nil))))) +(defmethod database-create (connection-spec (type (eql :postgresql))) + (destructuring-bind (host name user password) connection-spec + (declare (ignore password)) + (let ((asdf::*verbose-out* (make-string-output-stream))) + (unwind-protect + (let* ((status (asdf:run-shell-command + "su -c ~A createdb -h~A ~A" + user + (if host host "localhost") + name)) + (result (get-output-stream-string asdf::*verbose-out*))) + + (if (search "database creation failed: ERROR:" result) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-create failed: ~s" result)) + t)) + (close asdf::*verbose-out*))))) + +(defmethod database-destroy (connection-spec (type (eql :postgresql))) + (destructuring-bind (host name user password) connection-spec + (declare (ignore password)) + (let ((asdf::*verbose-out* (make-string-output-stream))) + (unwind-protect + (let* ((status (asdf:run-shell-command + "su -c ~A dropdb -h~A ~A" + user + (if host host "localhost") + name)) + (result (get-output-stream-string asdf::*verbose-out*))) + + (if (search "database removal failed: ERROR:" result) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-destroy failed: ~s" result)) + t)) + (close asdf::*verbose-out*))))) + + +(defmethod database-probe (connection-spec (type (eql :postgresql))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "template1" user password) + type))) + (unwind-protect + (find name (database-query "select datname from pg_database" + database :auto) + :key #'car :test #'string-equal) + (database-disconnect database))))) -;; Functions depending upon high-level CommonSQL classes/functions -#| -(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) - (database postgresql-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 #\: clsql-sys::*sql-stream*) - (write-char #\: clsql-sys::*sql-stream*) - (write-string (symbol-name clsql-sys::modifier) - clsql-sys::*sql-stream*))))) - -(defmethod database-output-sql-as-type ((type (eql 'integer)) val - (database postgresql-database)) - (when val ;; typecast it so it uses the indexes - (make-instance 'clsql-sys::sql-typecast-exp - :modifier 'int8 - :components val))) -|# (when (clsql-base-sys:database-type-library-loaded :postgresql) (clsql-base-sys:initialize-database-type :database-type :postgresql)) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 5a41b4d..9b67f38 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -282,3 +282,21 @@ (defmethod database-sequence-last (sequence-name (database sqlite-database)) (declare (ignore sequence-name))) + +(defmethod database-create (connection-spec (type (eql :sqlite))) + (declare (ignore connection-spec)) + ;; databases are created automatically by SQLite + t) + +(defmethod database-destroy (connection-spec (type (eql :sqlite))) + (destructuring-bind (name) connection-spec + (if (probe-file name) + (delete-file name) + nil))) + +(defmethod database-probe (connection-spec (type (eql :sqlite))) + (destructuring-bind (name) connection-spec + ;; TODO: Add a test that this file is a real sqlite database + (and (probe-file name) t))) + + diff --git a/sql/package.lisp b/sql/package.lisp index 01dae36..0de7881 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -109,11 +109,12 @@ #:clsql-invalid-spec-error-connection-spec #:clsql-invalid-spec-error-database-type #:clsql-invalid-spec-error-template + #:clsql-access-error + #:clsql-access-error-database-type + #:clsql-access-error-connection-spec + #:clsql-access-error-error #:clsql-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec #:clsql-connect-error-errno - #:clsql-connect-error-error #:clsql-sql-error #:clsql-sql-error-database #:clsql-sql-error-expression @@ -186,6 +187,9 @@ #:status ; database xx #:with-database #:with-default-database + #:create-database + #:destroy-database + #:probe-database ;; pool.lisp #:disconnect-pooled diff --git a/tests/test-connection.lisp b/tests/test-connection.lisp index 2952444..df91957 100644 --- a/tests/test-connection.lisp +++ b/tests/test-connection.lisp @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ====================================================================== ;;;; File: test-connection.lisp -;;;; Author: Marcus Pearce +;;;; Authors: Marcus Pearce , Kevin Rosenberg ;;;; Created: 30/03/2004 ;;;; Updated: $Id$ ;;;; ====================================================================== @@ -25,4 +25,14 @@ (eql (clsql:database-type database) *test-database-type*)) t) +(deftest :connection/2 + (clsql-base-sys::string-to-list-connection-spec + "localhost/dbname/user/passwd") + ("localhost" "dbname" "user" "passwd")) + +(deftest :connection/3 + (clsql-base-sys::string-to-list-connection-spec + "dbname/user@hostname") + ("hostname" "dbname" "user")) + )) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 89b6ce2..ebbcf83 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -314,12 +314,19 @@ (dolist (db-type +all-db-types+) (let ((spec (db-type-spec db-type specs))) (when spec + (format t +"~& +******************************************************************* +*** Running CLSQL tests with ~A backend. +******************************************************************* +" db-type) (db-type-ensure-system db-type) (rt:rem-all-tests) + (ignore-errors (destroy-database spec :database-type db-type)) + (ignore-errors (create-database spec :database-type db-type)) (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml* *rt-ooddl* *rt-oodml* *rt-syntax*)) (eval test)) - (format t "~&Running CLSQL tests with ~A backend.~%" db-type) (test-connect-to-database db-type spec) (test-initialise-database) (rtest:do-tests)))))) -- 2.34.1