Major rewrite of table/column name output escaping system wide.

[clsql.git] / sql / fddl.lisp

diff --git a/sql/fddl.lisp b/sql/fddl.lisp
index 75bfa97d1eb5fa6ddc428e4aecb547ca2f0b3b55..267ee290f1dfe583650f68a39e2c73e4f4d55119 100644 (file)
--- a/sql/fddl.lisp
+++ b/sql/fddl.lisp
@@ -1,8 +1,6 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;

-;;;; $Id$
-;;;;

 ;;;; The CLSQL Functional Data Definition Language (FDDL)
 ;;;; including functions for schema manipulation. Currently supported
 ;;;; SQL objects include tables, views, indexes, attributes and
 ;;;; The CLSQL Functional Data Definition Language (FDDL)
 ;;;; including functions for schema manipulation. Currently supported
 ;;;; SQL objects include tables, views, indexes, attributes and


@@ -18,18 +16,32 @@
 (in-package #:clsql-sys)
 
 
 (in-package #:clsql-sys)
 
 

-;; Utilities
-
-(defun database-identifier (name database)
-  (sql-escape (etypecase name
-               ;; honor case of strings
-                (string name
-                       #+nil (convert-to-db-default-case name database))
-                (sql-ident (sql-output name database))
-                (symbol (sql-output name database)))))
+;; Truncate database
+
+(defun truncate-database (&key (database *default-database*))
+  "Drops all tables, views, indexes and sequences in DATABASE which
+defaults to *DEFAULT-DATABASE*."
+  (unless (typep database 'database)
+    (signal-no-database-error database))
+  (unless (is-database-open database)
+    (database-reconnect database))
+  (when (eq :oracle (database-type database))
+    (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
+  (when (db-type-has-views? (database-underlying-type database))
+    (dolist (view (list-views :database database))
+      (drop-view view :database database)))
+  (dolist (table (list-tables :database database))
+    (drop-table table :database database))
+  (dolist (index (list-indexes :database database))
+    (drop-index index :database database))
+  (dolist (seq (list-sequences :database database))
+    (drop-sequence seq :database database))
+  (when (eq :oracle (database-type database))
+    (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
+  (values))

 
 
 
 

-;; Tables 
+;; Tables

 
 (defun create-table (name description &key (database *default-database*)
                           (constraints nil) (transactions t))
 
 (defun create-table (name description &key (database *default-database*)
                           (constraints nil) (transactions t))


@@ -42,41 +54,38 @@ the table.  CONSTRAINTS is a string representing an SQL table
 constraint expression or a list of such strings. With MySQL
 databases, if TRANSACTIONS is t an InnoDB table is created which
 supports transactions."
 constraint expression or a list of such strings. With MySQL
 databases, if TRANSACTIONS is t an InnoDB table is created which
 supports transactions."

-  (let* ((table-name (etypecase name 
-                       (symbol (sql-expression :attribute name))
-                       (string (sql-expression :attribute name))
-                       (sql-ident name)))
-         (stmt (make-instance 'sql-create-table
-                              :name table-name
-                              :columns description
-                              :modifiers constraints
-                             :transactions transactions)))
-    (execute-command stmt :database database)))
+  (execute-command
+   (make-instance 'sql-create-table
+                  :name name
+                  :columns description
+                  :modifiers constraints
+                  :transactions transactions)
+   :database database))

 
 (defun drop-table (name &key (if-does-not-exist :error)
 
 (defun drop-table (name &key (if-does-not-exist :error)

-                            (database *default-database*))
+                             (database *default-database*)
+                             (owner nil))

   "Drops the table called NAME from DATABASE which defaults to
 *DEFAULT-DATABASE*. If the table does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
 an error is signalled if IF-DOES-NOT-EXIST is :error."
   "Drops the table called NAME from DATABASE which defaults to
 *DEFAULT-DATABASE*. If the table does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
 an error is signalled if IF-DOES-NOT-EXIST is :error."

-  (let ((table-name (database-identifier name database)))

     (ecase if-does-not-exist
       (:ignore
     (ecase if-does-not-exist
       (:ignore

-       (unless (table-exists-p table-name :database database)
+       (unless (table-exists-p name :database database :owner owner)

          (return-from drop-table nil)))
       (:error
        t))
          (return-from drop-table nil)))
       (:error
        t))

-    
-    ;; Fixme: move to clsql-oracle
-    (let ((expr (concatenate 'string "DROP TABLE " table-name)))
+  
+    (let ((expr (concatenate 'string "DROP TABLE " (escaped-database-identifier name database))))
+      ;; Fixme: move to clsql-oracle

       (when (and (find-package 'clsql-oracle)
       (when (and (find-package 'clsql-oracle)

-                (eq :oracle (database-type database))
-                (eql 10 (slot-value database 
-                                    (intern (symbol-name '#:major-server-version)
-                                            (symbol-name '#:clsql-oracle)))))
-       (setq expr (concatenate 'string expr " PURGE")))
+                 (eq :oracle (database-type database))
+                 (eql 10 (slot-value database
+                                     (intern (symbol-name '#:major-server-version)
+                                             (symbol-name '#:clsql-oracle)))))
+        (setq expr (concatenate 'string expr " PURGE")))

 
 

-      (execute-command expr :database database))))
+      (execute-command expr :database database)))

 
 (defun list-tables (&key (owner nil) (database *default-database*))
   "Returns a list of strings representing table names in DATABASE
 
 (defun list-tables (&key (owner nil) (database *default-database*))
   "Returns a list of strings representing table names in DATABASE


@@ -86,6 +95,13 @@ is a string denoting a user name, only tables owned by OWNER are
 listed. If OWNER is :all then all tables are listed."
   (database-list-tables database :owner owner))
 
 listed. If OWNER is :all then all tables are listed."
   (database-list-tables database :owner owner))
 

+(defmethod %table-exists-p (name (database T) &key owner )
+  (unless database (setf database *default-database*))
+  (let ((name (database-identifier name database))
+        (tables (list-tables :owner owner :database database)))
+    (when (member name tables :test #'database-identifier-equal)
+      t)))
+

 (defun table-exists-p (name &key (owner nil) (database *default-database*))
   "Tests for the existence of an SQL table called NAME in DATABASE
 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 (defun table-exists-p (name &key (owner nil) (database *default-database*))
   "Tests for the existence of an SQL table called NAME in DATABASE
 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default


@@ -93,13 +109,10 @@ which means that only tables owned by users are examined. If
 OWNER is a string denoting a user name, only tables owned by
 OWNER are examined. If OWNER is :all then all tables are
 examined."
 OWNER is a string denoting a user name, only tables owned by
 OWNER are examined. If OWNER is :all then all tables are
 examined."

-  (when (member (database-identifier name database)
-                (list-tables :owner owner :database database)
-                :test #'string-equal)
-    t))
+  (%table-exists-p name database :owner owner))

 
 
 
 

-;; Views 
+;; Views

 
 (defun create-view (name &key as column-list (with-check-option nil)
                          (database *default-database*))
 
 (defun create-view (name &key as column-list (with-check-option nil)
                          (database *default-database*))


@@ -109,10 +122,7 @@ the columns of the view may be specified using the COLUMN-LIST
 parameter. The WITH-CHECK-OPTION is nil by default but if it has
 a non-nil value, then all insert/update commands on the view are
 checked to ensure that the new data satisfy the query AS."
 parameter. The WITH-CHECK-OPTION is nil by default but if it has
 a non-nil value, then all insert/update commands on the view are
 checked to ensure that the new data satisfy the query AS."

-  (let* ((view-name (etypecase name 
-                      (symbol (sql-expression :attribute name))
-                      (string (sql-expression :attribute (make-symbol name)))
-                      (sql-ident name)))
+  (let* ((view-name (database-identifier name))

          (stmt (make-instance 'sql-create-view
                               :name view-name
                               :column-list column-list
          (stmt (make-instance 'sql-create-view
                               :name view-name
                               :column-list column-list


@@ -126,15 +136,14 @@ checked to ensure that the new data satisfy the query AS."
 *DEFAULT-DATABASE*. If the view does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas
 an error is signalled if IF-DOES-NOT-EXIST is :error."
 *DEFAULT-DATABASE*. If the view does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas
 an error is signalled if IF-DOES-NOT-EXIST is :error."

-  (let ((view-name (database-identifier name database)))

     (ecase if-does-not-exist
       (:ignore
     (ecase if-does-not-exist
       (:ignore

-       (unless (view-exists-p view-name :database database)
+       (unless (view-exists-p name :database database)

          (return-from drop-view)))
       (:error
        t))
          (return-from drop-view)))
       (:error
        t))

-    (let ((expr (concatenate 'string "DROP VIEW " view-name)))
-      (execute-command expr :database database))))
+    (let ((expr (concatenate 'string "DROP VIEW " (escaped-database-identifier name database))))
+      (execute-command expr :database database)))

 
 (defun list-views (&key (owner nil) (database *default-database*))
   "Returns a list of strings representing view names in DATABASE
 
 (defun list-views (&key (owner nil) (database *default-database*))
   "Returns a list of strings representing view names in DATABASE


@@ -152,11 +161,11 @@ is a string denoting a user name, only views owned by OWNER are
 examined. If OWNER is :all then all views are examined."
   (when (member (database-identifier name database)
                 (list-views :owner owner :database database)
 examined. If OWNER is :all then all views are examined."
   (when (member (database-identifier name database)
                 (list-views :owner owner :database database)

-                :test #'string-equal)
+                :test #'database-identifier-equal)

     t))
 
 
     t))
 
 

-;; Indexes 
+;; Indexes

 
 (defun create-index (name &key on (unique nil) attributes
                           (database *default-database*))
 
 (defun create-index (name &key on (unique nil) attributes
                           (database *default-database*))


@@ -166,9 +175,10 @@ attributes to use in constructing the index NAME are specified by
 ATTRIBUTES. The UNIQUE argument is nil by default but if it has a
 non-nil value then the indexed attributes must have unique
 values."
 ATTRIBUTES. The UNIQUE argument is nil by default but if it has a
 non-nil value then the indexed attributes must have unique
 values."

-  (let* ((index-name (database-identifier name database))
-         (table-name (database-identifier on database))
-         (attributes (mapcar #'(lambda (a) (database-identifier a database)) (listify attributes)))
+  (let* ((index-name (escaped-database-identifier name database))
+         (table-name (escaped-database-identifier on database))
+         (attributes (mapcar #'(lambda (a) (escaped-database-identifier a database))
+                             (listify attributes)))

          (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
                        (if unique "UNIQUE" "")
                        index-name table-name attributes)))
          (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
                        (if unique "UNIQUE" "")
                        index-name table-name attributes)))


@@ -183,19 +193,21 @@ IF-DOES-NOT-EXIST is :ignore then DROP-INDEX returns nil whereas
 an error is signalled if IF-DOES-NOT-EXIST is :error. The
 argument ON allows the optional specification of a table to drop
 the index from."
 an error is signalled if IF-DOES-NOT-EXIST is :error. The
 argument ON allows the optional specification of a table to drop
 the index from."

-  (let ((index-name (database-identifier name database)))
-    (ecase if-does-not-exist
-      (:ignore
-       (unless (index-exists-p index-name :database database)
-         (return-from drop-index)))
-      (:error t))
-    (unless (db-type-use-column-on-drop-index? 
-            (database-underlying-type database))
-      (setq on nil))
-    (execute-command (format nil "DROP INDEX ~A~A" index-name
-                             (if (null on) ""
-                                 (concatenate 'string " ON "
-                                              (database-identifier on database))))
+  (ecase if-does-not-exist
+    (:ignore
+     (unless (index-exists-p name :database database)
+       (return-from drop-index)))
+    (:error t))
+  (let* ((db-type (database-underlying-type database))
+         (on (when on (escaped-database-identifier on database)))
+         (index-name (escaped-database-identifier name database))
+         (index-identifier
+           (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
+                  (format nil "~A.~A"  on index-name))
+                 ((db-type-use-column-on-drop-index? db-type)
+                  (format nil "~A ON ~A" index-name on))
+                 (t index-name))))
+    (execute-command (format nil "DROP INDEX ~A" index-identifier)

                      :database database)))
 
 (defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
                      :database database)))
 
 (defun list-indexes (&key (owner nil) (database *default-database*) (on nil))


@@ -209,15 +221,17 @@ tables. Meaningful values for ON are nil (the default) which
 means that all tables are considered, a string, symbol or SQL
 expression representing a table name in DATABASE or a list of
 such table identifiers."
 means that all tables are considered, a string, symbol or SQL
 expression representing a table name in DATABASE or a list of
 such table identifiers."

-  (if (null on) 
+  (if (null on)

       (database-list-indexes database :owner owner)
       (database-list-indexes database :owner owner)

-      (let ((tables (typecase on (cons on) (t (list on)))))
-        (reduce #'append 
-                (mapcar #'(lambda (table) (database-list-table-indexes 
-                                           (database-identifier table database)
-                                           database :owner owner))
-                        tables)))))
-  
+      (let ((tables (typecase on
+                      (cons on)
+                      (t (list on)))))
+        (reduce
+         #'append
+         (mapcar #'(lambda (table)
+                     (database-list-table-indexes table database :owner owner))
+                 tables)))))
+

 (defun index-exists-p (name &key (owner nil) (database *default-database*))
   "Tests for the existence of an SQL index called NAME in DATABASE
 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 (defun index-exists-p (name &key (owner nil) (database *default-database*))
   "Tests for the existence of an SQL index called NAME in DATABASE
 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default


@@ -227,12 +241,12 @@ OWNER are examined. If OWNER is :all then all indexes are
 examined."
   (when (member (database-identifier name database)
                 (list-indexes :owner owner :database database)
 examined."
   (when (member (database-identifier name database)
                 (list-indexes :owner owner :database database)

-                :test #'string-equal)
+                :test #'database-identifier-equal)

     t))
 
     t))
 

-;; Attributes 
+;; Attributes

 
 

-(defvar *cache-table-queries-default* nil 
+(defvar *cache-table-queries-default* nil

   "Specifies the default behaivour for caching of attribute
   types. Meaningful values are t, nil and :flush as described for
   the action argument to CACHE-TABLE-QUERIES.")
   "Specifies the default behaivour for caching of attribute
   types. Meaningful values are t, nil and :flush as described for
   the action argument to CACHE-TABLE-QUERIES.")


@@ -255,38 +269,38 @@ caching action has not been explicitly set."
     (cond
       ((stringp table)
        (multiple-value-bind (val found) (gethash table attribute-cache)
     (cond
       ((stringp table)
        (multiple-value-bind (val found) (gethash table attribute-cache)

-        (cond
-          ((and found (eq action :flush))
-           (setf (gethash table attribute-cache) (list t nil)))
-          ((and found (eq action t))
-           (setf (gethash table attribute-cache) (list t (second val))))
-          ((and found (null action))
-           (setf (gethash table attribute-cache) (list nil nil)))
-          ((not found)
-           (setf (gethash table attribute-cache) (list action nil))))))
+         (cond
+           ((and found (eq action :flush))
+            (setf (gethash table attribute-cache) (list t nil)))
+           ((and found (eq action t))
+            (setf (gethash table attribute-cache) (list t (second val))))
+           ((and found (null action))
+            (setf (gethash table attribute-cache) (list nil nil)))
+           ((not found)
+            (setf (gethash table attribute-cache) (list action nil))))))

       ((eq table t)
        (maphash (lambda (k v)
       ((eq table t)
        (maphash (lambda (k v)

-                 (cond
-                   ((eq action :flush)
-                    (setf (gethash k attribute-cache) (list t nil)))
-                   ((null action)
-                    (setf (gethash k attribute-cache) (list nil nil)))
-                   ((eq t action)
-                    (setf (gethash k attribute-cache) (list t (second v))))))
-               attribute-cache))
+                  (cond
+                    ((eq action :flush)
+                     (setf (gethash k attribute-cache) (list t nil)))
+                    ((null action)
+                     (setf (gethash k attribute-cache) (list nil nil)))
+                    ((eq t action)
+                     (setf (gethash k attribute-cache) (list t (second v))))))
+                attribute-cache))

       ((eq table :default)
        (maphash (lambda (k v)
       ((eq table :default)
        (maphash (lambda (k v)

-                 (when (eq (first v) :unspecified)
-                   (cond
-                     ((eq action :flush)
-                      (setf (gethash k attribute-cache) (list t nil)))
-                     ((null action)
-                      (setf (gethash k attribute-cache) (list nil nil)))
-                     ((eq t action)
-                      (setf (gethash k attribute-cache) (list t (second v)))))))
-               attribute-cache))))
+                  (when (eq (first v) :unspecified)
+                    (cond
+                      ((eq action :flush)
+                       (setf (gethash k attribute-cache) (list t nil)))
+                      ((null action)
+                       (setf (gethash k attribute-cache) (list nil nil)))
+                      ((eq t action)
+                       (setf (gethash k attribute-cache) (list t (second v)))))))
+                attribute-cache))))

   (values))
   (values))

-                 
+

 
 (defun list-attributes (name &key (owner nil) (database *default-database*))
   "Returns a list of strings representing the attributes of table
 
 (defun list-attributes (name &key (owner nil) (database *default-database*))
   "Returns a list of strings representing the attributes of table


@@ -295,7 +309,7 @@ nil by default which means that only attributes owned by users
 are listed. If OWNER is a string denoting a user name, only
 attributes owned by OWNER are listed. If OWNER is :all then all
 attributes are listed."
 are listed. If OWNER is a string denoting a user name, only
 attributes owned by OWNER are listed. If OWNER is :all then all
 attributes are listed."

-  (database-list-attributes (database-identifier name database) database 
+  (database-list-attributes (escaped-database-identifier name database) database

                             :owner owner))
 
 (defun attribute-type (attribute table &key (owner nil)
                             :owner owner))
 
 (defun attribute-type (attribute table &key (owner nil)


@@ -309,8 +323,8 @@ returned. If OWNER is a string denoting a user name, the
 attribute, if it exists, must be owned by OWNER else nil is
 returned, whereas if OWNER is :all then the attribute, if it
 exists, will be returned regardless of its owner."
 attribute, if it exists, must be owned by OWNER else nil is
 returned, whereas if OWNER is :all then the attribute, if it
 exists, will be returned regardless of its owner."

-  (database-attribute-type (database-identifier attribute database)
-                           (database-identifier table database)
+  (database-attribute-type (escaped-database-identifier attribute database)
+                           (escaped-database-identifier table database)

                            database
                            :owner owner))
 
                            database
                            :owner owner))
 


@@ -328,32 +342,32 @@ second element is its SQL type, the third is the type precision,
 the fourth is the scale of the attribute and the fifth is 1 if
 the attribute accepts null values and otherwise 0."
   (with-slots (attribute-cache) database
 the fourth is the scale of the attribute and the fifth is 1 if
 the attribute accepts null values and otherwise 0."
   (with-slots (attribute-cache) database

-    (let ((table-ident (database-identifier table database)))
+    (let ((table-ident (escaped-database-identifier table database)))

       (multiple-value-bind (val found) (gethash table-ident attribute-cache)
       (multiple-value-bind (val found) (gethash table-ident attribute-cache)

-       (if (and found (second val))
-           (second val)
-           (let ((types (mapcar #'(lambda (attribute)
-                                    (cons attribute
-                                          (multiple-value-list
-                                           (database-attribute-type
-                                            (database-identifier attribute 
+        (if (and found (second val))
+            (second val)
+            (let ((types (mapcar #'(lambda (attribute)
+                                     (cons attribute
+                                           (multiple-value-list
+                                            (database-attribute-type
+                                             (escaped-database-identifier attribute

                                                                   database)
                                                                   database)

-                                            table-ident
-                                            database
-                                            :owner owner))))
-                                (list-attributes table :database database 
+                                             table-ident
+                                             database
+                                             :owner owner))))
+                                 (list-attributes table :database database

                                                   :owner owner))))
                                                   :owner owner))))

-             (cond
-               ((and (not found) (eq t *cache-table-queries-default*))
-                (setf (gethash table-ident attribute-cache) 
+              (cond
+                ((and (not found) (eq t *cache-table-queries-default*))
+                 (setf (gethash table-ident attribute-cache)

                        (list :unspecified types)))
                        (list :unspecified types)))

-               ((and found (eq t (first val)) 
-                     (setf (gethash table-ident attribute-cache) 
+                ((and found (eq t (first val))
+                      (setf (gethash table-ident attribute-cache)

                             (list t types)))))
                             (list t types)))))

-             types))))))
-  
+              types))))))

 
 

-;; Sequences 
+
+;; Sequences

 
 (defun create-sequence (name &key (database *default-database*))
   "Creates a sequence called NAME in DATABASE which defaults to
 
 (defun create-sequence (name &key (database *default-database*))
   "Creates a sequence called NAME in DATABASE which defaults to


@@ -368,13 +382,12 @@ the attribute accepts null values and otherwise 0."
 *DEFAULT-DATABASE*. If the sequence does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil
 whereas an error is signalled if IF-DOES-NOT-EXIST is :error."
 *DEFAULT-DATABASE*. If the sequence does not exist and
 IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil
 whereas an error is signalled if IF-DOES-NOT-EXIST is :error."

-  (let ((sequence-name (database-identifier name database)))
-    (ecase if-does-not-exist
-      (:ignore
-       (unless (sequence-exists-p sequence-name :database database)
-         (return-from drop-sequence)))
-      (:error t))
-    (database-drop-sequence sequence-name database))
+  (ecase if-does-not-exist
+    (:ignore
+     (unless (sequence-exists-p name :database database)
+       (return-from drop-sequence)))
+    (:error t))
+  (database-drop-sequence name database)

   (values))
 
 (defun list-sequences (&key (owner nil) (database *default-database*))
   (values))
 
 (defun list-sequences (&key (owner nil) (database *default-database*))


@@ -394,11 +407,14 @@ default which means that only sequences owned by users are
 examined. If OWNER is a string denoting a user name, only
 sequences owned by OWNER are examined. If OWNER is :all then all
 sequences are examined."
 examined. If OWNER is a string denoting a user name, only
 sequences owned by OWNER are examined. If OWNER is :all then all
 sequences are examined."

-  (when (member (database-identifier name database)
-                (list-sequences :owner owner :database database)
-                :test #'string-equal)
-    t))
-  
+  (let ((seqs (list-sequences :owner owner :database database))
+        ;; handle symbols, we know the db will return strings
+        (n1 (database-identifier name database))
+        (n2 (%sequence-name-to-table name database)))
+    (when (or (member n1 seqs :test #'database-identifier-equal)
+              (member n2 seqs :test #'database-identifier-equal))
+      t)))
+

 (defun sequence-next (name &key (database *default-database*))
   "Increment and return the next value in the sequence called
   NAME in DATABASE which defaults to *DEFAULT-DATABASE*."
 (defun sequence-next (name &key (database *default-database*))
   "Increment and return the next value in the sequence called
   NAME in DATABASE which defaults to *DEFAULT-DATABASE*."


@@ -406,9 +422,9 @@ sequences are examined."
 
 (defun set-sequence-position (name position &key (database *default-database*))
   "Explicitly set the the position of the sequence called NAME in
 
 (defun set-sequence-position (name position &key (database *default-database*))
   "Explicitly set the the position of the sequence called NAME in

-DATABASE, which defaults to *DEFAULT-DATABSE*, to POSITION which
+DATABASE, which defaults to *DEFAULT-DATABASE*, to POSITION which

 is returned."
 is returned."

-  (database-set-sequence-position (database-identifier name database) 
+  (database-set-sequence-position (database-identifier name database)

                                   position database))
 
 (defun sequence-last (name &key (database *default-database*))
                                   position database))
 
 (defun sequence-last (name &key (database *default-database*))