Automated commit for debian release 6.7.2-1

[clsql.git] / sql / fdml.lisp

diff --git a/sql/fdml.lisp b/sql/fdml.lisp
index 34062620389844cb3bf61ba93650db782b6b2db5..5e248ced0547c0eb66895d820493023b4f032f7b 100644 (file)
--- a/sql/fdml.lisp
+++ b/sql/fdml.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 Manipulation Language (FDML).
 ;;;;
 ;;;; This file is part of CLSQL.
 ;;;; The CLSQL Functional Data Manipulation Language (FDML).
 ;;;;
 ;;;; This file is part of CLSQL.


@@ -14,6 +12,33 @@
 
 (in-package #:clsql-sys)
 
 
 (in-package #:clsql-sys)
 

+;; some helpers to make dealing with attribute-value-pairs a bit more structured
+(defclass attribute-value-pair ()
+  ((attribute :accessor attribute :initarg :attribute :initform nil)
+   (db-value :accessor db-value :initarg :db-value :initform nil))
+  (:documentation "Represents an attribute-sql-expression and its value, used
+   to pass to insert/update. Was previously a two list"))
+
+(defun make-attribute-value-pair (slot-def value database)
+  (check-slot-type slot-def value)
+  (make-instance
+   'attribute-value-pair
+   :attribute (sql-expression :attribute (database-identifier slot-def database))
+   :db-value (db-value-from-slot slot-def value database)))
+
+(defun to-attributes-and-values (av-pairs)
+  (etypecase (first av-pairs)
+    (list
+     (loop for (a v) in av-pairs
+           collect a into attributes
+           collect v into db-values
+           finally (return (values attributes db-values))))
+    (attribute-value-pair
+     (loop for pair in av-pairs
+           collecting (attribute pair) into attributes
+           collecting (db-value pair) into db-values
+           finally (return (values attributes db-values))))))
+

 ;;; Basic operations on databases
 
 (defmethod database-query-result-set ((expr %sql-expression) database
 ;;; Basic operations on databases
 
 (defmethod database-query-result-set ((expr %sql-expression) database


@@ -112,50 +137,59 @@ used."
                             (database *default-database*))
   "Inserts records into the table specified by INTO in DATABASE
 which defaults to *DEFAULT-DATABASE*. There are five ways of
                             (database *default-database*))
   "Inserts records into the table specified by INTO in DATABASE
 which defaults to *DEFAULT-DATABASE*. There are five ways of

-specifying the values inserted into each row. In the first VALUES
-contains a list of values to insert and ATTRIBUTES, AV-PAIRS and
-QUERY are nil. This can be used when values are supplied for all
-attributes in INTO. In the second, ATTRIBUTES is a list of column
-names, VALUES is a corresponding list of values and AV-PAIRS and
-QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil
-and AV-PAIRS is an alist of (attribute value) pairs. In the
-fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a
-symbolic SQL query expression in which the selected columns also
-exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil
-and ATTRIBUTES is a list of column names and QUERY is a symbolic
-SQL query expression which returns values for the specified
-columns."
+specifying the values inserted into each row.
+
+In the first VALUES contains a list of values to insert and ATTRIBUTES,
+AV-PAIRS and QUERY are nil. This can be used when values are supplied for all
+attributes in INTO.
+
+In the second, ATTRIBUTES is a list of column names, VALUES is a corresponding
+list of values and AV-PAIRS and QUERY are nil.
+
+In the third, ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is a list
+of (attribute value) pairs, or attribute-value-pair objects.
+
+In the fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a symbolic
+SQL query expression in which the selected columns also exist in INTO.
+
+In the fifth method, VALUES and AV-PAIRS are nil and ATTRIBUTES is a list of
+column names and QUERY is a symbolic SQL query expression which returns values
+for the specified columns."

   (let ((stmt (make-sql-insert :into into :attrs attributes
                                :vals values :av-pairs av-pairs
                                :subquery query)))
     (execute-command stmt :database database)))
 
 (defun make-sql-insert (&key (into nil)
   (let ((stmt (make-sql-insert :into into :attrs attributes
                                :vals values :av-pairs av-pairs
                                :subquery query)))
     (execute-command stmt :database database)))
 
 (defun make-sql-insert (&key (into nil)

-                            (attrs nil)
-                            (vals nil)
-                            (av-pairs nil)
-                            (subquery nil))
+                        (attrs nil)
+                        (vals nil)
+                        (av-pairs nil)
+                        (subquery nil))

   (unless into
   (unless into

-      (error 'sql-user-error :message ":into keyword not supplied"))
-  (let ((insert (make-instance 'sql-insert :into into)))
-    (with-slots (attributes values query)
-      insert
+    (error 'sql-user-error :message ":into keyword not supplied"))
+  (let ((insert (make-instance 'sql-insert :into (database-identifier into nil))))
+    (with-slots (attributes values query) insert
+

       (cond ((and vals (not attrs) (not query) (not av-pairs))
              (setf values vals))
       (cond ((and vals (not attrs) (not query) (not av-pairs))
              (setf values vals))

+

             ((and vals attrs (not subquery) (not av-pairs))
              (setf attributes attrs)
              (setf values vals))
             ((and vals attrs (not subquery) (not av-pairs))
              (setf attributes attrs)
              (setf values vals))

+

             ((and av-pairs (not vals) (not attrs) (not subquery))
             ((and av-pairs (not vals) (not attrs) (not subquery))

-             (setf attributes (mapcar #'car av-pairs))
-             (setf values (mapcar #'cadr av-pairs)))
+             (multiple-value-setq (attributes values)
+               (to-attributes-and-values av-pairs)))
+

             ((and subquery (not vals) (not attrs) (not av-pairs))
              (setf query subquery))
             ((and subquery (not vals) (not attrs) (not av-pairs))
              (setf query subquery))

+

             ((and subquery attrs (not vals) (not av-pairs))
              (setf attributes attrs)
              (setf query subquery))
             ((and subquery attrs (not vals) (not av-pairs))
              (setf attributes attrs)
              (setf query subquery))

-            (t
-             (error 'sql-user-error
-                    :message "bad or ambiguous keyword combination.")))
+
+            (t (error 'sql-user-error
+                      :message "bad or ambiguous keyword combination.")))

       insert)))
 
 (defun delete-records (&key (from nil)
       insert)))
 
 (defun delete-records (&key (from nil)


@@ -164,7 +198,7 @@ columns."
   "Deletes records satisfying the SQL expression WHERE from the
 table specified by FROM in DATABASE specifies a database which
 defaults to *DEFAULT-DATABASE*."
   "Deletes records satisfying the SQL expression WHERE from the
 table specified by FROM in DATABASE specifies a database which
 defaults to *DEFAULT-DATABASE*."

-  (let ((stmt (make-instance 'sql-delete :from from :where where)))
+  (let ((stmt (make-instance 'sql-delete :from (database-identifier from database) :where where)))

     (execute-command stmt :database database)))
 
 (defun update-records (table &key (attributes nil)
     (execute-command stmt :database database)))
 
 (defun update-records (table &key (attributes nil)


@@ -183,9 +217,9 @@ is a list of column names, VALUES is a corresponding list of
 values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES
 are nil and AV-PAIRS is an alist of (attribute value) pairs."
   (when av-pairs
 values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES
 are nil and AV-PAIRS is an alist of (attribute value) pairs."
   (when av-pairs

-    (setf attributes (mapcar #'car av-pairs)
-          values (mapcar #'cadr av-pairs)))
-  (let ((stmt (make-instance 'sql-update :table table
+    (multiple-value-setq (attributes values)
+      (to-attributes-and-values av-pairs)))
+  (let ((stmt (make-instance 'sql-update :table (database-identifier table database)

                              :attributes attributes
                              :values values
                              :where where)))
                              :attributes attributes
                              :values values
                              :where where)))


@@ -210,29 +244,33 @@ types are automatically computed for each field."
         (qe (gensym "QUERY-EXPRESSION-"))
         (columns (gensym "COLUMNS-"))
         (row (gensym "ROW-"))
         (qe (gensym "QUERY-EXPRESSION-"))
         (columns (gensym "COLUMNS-"))
         (row (gensym "ROW-"))

-        (db (gensym "DB-")))
-    `(let ((,qe ,query-expression))
+        (db (gensym "DB-"))
+        (last-form-eval (gensym "LFE-")))
+    `(let ((,qe ,query-expression)
+           (,db ,database))

       (typecase ,qe
         (sql-object-query
       (typecase ,qe
         (sql-object-query

-         (dolist (,row (query ,qe))
+         (dolist (,row (query ,qe :database ,db))

            (destructuring-bind ,args
                ,row
              ,@body)))
         (t
          ;; Functional query
            (destructuring-bind ,args
                ,row
              ,@body)))
         (t
          ;; Functional query

-         (let ((,db ,database))
-           (multiple-value-bind (,result-set ,columns)
-               (database-query-result-set ,qe ,db
-                                          :full-set nil
+         (multiple-value-bind (,result-set ,columns)
+             (database-query-result-set ,qe ,db
+                                        :full-set nil

                                           :result-types ,result-types)
                                           :result-types ,result-types)

-             (when ,result-set
-               (unwind-protect
-                    (do ((,row (make-list ,columns)))
-                        ((not (database-store-next-row ,result-set ,db ,row))
-                         nil)
-                      (destructuring-bind ,args ,row
-                        ,@body))
-                 (database-dump-result-set ,result-set ,db))))))))))
+           (when ,result-set
+             (unwind-protect
+                  (do ((,row (make-list ,columns))
+                       (,last-form-eval nil))
+                      ((not (database-store-next-row ,result-set ,db ,row))
+                       ,last-form-eval)
+                    (destructuring-bind ,args ,row
+                      (setq ,last-form-eval
+                            (progn
+                              ,@body))))
+               (database-dump-result-set ,result-set ,db)))))))))

 
 (defun map-query (output-type-spec function query-expression
                   &key (database *default-database*)
 
 (defun map-query (output-type-spec function query-expression
                   &key (database *default-database*)