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:
(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)
;;;; 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)))
#+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
(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
()
())))
(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
#:database-write-large-object
#:database-read-large-object
#:database-delete-large-object
+
+ #:command-output
;; Shared exports for re-export by CLSQL-BASE
.
(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
(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")
+
+ ))
(: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")))
(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))
(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)
(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)))
(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)))))
</refsect1>
</refentry>
+ <refentry id="create_db">
+ <refnamediv>
+ <refname>CREATE-DATABASE</refname>
+ <refpurpose>create a database</refpurpose>
+ <refclass>Function</refclass>
+ </refnamediv>
+ <refsect1>
+ <title>Syntax</title>
+ <synopsis><function>create-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis>
+ </refsect1>
+ <refsect1>
+ <title>Arguments and Values</title>
+ <variablelist>
+ <varlistentry>
+ <term><parameter>connection-spec</parameter></term>
+ <listitem>
+ <para>A connection specification</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>database-type</parameter></term>
+ <listitem>
+ <para>A database type specifier, i.e. a keyword.
+ This defaults to the value of
+ <symbol>*default-database-type*</symbol></para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>success</parameter></term>
+ <listitem>
+ <para>A boolean flag. If &t;, a new database wa
+ successfully created.
+ </para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </refsect1>
+ <refsect1>
+ <title>Description</title>
+ <para>This function creates a database in the database system
+ specified by <parameter>database-type</parameter>.
+ </para>
+ </refsect1>
+ <refsect1>
+ <title>Examples</title>
+ <screen>
+(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]
+ </screen>
+ </refsect1>
+ <refsect1>
+ <title>Side Effects</title>
+ <para>A database will be created on the filesystem of the host.</para>
+ </refsect1>
+ <refsect1>
+ <title>Exceptional Situations</title>
+ <para>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 <symbol>:postgresql-socket</symbol>
+ does not allow new databases to be created.</para>
+ </refsect1>
+ <refsect1>
+ <title>Notes</title>
+ <para>This function may invoke the operating systems
+ functions. Thus, some database systems may require the
+ administration functions to be available in the current
+ <symbol>PATH</symbol>. At this time, the
+ <symbol>:mysql</symbol> backend requires
+ <filename>mysqladmin</filename> and the
+ <symbol>:postgresql</symbol> backend requires
+ <filename>createdb</filename>.</para>
+ </refsect1>
+ </refentry>
+
+ <refentry id="destroy_db">
+ <refnamediv>
+ <refname>DESTROY-DATABASE</refname>
+ <refpurpose>destroys a database</refpurpose>
+ <refclass>Function</refclass>
+ </refnamediv>
+ <refsect1>
+ <title>Syntax</title>
+ <synopsis><function>destroy-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis>
+ </refsect1>
+ <refsect1>
+ <title>Arguments and Values</title>
+ <variablelist>
+ <varlistentry>
+ <term><parameter>connection-spec</parameter></term>
+ <listitem>
+ <para>A connection specification</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>database-type</parameter></term>
+ <listitem>
+ <para>A database type specifier, i.e. a keyword.
+ This defaults to the value of
+ <symbol>*default-database-type*</symbol></para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>success</parameter></term>
+ <listitem>
+ <para>A boolean flag. If &t;, a new database wa
+ successfully destroyed.
+ </para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </refsect1>
+ <refsect1>
+ <title>Description</title>
+ <para>This function destroy a database in the database system
+ specified by <parameter>database-type</parameter>.
+ </para>
+ </refsect1>
+ <refsect1>
+ <title>Examples</title>
+ <screen>
+(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]
+ </screen>
+ </refsect1>
+ <refsect1>
+ <title>Side Effects</title>
+ <para>A database will be removed from the filesystem of the host.</para>
+ </refsect1>
+ <refsect1>
+ <title>Exceptional Situations</title>
+ <para>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
+ <symbol>:postgresql-socket</symbol> does not allow
+ databases to be destroyed.</para>
+ </refsect1>
+ <refsect1>
+ <title>Notes</title>
+ <para>This function may invoke the operating systems
+ functions. Thus, some database systems may require the
+ administration functions to be available in the current
+ <symbol>PATH</symbol>. At this time, the
+ <symbol>:mysql</symbol> backend requires
+ <filename>mysqladmin</filename> and the
+ <symbol>:postgresql</symbol> backend requires
+ <filename>dropdb</filename>.</para>
+ </refsect1>
+ </refentry>
+
+ <refentry id="probe_db">
+ <refnamediv>
+ <refname>PROBE-DATABASE</refname>
+ <refpurpose>tests for existance of a database</refpurpose>
+ <refclass>Function</refclass>
+ </refnamediv>
+ <refsect1>
+ <title>Syntax</title>
+ <synopsis><function>probe-database</function> <replaceable>connection-spec</replaceable> &key <replaceable>database-type</replaceable> => <returnvalue>success</returnvalue></synopsis>
+ </refsect1>
+ <refsect1>
+ <title>Arguments and Values</title>
+ <variablelist>
+ <varlistentry>
+ <term><parameter>connection-spec</parameter></term>
+ <listitem>
+ <para>A connection specification</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>database-type</parameter></term>
+ <listitem>
+ <para>A database type specifier, i.e. a keyword.
+ This defaults to the value of
+ <symbol>*default-database-type*</symbol></para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><parameter>success</parameter></term>
+ <listitem>
+ <para>A boolean flag. If &t;, the database exists
+ in the database system.
+ </para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </refsect1>
+ <refsect1>
+ <title>Description</title>
+ <para>This function tests for the existance of a database in
+ the database system specified by
+ <parameter>database-type</parameter>.
+ </para>
+ </refsect1>
+ <refsect1>
+ <title>Examples</title>
+ <screen>
+(probe-database '("localhost" "new" "dent" "dent") :database-type :postgresql)
+=> T
+ </screen>
+ </refsect1>
+ <refsect1>
+ <title>Side Effects</title>
+ <para>None</para>
+ </refsect1>
+ <refsect1>
+ <title>Exceptional Situations</title>
+ <para>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.</para>
+ </refsect1>
+ <refsect1>
+ <title>Notes</title>
+ <para>None.</para>
+ </refsect1>
+ </refentry>
+
<refentry id="database-name-from-spec">
<refnamediv>
<refname>DATABASE-NAME-FROM-SPEC</refname>
*******************************************************************
" 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*
projects / clsql.git / commitdiff