From e5744a78271044484b3399d4fc1d55b3e8808784 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 11 Apr 2004 00:12:18 +0000 Subject: [PATCH] r8928: add probe-database,create-database,destroy-database --- ChangeLog | 12 +- base/database.lisp | 2 +- base/loop-extension.lisp | 49 ++-- base/package.lisp | 2 + base/utils.lisp | 82 ++++++- clsql-tests.asd | 1 + db-mysql/mysql-sql.lisp | 72 +++--- .../postgresql-socket-sql.lisp | 8 +- db-postgresql/postgresql-sql.lisp | 72 +++--- doc/ref_clsql.xml | 232 ++++++++++++++++++ tests/test-init.lisp | 2 +- 11 files changed, 416 insertions(+), 118 deletions(-) diff --git a/ChangeLog b/ChangeLog index 06760e8..e4f8290 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,14 @@ 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) - * Version 2.5.3 released: - * base/database.lisp: Added CREATE-DATABASE, - DESTROY-DATABASE, PROBE-DATABASE commands + * Version 2.6.0 released: New API functions + CREATE-DATABASE, DESTORY-DATABASE, PROBE-DATABASE + * doc/ref_clsql.xml: Document new functions + * base/database.lisp: New API functions * base/conditions.lisp: Added CLSQL-ACCESS-ERROR + * base/utils.lisp: Fix use of position-char. + Add COMMAND-OUTPUT used by backends for running + shell commands. + * base/loop-extension.lisp: Rework packages + for Lispworks and Allegro * db-*/*-sql.lisp: Added DATABASE-CREATE, DATABASE-DESTORY, PROBE-DATABASE methods * tests/test-init.lisp, clasic-tests/tests.lisp: diff --git a/base/database.lisp b/base/database.lisp index 7cf45f1..92599bb 100644 --- a/base/database.lisp +++ b/base/database.lisp @@ -219,7 +219,7 @@ of full is NIL." (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)) + (database-destroy connection-spec database-type)) (defmacro with-database ((db-var connection-spec &rest connect-args) &body body) diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp index 5214488..0eba251 100644 --- a/base/loop-extension.lisp +++ b/base/loop-extension.lisp @@ -18,30 +18,16 @@ ;;;; MIT-LOOP extension -#+sbcl +#+(or allegro sbcl) (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage #:ansi-loop - (:import-from #:sb-loop + (:import-from #+sbcl #:sb-loop #+allegro #:excl #:loop-error #:*loop-epilogue* #:*loop-ansi-universe* #:add-loop-path))) -#+lispworks -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:ansi-loop - (:import-from #:loop - #:*epilogue*))) - -#+allegro -(defpackage #:ansi-loop - (:import-from #:excl - #:loop-error - #:*loop-epilogue* - #:*loop-ansi-universe* - #:add-loop-path)) - -#+sbcl +#+(or allegro sbcl) (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) (gensym (string pref))) @@ -129,16 +115,13 @@ #+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)) +(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method + (in of from)) #+lispworks -(defun ansi-loop::clsql-loop-method (method-name iter-var iter-var-data-type - prep-phrases inclusive? allowed-preps - method-specific-data) +(defun clsql-loop-method (method-name iter-var iter-var-data-type + prep-phrases inclusive? allowed-preps + method-specific-data) (let ((in-phrase nil) (from-phrase nil)) (loop for (prep . rest) in prep-phrases @@ -163,11 +146,10 @@ (setq from-phrase '(clsql-base-sys:*default-database*))) (cond ((consp iter-var) - (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) - (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) - (result-set-var (ansi-loop::loop-gentemp - 'loop-record-result-set-)) - (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + (let ((query-var (gensym 'loop-record-)) + (db-var (gensym 'loop-record-database-)) + (result-set-var (gensym 'loop-record-result-set-)) + (step-var (gensym 'loop-record-step-))) (values t nil @@ -194,10 +176,9 @@ () ()))) (t - (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) - (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) - (result-set-var (ansi-loop::loop-gentemp - 'loop-record-result-set-))) + (let ((query-var (gensym 'loop-record-)) + (db-var (gensym 'loop-record-database-)) + (result-set-var (gensym 'loop-record-result-set-))) (values t nil diff --git a/base/package.lisp b/base/package.lisp index 70b1e25..9888ba1 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -65,6 +65,8 @@ #:database-write-large-object #:database-read-large-object #:database-delete-large-object + + #:command-output ;; Shared exports for re-export by CLSQL-BASE . diff --git a/base/utils.lisp b/base/utils.lisp index d409977..0221ac4 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -113,7 +113,7 @@ (setq pos (1+ end)))) (defun string-to-list-connection-spec (str) - (let ((at-pos (position-char #\@ str))) + (let ((at-pos (position-char #\@ str 0 (length str)))) (cond ((and at-pos (> (length str) at-pos)) ;; Connection spec is SQL*NET format @@ -122,3 +122,83 @@ (t (delimited-string-to-list str #\/))))) +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:excl.osi) + (require 'osi))) + +(defun command-output (control-string &rest args) + ;; Concatenates output and error since Lispworks combines + ;; these, thus CLSQL can't depend upon separate results + (multiple-value-bind (output error status) + (apply #'%command-output control-string args) + (values + (concatenate 'string (if output output "") + (if error error "")) + status))) + +;; From KMRCL +(defun %command-output (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES string-output error-output exit-status)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (let ((process (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream))) + (values + (sb-impl::process-output process) + (sb-impl::process-error process) + (sb-impl::process-exit-code process))) + + #+(or cmu scl) + (let ((process (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream))) + (values + (ext::process-output process) + (ext::process-error process) + (ext::process-exit-code process))) + + #+allegro + (multiple-value-bind (output error status) + (excl.osi:command-output command :whole t) + (values output error status)) + + #+lispworks + ;; BUG: Lispworks combines output and error streams + (let ((output (make-output-string-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream output))) + (values (get-output-string output) nil status)) + (close output))) + + #+clisp + ;; BUG: CLisp doesn't allow output to user-specified stream + (values + nil + nil + (ext:run-shell-command command :output :terminal :wait t)) + + #+openmcl + (let ((process (ccl:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream + :wait t))) + (values + (get-output-stream-string (ccl::external-process-output-stream process)) + (get-output-stream-string (ccl::external-process-error-stream process)) + (nth-value 1 (ccl::external-process-status process)))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "COMMAND-OUTPUT not implemented for this Lisp") + + )) diff --git a/clsql-tests.asd b/clsql-tests.asd index 6d44b87..274e69b 100644 --- a/clsql-tests.asd +++ b/clsql-tests.asd @@ -40,6 +40,7 @@ (:file "test-syntax"))))) (defmethod perform ((o test-op) (c (eql (find-system 'clsql-tests)))) + (operate 'load-op 'clsql) (unless (funcall (intern (symbol-name '#:run-tests) (find-package '#:clsql-tests))) (error "test-op failed"))) diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 12279c3..55918a9 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -397,47 +397,47 @@ (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*))))) + (multiple-value-bind (output status) + (clsql-base-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A" + user password + (if host host "localhost") + name) + (if (or (not (eql 0 status)) + (and (search "failed" output) (search "error" output))) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-create failed: ~A" output)) + t)))) (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*))))) + (multiple-value-bind (output status) + (clsql-base-sys:command-output "mysqladmin drop -u~A -p~A -h~A ~A" + user password + (if host host "localhost") + name) + (if (or (not (eql 0 status)) + (and (search "failed" output) (search "error" output))) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-destroy failed: ~A" output)) + t)))) (defmethod database-probe (connection-spec (type (eql :mysql))) - (destructuring-bind (name user password) connection-spec - (error "not-yet-implemented"))) + (destructuring-bind (host name user password) connection-spec + (let ((database (database-connect (list host "mysql" user password) type))) + (unwind-protect + (when + (find name (database-query "select db from db" + database :auto) + :key #'car :test #'string-equal) + t) + (database-disconnect database))))) + (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 7df3dc7..9a2f02d 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -446,9 +446,11 @@ doesn't depend on UFFI." (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) + (when + (find name (database-query "select datname from pg_database" + database :auto) + :key #'car :test #'string-equal) + t) (database-disconnect database))))) (when (clsql-base-sys:database-type-library-loaded :postgresql-socket) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 76cab66..5355972 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -479,45 +479,37 @@ (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*))))) + (declare (ignore user password)) + (multiple-value-bind (output status) + (clsql-base-sys:command-output "createdb -h~A ~A" + (if host host "localhost") + name) + (if (or (not (zerop status)) + (search "database creation failed: ERROR:" output)) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-create failed: ~A" + output)) + t)))) (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*))))) + (declare (ignore user password)) + (multiple-value-bind (output status) + (clsql-base-sys:command-output "dropdb -h~A ~A" + (if host host "localhost") + name) + (if (or (not (zerop status)) + (search "database removal failed: ERROR:" output)) + (error 'clsql-access-error + :connection-spec connection-spec + :database-type type + :error + (format nil "database-destory failed: ~A" + output)) + t)))) (defmethod database-probe (connection-spec (type (eql :postgresql))) @@ -525,9 +517,11 @@ (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) + (when + (find name (database-query "select datname from pg_database" + database :auto) + :key #'car :test #'string-equal) + t) (database-disconnect database))))) diff --git a/doc/ref_clsql.xml b/doc/ref_clsql.xml index 6fadbae..9f5c0d6 100644 --- a/doc/ref_clsql.xml +++ b/doc/ref_clsql.xml @@ -1650,6 +1650,238 @@ The default is &nil;. + + + CREATE-DATABASE + create a database + Function + + + Syntax + create-database connection-spec &key database-type => success + + + Arguments and Values + + + connection-spec + + A connection specification + + + + database-type + + A database type specifier, i.e. a keyword. + This defaults to the value of + *default-database-type* + + + + success + + A boolean flag. If &t;, a new database wa + successfully created. + + + + + + + Description + This function creates a database in the database system + specified by database-type. + + + + Examples + +(create-database '("localhost" "new" "dent" "dent") :database-type :mysql) +=> T + +(create-database '("localhost" "new" "dent" "badpasswd") :database-type :mysql) +Error: While trying to access database localhost/new/dent + using database-type MYSQL: + Error database-create failed: mysqladmin: connect to server at 'localhost' failed +error: 'Access denied for user: 'root@localhost' (Using password: YES)' + has occurred. + [condition type: CLSQL-ACCESS-ERROR] + + + + Side Effects + A database will be created on the filesystem of the host. + + + Exceptional Situations + An exception will be thrown if the database system does + not allow new databases to be created or if database creation + fails. Currently, only the :postgresql-socket + does not allow new databases to be created. + + + Notes + This function may invoke the operating systems + functions. Thus, some database systems may require the + administration functions to be available in the current + PATH. At this time, the + :mysql backend requires + mysqladmin and the + :postgresql backend requires + createdb. + + + + + + DESTROY-DATABASE + destroys a database + Function + + + Syntax + destroy-database connection-spec &key database-type => success + + + Arguments and Values + + + connection-spec + + A connection specification + + + + database-type + + A database type specifier, i.e. a keyword. + This defaults to the value of + *default-database-type* + + + + success + + A boolean flag. If &t;, a new database wa + successfully destroyed. + + + + + + + Description + This function destroy a database in the database system + specified by database-type. + + + + Examples + +(destroy-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> T + +(destroy-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +Error: While trying to access database localhost/test2/root + using database-type POSTGRESQL: + Error database-destory failed: dropdb: database removal failed: ERROR: database "test2" does not exist + has occurred. + [condition type: CLSQL-ACCESS-ERROR] + + + + Side Effects + A database will be removed from the filesystem of the host. + + + Exceptional Situations + An exception will be thrown if the database system does not + allow databases to be removed, the database does not exist, or + if database removal fails. Currently, only the + :postgresql-socket does not allow + databases to be destroyed. + + + Notes + This function may invoke the operating systems + functions. Thus, some database systems may require the + administration functions to be available in the current + PATH. At this time, the + :mysql backend requires + mysqladmin and the + :postgresql backend requires + dropdb. + + + + + + PROBE-DATABASE + tests for existance of a database + Function + + + Syntax + probe-database connection-spec &key database-type => success + + + Arguments and Values + + + connection-spec + + A connection specification + + + + database-type + + A database type specifier, i.e. a keyword. + This defaults to the value of + *default-database-type* + + + + success + + A boolean flag. If &t;, the database exists + in the database system. + + + + + + + Description + This function tests for the existance of a database in + the database system specified by + database-type. + + + + Examples + +(probe-database '("localhost" "new" "dent" "dent") :database-type :postgresql) +=> T + + + + Side Effects + None + + + Exceptional Situations + An exception maybe thrown if the database system does + not receive administrator-level authentication. This function + may need to read the administrative table of the database + system. + + + Notes + None. + + + DATABASE-NAME-FROM-SPEC diff --git a/tests/test-init.lisp b/tests/test-init.lisp index ebbcf83..005c247 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -321,7 +321,7 @@ ******************************************************************* " db-type) (db-type-ensure-system db-type) - (rt:rem-all-tests) + (regression-test: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* -- 2.34.1