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))
  71         (columns (gensym))
  72         (row (gensym))
  73         (db (gensym)))
  74     `(if (listp ,query-expression)
  75          ;; Object query
  76          (dolist (,row ,query-expression)
  77            (destructuring-bind ,args
  78                ,row
  79              ,@body))
  80          ;; Functional query
  81          (let ((,db ,database))
  82            (multiple-value-bind (,result-set ,columns)
  83                (database-query-result-set ,query-expression ,db
  84                                           :full-set nil
  85                                           :result-types ,result-types)
  86              (when ,result-set
  87                (unwind-protect
  88                     (do ((,row (make-list ,columns)))
  89                         ((not (database-store-next-row ,result-set ,db ,row))
  90                          nil)
  91                       (destructuring-bind ,args ,row
  92                         ,@body))
  93                  (database-dump-result-set ,result-set ,db))))))))
  94
  95 (defun map-query (output-type-spec function query-expression
  96                   &key (database *default-database*)
  97                   (result-types :auto))
  98   "Map the function over all tuples that are returned by the
  99 query in QUERY-EXPRESSION. The results of the function are
 100 collected as specified in OUTPUT-TYPE-SPEC and returned like in
 101 MAP."
 102   (if (listp query-expression)
 103       ;; Object query
 104       (map output-type-spec #'(lambda (x) (apply function x)) query-expression)
 105       ;; Functional query
 106       (macrolet ((type-specifier-atom (type)
 107                    `(if (atom ,type) ,type (car ,type))))
 108         (case (type-specifier-atom output-type-spec)
 109           ((nil)
 110            (map-query-for-effect function query-expression database
 111                                  result-types))
 112           (list
 113            (map-query-to-list function query-expression database result-types))
 114           ((simple-vector simple-string vector string array simple-array
 115                           bit-vector simple-bit-vector base-string
 116                           simple-base-string)
 117            (map-query-to-simple output-type-spec function query-expression
 118                                 database result-types))
 119           (t
 120            (funcall #'map-query
 121                     (cmucl-compat:result-type-or-lose output-type-spec t)
 122                     function query-expression :database database
 123                     :result-types result-types))))))
 124
 125 (defun map-query-for-effect (function query-expression database result-types)
 126   (multiple-value-bind (result-set columns)
 127       (database-query-result-set query-expression database :full-set nil
 128                                  :result-types result-types)
 129     (when result-set
 130       (unwind-protect
 131            (do ((row (make-list columns)))
 132                ((not (database-store-next-row result-set database row))
 133                 nil)
 134              (apply function row))
 135         (database-dump-result-set result-set database)))))
 136
 137 (defun map-query-to-list (function query-expression database result-types)
 138   (multiple-value-bind (result-set columns)
 139       (database-query-result-set query-expression database :full-set nil
 140                                  :result-types result-types)
 141     (when result-set
 142       (unwind-protect
 143            (let ((result (list nil)))
 144              (do ((row (make-list columns))
 145                   (current-cons result (cdr current-cons)))
 146                  ((not (database-store-next-row result-set database row))
 147                   (cdr result))
 148                (rplacd current-cons (list (apply function row)))))
 149         (database-dump-result-set result-set database)))))
 150
 151
 152 (defun map-query-to-simple (output-type-spec function query-expression database result-types)
 153   (multiple-value-bind (result-set columns rows)
 154       (database-query-result-set query-expression database :full-set t
 155                                  :result-types result-types)
 156     (when result-set
 157       (unwind-protect
 158            (if rows
 159                ;; We know the row count in advance, so we allocate once
 160                (do ((result
 161                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 162                     (row (make-list columns))
 163                     (index 0 (1+ index)))
 164                    ((not (database-store-next-row result-set database row))
 165                     result)
 166                  (declare (fixnum index))
 167                  (setf (aref result index)
 168                        (apply function row)))
 169                ;; Database can't report row count in advance, so we have
 170                ;; to grow and shrink our vector dynamically
 171                (do ((result
 172                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 173                     (allocated-length 100)
 174                     (row (make-list columns))
 175                     (index 0 (1+ index)))
 176                    ((not (database-store-next-row result-set database row))
 177                     (cmucl-compat:shrink-vector result index))
 178                  (declare (fixnum allocated-length index))
 179                  (when (>= index allocated-length)
 180                    (setq allocated-length (* allocated-length 2)
 181                          result (adjust-array result allocated-length)))
 182                  (setf (aref result index)
 183                        (apply function row))))
 184         (database-dump-result-set result-set database)))))
 185
 186 ;;; Large objects support
 187
 188 (defun create-large-object (&key (database *default-database*))
 189   "Creates a new large object in the database and returns the object identifier"
 190   (database-create-large-object database))
 191
 192 (defun write-large-object (object-id data &key (database *default-database*))
 193   "Writes data to the large object"
 194   (database-write-large-object object-id data database))
 195
 196 (defun read-large-object (object-id &key (database *default-database*))
 197   "Reads the large object content"
 198   (database-read-large-object object-id database))
 199
 200 (defun delete-large-object (object-id &key (database *default-database*))
 201   "Deletes the large object in the database"
 202   (database-delete-large-object object-id database))
 203