postmodern/query.lisp

   1 (in-package :postmodern)
   2
   3 ;; Like alist-row-reader from cl-postgres, but converts the field
   4 ;; names to keywords (with underscores converted to dashes).
   5 (def-row-reader symbol-alist-row-reader (fields)
   6   (let ((symbols (map 'list (lambda (desc) (from-sql-name (field-name desc))) fields)))
   7     (loop :while (next-row)
   8           :collect (loop :for field :across fields
   9                          :for symbol :in symbols
  10                          :collect (cons symbol (next-field field))))))
  11
  12 ;; Like symbol-alist-row-reader, but return plist
  13 (def-row-reader symbol-plist-row-reader (fields)
  14   (let ((symbols (map 'list (lambda (desc) (from-sql-name (field-name desc))) fields)))
  15     (loop :while (next-row)
  16           :collect (loop :for field :across fields
  17                          :for symbol :in symbols
  18                          :collect symbol :collect (next-field field)))))
  19
  20 ;; A row-reader for reading only a single column, and returning a list
  21 ;; of single values.
  22 (def-row-reader column-row-reader (fields)
  23   (assert (= (length fields) 1))
  24   (loop :while (next-row)
  25         :collect (next-field (elt fields 0))))
  26
  27 (defparameter *result-styles*
  28   '((:none ignore-row-reader all-rows)
  29     (:lists list-row-reader all-rows)
  30     (:list list-row-reader single-row)
  31     (:rows list-row-reader all-rows)
  32     (:row list-row-reader single-row)
  33     (:alists symbol-alist-row-reader all-rows)
  34     (:alist symbol-alist-row-reader single-row)
  35     (:str-alists alist-row-reader all-rows)
  36     (:str-alist alist-row-reader single-row)
  37     (:plists symbol-plist-row-reader all-rows)
  38     (:plist symbol-plist-row-reader single-row)
  39     (:column column-row-reader all-rows)
  40     (:single column-row-reader single-row)
  41     (:single! column-row-reader single-row!))
  42   "Mapping from keywords identifying result styles to the row-reader
  43 that should be used and whether all values or only one value should be
  44 returned.")
  45
  46 (defun dao-spec-for-format (format)
  47   (if (and (consp format)
  48            (eq :dao (car format)))
  49       (cdr format)))
  50
  51 (defun reader-for-format (format)
  52   (let ((format-spec (cdr (assoc format *result-styles*))))
  53     (if format-spec
  54         `(',(car format-spec) ,@(cdr format-spec))
  55         (destructuring-bind (class &optional result)
  56             (dao-spec-for-format format)
  57           (unless class
  58             (error "~S is not a valid result style." format))
  59           (let ((class-name (gensym)))
  60             (list `(let ((,class-name (find-class ',class)))
  61                      (unless (class-finalized-p ,class-name)
  62                        (finalize-inheritance ,class-name))
  63                      (dao-row-reader ,class-name))
  64                   (if (eq result :single)
  65                       'single-row
  66                       'all-rows)))))))
  67
  68 (defmacro all-rows (form)
  69   form)
  70
  71 (defmacro single-row (form)
  72   `(multiple-value-bind (rows affected) ,form
  73     (if affected (values (car rows) affected) (car rows))))
  74
  75 (defmacro single-row! (form)
  76   `(multiple-value-bind (rows affected) ,form
  77     (unless (= (length rows) 1)
  78       (error 'database-error :message (format nil "Query for a single row returned ~a rows." (length rows))))
  79     (if affected (values (car rows) affected) (car rows))))
  80
  81 (defun real-query (query)
  82   "Used for supporting both plain string queries and S-SQL constructs.
  83 Looks at the argument at compile-time and wraps it in (sql ...) if it
  84 looks like an S-SQL query."
  85   (if (and (consp query) (keywordp (first query)))
  86       `(sql ,query)
  87       query))
  88
  89 (defmacro query (query &rest args/format)
  90   "Execute a query, optionally with arguments to put in the place of
  91 $X elements. If one of the arguments is a known result style or a class name,
  92 it specifies the format in which the results should be returned."
  93   (let* ((format :rows)
  94          (args (loop :for arg :in args/format
  95                      :if (or (dao-spec-for-format arg)
  96                              (assoc arg *result-styles*)) :do (setf format arg)
  97                      :else :collect arg)))
  98     (destructuring-bind (reader result-form) (reader-for-format format)
  99       (let ((base (if args
 100                       `(progn
 101                         (prepare-query *database* "" ,(real-query query))
 102                         (exec-prepared *database* "" (list ,@args) ,reader))
 103                       `(exec-query *database* ,(real-query query) ,reader))))
 104         `(,result-form ,base)))))
 105
 106 (defmacro execute (query &rest args)
 107   "Execute a query, ignore the results."
 108   `(let ((rows (nth-value 1 (query ,query ,@args :none))))
 109     (if rows (values rows rows) 0)))
 110
 111 (defmacro doquery (query (&rest names) &body body)
 112  "Iterate over the rows in the result of a query, binding the given
 113 names to the results and executing body for every row. Query can be a
 114 string, an s-sql query, or a list starting with one of those, followed
 115 by the arguments to parameterize the query with."
 116  (let* ((fields (gensym))
 117         (query-name (gensym))
 118         args
 119         (reader-expr
 120           `(row-reader (,fields)
 121              (unless (= ,(length names) (length ,fields))
 122                (error "Number of field names does not match number of selected fields in query ~A." ,query-name))
 123              (loop :while (next-row)
 124                    :do (let ,(loop :for i :from 0
 125                                    :for name :in names
 126                                    :collect `(,name (next-field (elt ,fields ,i))))
 127                          ,@body)))))
 128    (when (and (consp query) (not (keywordp (first query))))
 129      (setf args (cdr query) query (car query)))
 130    (if args
 131        `(let ((,query-name ,(real-query query)))
 132           (prepare-query *database* "" ,query-name)
 133           (exec-prepared *database* "" (list ,@args) ,reader-expr))
 134        `(let ((,query-name ,(real-query query)))
 135           (exec-query *database* ,query-name ,reader-expr)))))