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)
  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 :auto) (flatp nil) (field-names t))
  34   (record-sql-action query-expression :query database)
  35   (multiple-value-bind (rows names) (database-query query-expression database result-types
  36                                                     field-names)
  37     (let ((result (if (and flatp (= 1 (length (car rows))))
  38                       (mapcar #'car rows)
  39                     rows)))
  40       (record-sql-action result :result database)
  41       (if field-names
  42           (values result names)
  43         result))))
  44
  45 ;;; Execute
  46
  47 (defgeneric execute-command (expression &key database)
  48   (:documentation
  49    "Executes the SQL command specified by EXPRESSION for the database
  50 specified by DATABASE, which has a default value of
  51 *DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement
  52 other than a query. To run a stored procedure, pass an appropriate
  53 string. The call to the procedure needs to be wrapped in a BEGIN END
  54 pair."))
  55
  56 (defmethod execute-command ((sql-expression string)
  57                             &key (database *default-database*))
  58   (record-sql-action sql-expression :command database)
  59   (let ((res (database-execute-command sql-expression database)))
  60     (record-sql-action res :result database))
  61   (values))
  62
  63 (defmacro do-query (((&rest args) query-expression
  64                      &key (database '*default-database*) (result-types :auto))
  65                     &body body)
  66   "Repeatedly executes BODY within a binding of ARGS on the
  67 attributes of each record resulting from QUERY-EXPRESSION. The
  68 return value is determined by the result of executing BODY. The
  69 default value of DATABASE is *DEFAULT-DATABASE*."
  70   (let ((result-set (gensym "RESULT-SET-"))
  71         (qe (gensym "QUERY-EXPRESSION-"))
  72         (columns (gensym "COLUMNS-"))
  73         (row (gensym "ROW-"))
  74         (db (gensym "DB-")))
  75     `(let ((,qe ,query-expression))
  76       (typecase ,qe
  77         (list
  78          ;; Object query
  79          (dolist (,row ,qe)
  80            (destructuring-bind ,args
  81                ,row
  82              ,@body)))
  83         (t
  84          ;; Functional query
  85          (let ((,db ,database))
  86            (multiple-value-bind (,result-set ,columns)
  87                (database-query-result-set ,qe ,db
  88                                           :full-set nil
  89                                           :result-types ,result-types)
  90              (when ,result-set
  91                (unwind-protect
  92                     (do ((,row (make-list ,columns)))
  93                         ((not (database-store-next-row ,result-set ,db ,row))
  94                          nil)
  95                       (destructuring-bind ,args ,row
  96                         ,@body))
  97                  (database-dump-result-set ,result-set ,db))))))))))
  98
  99 (defun map-query (output-type-spec function query-expression
 100                   &key (database *default-database*)
 101                   (result-types :auto))
 102   "Map the function over all tuples that are returned by the
 103 query in QUERY-EXPRESSION. The results of the function are
 104 collected as specified in OUTPUT-TYPE-SPEC and returned like in
 105 MAP."
 106   (if (listp query-expression)
 107       ;; Object query
 108       (map output-type-spec #'(lambda (x) (apply function x)) query-expression)
 109       ;; Functional query
 110       (macrolet ((type-specifier-atom (type)
 111                    `(if (atom ,type) ,type (car ,type))))
 112         (case (type-specifier-atom output-type-spec)
 113           ((nil)
 114            (map-query-for-effect function query-expression database
 115                                  result-types))
 116           (list
 117            (map-query-to-list function query-expression database result-types))
 118           ((simple-vector simple-string vector string array simple-array
 119                           bit-vector simple-bit-vector base-string
 120                           simple-base-string)
 121            (map-query-to-simple output-type-spec function query-expression
 122                                 database result-types))
 123           (t
 124            (funcall #'map-query
 125                     (cmucl-compat:result-type-or-lose output-type-spec t)
 126                     function query-expression :database database
 127                     :result-types result-types))))))
 128
 129 (defun map-query-for-effect (function query-expression database result-types)
 130   (multiple-value-bind (result-set columns)
 131       (database-query-result-set query-expression database :full-set nil
 132                                  :result-types result-types)
 133     (when result-set
 134       (unwind-protect
 135            (do ((row (make-list columns)))
 136                ((not (database-store-next-row result-set database row))
 137                 nil)
 138              (apply function row))
 139         (database-dump-result-set result-set database)))))
 140
 141 (defun map-query-to-list (function query-expression database result-types)
 142   (multiple-value-bind (result-set columns)
 143       (database-query-result-set query-expression database :full-set nil
 144                                  :result-types result-types)
 145     (when result-set
 146       (unwind-protect
 147            (let ((result (list nil)))
 148              (do ((row (make-list columns))
 149                   (current-cons result (cdr current-cons)))
 150                  ((not (database-store-next-row result-set database row))
 151                   (cdr result))
 152                (rplacd current-cons (list (apply function row)))))
 153         (database-dump-result-set result-set database)))))
 154
 155
 156 (defun map-query-to-simple (output-type-spec function query-expression database result-types)
 157   (multiple-value-bind (result-set columns rows)
 158       (database-query-result-set query-expression database :full-set t
 159                                  :result-types result-types)
 160     (when result-set
 161       (unwind-protect
 162            (if rows
 163                ;; We know the row count in advance, so we allocate once
 164                (do ((result
 165                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 166                     (row (make-list columns))
 167                     (index 0 (1+ index)))
 168                    ((not (database-store-next-row result-set database row))
 169                     result)
 170                  (declare (fixnum index))
 171                  (setf (aref result index)
 172                        (apply function row)))
 173                ;; Database can't report row count in advance, so we have
 174                ;; to grow and shrink our vector dynamically
 175                (do ((result
 176                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 177                     (allocated-length 100)
 178                     (row (make-list columns))
 179                     (index 0 (1+ index)))
 180                    ((not (database-store-next-row result-set database row))
 181                     (cmucl-compat:shrink-vector result index))
 182                  (declare (fixnum allocated-length index))
 183                  (when (>= index allocated-length)
 184                    (setq allocated-length (* allocated-length 2)
 185                          result (adjust-array result allocated-length)))
 186                  (setf (aref result index)
 187                        (apply function row))))
 188         (database-dump-result-set result-set database)))))
 189
 190 ;;; Large objects support
 191
 192 (defun create-large-object (&key (database *default-database*))
 193   "Creates a new large object in the database and returns the object identifier"
 194   (database-create-large-object database))
 195
 196 (defun write-large-object (object-id data &key (database *default-database*))
 197   "Writes data to the large object"
 198   (database-write-large-object object-id data database))
 199
 200 (defun read-large-object (object-id &key (database *default-database*))
 201   "Reads the large object content"
 202   (database-read-large-object object-id database))
 203
 204 (defun delete-large-object (object-id &key (database *default-database*))
 205   "Deletes the large object in the database"
 206   (database-delete-large-object object-id database))
 207