X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ffdml.lisp;h=5e248ced0547c0eb66895d820493023b4f032f7b;hp=34062620389844cb3bf61ba93650db782b6b2db5;hb=HEAD;hpb=e567409d9fff3f7231c2a0bb69b345e19de2b246;ds=sidebyside diff --git a/sql/fdml.lisp b/sql/fdml.lisp index 3406262..5e248ce 100644 --- a/sql/fdml.lisp +++ b/sql/fdml.lisp @@ -1,8 +1,6 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ -;;;; ;;;; The CLSQL Functional Data Manipulation Language (FDML). ;;;; ;;;; This file is part of CLSQL. @@ -14,6 +12,33 @@ (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 @@ -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 -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) - (attrs nil) - (vals nil) - (av-pairs nil) - (subquery nil)) + (attrs nil) + (vals nil) + (av-pairs nil) + (subquery nil)) (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)) + ((and vals attrs (not subquery) (not av-pairs)) (setf attributes attrs) (setf values vals)) + ((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 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) @@ -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*." - (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) @@ -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 - (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))) @@ -210,29 +244,33 @@ types are automatically computed for each field." (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 - (dolist (,row (query ,qe)) + (dolist (,row (query ,qe :database ,db)) (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) - (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*)