base/basic-sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;  $Id: $
   4
   5 (in-package #:clsql-base-sys)
   6
   7 ;;; Query
   8
   9 (defgeneric query (query-expression &key database result-types flatp)
  10   (:documentation
  11    "Execute the SQL query expression QUERY-EXPRESSION on the given
  12 DATABASE which defaults to *default-database*. RESULT-TYPES is a list
  13 of symbols such as :string and :integer, one for each field in the
  14 query, which are used to specify the types to return. The FLATP
  15 argument, which has a default value of nil, specifies if full
  16 bracketed results should be returned for each matched entry. If FLATP
  17 is nil, the results are returned as a list of lists. If FLATP is t,
  18 the results are returned as elements of a list, only if there is only
  19 one result per row. Returns a list of lists of values of the result of
  20 that expression and a list of field names selected in sql-exp."))
  21
  22 (defmethod query ((query-expression string) &key (database *default-database*)
  23                   (result-types nil) (flatp nil))
  24   (record-sql-command query-expression database)
  25   (let* ((res (database-query query-expression database result-types))
  26          (res (if (and flatp (= (length
  27                                  (slot-value query-expression 'selections))
  28                                 1))
  29                   (mapcar #'car res)
  30                   res)))
  31     (record-sql-result res database)
  32     res))
  33
  34 ;;; Execute
  35
  36 (defgeneric execute-command (expression &key database)
  37   (:documentation
  38    "Executes the SQL command specified by EXPRESSION for the database
  39 specified by DATABASE, which has a default value of
  40 *DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement
  41 other than a query. To run a stored procedure, pass an appropriate
  42 string. The call to the procedure needs to be wrapped in a BEGIN END
  43 pair."))
  44
  45 (defmethod execute-command ((sql-expression string)
  46                             &key (database *default-database*))
  47   (record-sql-command sql-expression database)
  48   (let ((res (database-execute-command sql-expression database)))
  49     (record-sql-result res database))
  50   (values))
  51
  52
  53 (defmacro do-query (((&rest args) query-expression
  54                      &key (database '*default-database*) (types nil))
  55                     &body body)
  56   "Repeatedly executes BODY within a binding of ARGS on the attributes
  57 of each record resulting from QUERY. The return value is determined by
  58 the result of executing BODY. The default value of DATABASE is
  59 *DEFAULT-DATABASE*."
  60   (let ((result-set (gensym))
  61         (columns (gensym))
  62         (row (gensym))
  63         (db (gensym)))
  64     `(let ((,db ,database))
  65       (multiple-value-bind (,result-set ,columns)
  66           (database-query-result-set ,query-expression ,db
  67                                      :full-set nil :types ,types)
  68         (when ,result-set
  69           (unwind-protect
  70                (do ((,row (make-list ,columns)))
  71                    ((not (database-store-next-row ,result-set ,db ,row))
  72                     nil)
  73                  (destructuring-bind ,args ,row
  74                    ,@body))
  75             (database-dump-result-set ,result-set ,db)))))))
  76
  77 (defun map-query (output-type-spec function query-expression
  78                   &key (database *default-database*)
  79                   (types nil))
  80   "Map the function over all tuples that are returned by the query in
  81 query-expression.  The results of the function are collected as
  82 specified in output-type-spec and returned like in MAP."
  83   (macrolet ((type-specifier-atom (type)
  84                `(if (atom ,type) ,type (car ,type))))
  85     (case (type-specifier-atom output-type-spec)
  86       ((nil)
  87        (map-query-for-effect function query-expression database types))
  88       (list
  89        (map-query-to-list function query-expression database types))
  90       ((simple-vector simple-string vector string array simple-array
  91         bit-vector simple-bit-vector base-string
  92         simple-base-string)
  93        (map-query-to-simple output-type-spec function query-expression database types))
  94       (t
  95        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
  96               function query-expression :database database :types types)))))
  97
  98 (defun map-query-for-effect (function query-expression database types)
  99   (multiple-value-bind (result-set columns)
 100       (database-query-result-set query-expression database :full-set nil
 101                                  :types types)
 102     (when result-set
 103       (unwind-protect
 104            (do ((row (make-list columns)))
 105                ((not (database-store-next-row result-set database row))
 106                 nil)
 107              (apply function row))
 108         (database-dump-result-set result-set database)))))
 109
 110 (defun map-query-to-list (function query-expression database types)
 111   (multiple-value-bind (result-set columns)
 112       (database-query-result-set query-expression database :full-set nil
 113                                  :types types)
 114     (when result-set
 115       (unwind-protect
 116            (let ((result (list nil)))
 117              (do ((row (make-list columns))
 118                   (current-cons result (cdr current-cons)))
 119                  ((not (database-store-next-row result-set database row))
 120                   (cdr result))
 121                (rplacd current-cons (list (apply function row)))))
 122         (database-dump-result-set result-set database)))))
 123
 124
 125 (defun map-query-to-simple (output-type-spec function query-expression database types)
 126   (multiple-value-bind (result-set columns rows)
 127       (database-query-result-set query-expression database :full-set t
 128                                  :types types)
 129     (when result-set
 130       (unwind-protect
 131            (if rows
 132                ;; We know the row count in advance, so we allocate once
 133                (do ((result
 134                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 135                     (row (make-list columns))
 136                     (index 0 (1+ index)))
 137                    ((not (database-store-next-row result-set database row))
 138                     result)
 139                  (declare (fixnum index))
 140                  (setf (aref result index)
 141                        (apply function row)))
 142                ;; Database can't report row count in advance, so we have
 143                ;; to grow and shrink our vector dynamically
 144                (do ((result
 145                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 146                     (allocated-length 100)
 147                     (row (make-list columns))
 148                     (index 0 (1+ index)))
 149                    ((not (database-store-next-row result-set database row))
 150                     (cmucl-compat:shrink-vector result index))
 151                  (declare (fixnum allocated-length index))
 152                  (when (>= index allocated-length)
 153                    (setq allocated-length (* allocated-length 2)
 154                          result (adjust-array result allocated-length)))
 155                  (setf (aref result index)
 156                        (apply function row))))
 157         (database-dump-result-set result-set database)))))
 158
 159
 160