base/basic-sql.lisp

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