sql/sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:         sql.cl
   6 ;;;; Purpose:      High-level SQL interface
   7 ;;;; Authors:      Kevin M. Rosenberg based on code by Pierre R. Mai
   8 ;;;; Date Started: Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (eval-when (:compile-toplevel)
  21   (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
  22
  23 (in-package #:clsql-sys)
  24
  25
  26 ;;; Database handling
  27
  28 (defvar *connect-if-exists* :error
  29   "Default value for the if-exists parameter of connect calls.")
  30
  31 (defvar *connected-databases* nil
  32   "List of active database objects.")
  33
  34 (defun connected-databases ()
  35   "Return the list of active database objects."
  36   *connected-databases*)
  37
  38 (defvar *default-database* nil
  39   "Specifies the default database to be used.")
  40
  41 (defun find-database (database &optional (errorp t))
  42   (etypecase database
  43     (database
  44      ;; Return the database object itself
  45      database)
  46     (string
  47      (or (find database (connected-databases)
  48                :key #'database-name
  49                :test #'string=)
  50          (when errorp
  51            (cerror "Return nil."
  52                    'clsql-simple-error
  53                    :format-control "There exists no database called ~A."
  54                    :format-arguments (list database)))))))
  55
  56 (defun connect (connection-spec
  57                 &key (if-exists *connect-if-exists*)
  58                 (database-type *default-database-type*)
  59                 (pool nil))
  60   "Connects to a database of the given database-type, using the type-specific
  61 connection-spec.
  62 If pool is t the connection will be taken from the general pool,
  63 if pool is a conn-pool object the connection will be taken from this pool.
  64 "
  65   (if pool
  66     (acquire-from-pool connection-spec database-type pool)
  67     (let* ((db-name (database-name-from-spec connection-spec database-type))
  68            (old-db (unless (eq if-exists :new) (find-database db-name nil)))
  69            (result nil))
  70       (if old-db
  71         (case if-exists
  72 ;           (:new
  73 ;            (setq result
  74 ;              (database-connect connection-spec database-type)))
  75           (:warn-new
  76            (setq result
  77                  (database-connect connection-spec database-type))
  78            (warn 'clsql-exists-warning :old-db old-db :new-db result))
  79           (:error
  80            (restart-case
  81                  (error 'clsql-exists-error :old-db old-db)
  82                (create-new ()
  83                    :report "Create a new connection."
  84                  (setq result
  85                    (database-connect connection-spec database-type)))
  86                (use-old ()
  87                    :report "Use the existing connection."
  88                  (setq result old-db))))
  89           (:warn-old
  90            (setq result old-db)
  91            (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
  92           (:old
  93            (setq result old-db)))
  94         (setq result
  95               (database-connect connection-spec database-type)))
  96       (when result
  97         (pushnew result *connected-databases*)
  98         (setq *default-database* result)
  99         result))))
 100
 101
 102 (defun disconnect (&key (database *default-database*))
 103   "Closes the connection to database. Resets *default-database* if that
 104 database was disconnected and only one other connection exists.
 105 if the database is from a pool it will be released to this pool."
 106   (if (conn-pool database)
 107       (release-to-pool database)
 108     (when (database-disconnect database)
 109       (setq *connected-databases* (delete database *connected-databases*))
 110       (when (eq database *default-database*)
 111         (setq *default-database* (car *connected-databases*)))
 112       (change-class database 'closed-database)
 113       t)))
 114
 115 ;;; Basic operations on databases
 116
 117 (defgeneric query (expression &key database types))
 118 (defmethod query (query-expression &key (database *default-database*)
 119                   types)
 120   "Execute the SQL query expression query-expression on the given database.
 121 Returns a list of lists of values of the result of that expression."
 122   (database-query query-expression database types))
 123
 124
 125 (defgeneric execute-command (expression &key database))
 126 (defmethod execute-command (sql-expression &key (database *default-database*))
 127   "Execute the SQL command expression sql-expression on the given database.
 128 Returns true on success or nil on failure."
 129   (database-execute-command sql-expression database))
 130
 131
 132
 133 (defun map-query (output-type-spec function query-expression
 134                   &key (database *default-database*)
 135                   (types nil))
 136   "Map the function over all tuples that are returned by the query in
 137 query-expression.  The results of the function are collected as
 138 specified in output-type-spec and returned like in MAP."
 139   ;; DANGER Will Robinson: Parts of the code for implementing
 140   ;; map-query (including the code below and the helper functions
 141   ;; called) are highly CMU CL specific.
 142   ;; KMR -- these have been replaced with cross-platform instructions above
 143   (macrolet ((type-specifier-atom (type)
 144                `(if (atom ,type) ,type (car ,type))))
 145     (case (type-specifier-atom output-type-spec)
 146       ((nil)
 147        (map-query-for-effect function query-expression database types))
 148       (list
 149        (map-query-to-list function query-expression database types))
 150       ((simple-vector simple-string vector string array simple-array
 151         bit-vector simple-bit-vector base-string
 152         simple-base-string)
 153        (map-query-to-simple output-type-spec function query-expression database types))
 154       (t
 155        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
 156               function query-expression :database database :types types)))))
 157
 158 (defun map-query-for-effect (function query-expression database types)
 159   (multiple-value-bind (result-set columns)
 160       (database-query-result-set query-expression database :full-set nil
 161                                  :types types)
 162     (when result-set
 163       (unwind-protect
 164            (do ((row (make-list columns)))
 165                ((not (database-store-next-row result-set database row))
 166                 nil)
 167              (apply function row))
 168         (database-dump-result-set result-set database)))))
 169
 170 (defun map-query-to-list (function query-expression database types)
 171   (multiple-value-bind (result-set columns)
 172       (database-query-result-set query-expression database :full-set nil
 173                                  :types types)
 174     (when result-set
 175       (unwind-protect
 176            (let ((result (list nil)))
 177              (do ((row (make-list columns))
 178                   (current-cons result (cdr current-cons)))
 179                  ((not (database-store-next-row result-set database row))
 180                   (cdr result))
 181                (rplacd current-cons (list (apply function row)))))
 182         (database-dump-result-set result-set database)))))
 183
 184
 185 (defun map-query-to-simple (output-type-spec function query-expression database types)
 186   (multiple-value-bind (result-set columns rows)
 187       (database-query-result-set query-expression database :full-set t
 188                                  :types types)
 189     (when result-set
 190       (unwind-protect
 191            (if rows
 192                ;; We know the row count in advance, so we allocate once
 193                (do ((result
 194                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 195                     (row (make-list columns))
 196                     (index 0 (1+ index)))
 197                    ((not (database-store-next-row result-set database row))
 198                     result)
 199                  (declare (fixnum index))
 200                  (setf (aref result index)
 201                        (apply function row)))
 202                ;; Database can't report row count in advance, so we have
 203                ;; to grow and shrink our vector dynamically
 204                (do ((result
 205                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 206                     (allocated-length 100)
 207                     (row (make-list columns))
 208                     (index 0 (1+ index)))
 209                    ((not (database-store-next-row result-set database row))
 210                     (cmucl-compat:shrink-vector result index))
 211                  (declare (fixnum allocated-length index))
 212                  (when (>= index allocated-length)
 213                    (setq allocated-length (* allocated-length 2)
 214                          result (adjust-array result allocated-length)))
 215                  (setf (aref result index)
 216                        (apply function row))))
 217         (database-dump-result-set result-set database)))))
 218
 219 (defmacro do-query (((&rest args) query-expression
 220                      &key (database '*default-database*)
 221                      (types nil))
 222                     &body body)
 223   (let ((result-set (gensym))
 224         (columns (gensym))
 225         (row (gensym))
 226         (db (gensym)))
 227     `(let ((,db ,database))
 228        (multiple-value-bind (,result-set ,columns)
 229            (database-query-result-set ,query-expression ,db
 230                                       :full-set nil :types ,types)
 231          (when ,result-set
 232            (unwind-protect
 233                 (do ((,row (make-list ,columns)))
 234                     ((not (database-store-next-row ,result-set ,db ,row))
 235                      nil)
 236                   (destructuring-bind ,args ,row
 237                     ,@body))
 238              (database-dump-result-set ,result-set ,db)))))))
 239
 240 ;;; Marc Battyani : Large objects support
 241
 242 (defun create-large-object (&key (database *default-database*))
 243   "Creates a new large object in the database and returns the object identifier"
 244   (database-create-large-object database))
 245
 246 (defun write-large-object (object-id data &key (database *default-database*))
 247   "Writes data to the large object"
 248   (database-write-large-object object-id data database))
 249
 250 (defun read-large-object (object-id &key (database *default-database*))
 251   "Reads the large object content"
 252   (database-read-large-object object-id database))
 253
 254 (defun delete-large-object (object-id &key (database *default-database*))
 255   "Deletes the large object in the database"
 256   (database-delete-large-object object-id database))
 257
 258
 259 ;;; Row processing macro
 260
 261
 262
 263 (defun lisp->sql-name (field)
 264   (typecase field
 265     (string field)
 266     (symbol (string-upcase (symbol-name field)))
 267     (cons (cadr field))
 268     (t (format nil "~A" field))))
 269
 270 (defun field-names (field-forms)
 271   "Return a list of field name strings from a fields form"
 272   (loop for field-form in field-forms
 273         collect
 274         (lisp->sql-name
 275          (if (cadr field-form)
 276              (cadr field-form)
 277              (car field-form)))))
 278
 279 (defun from-names (from)
 280   "Return a list of field name strings from a fields form"
 281   (loop for table in (if (atom from) (list from) from)
 282         collect (lisp->sql-name table)))
 283
 284
 285 (defun where-strings (where)
 286   (loop for w in (if (atom (car where)) (list where) where)
 287         collect
 288         (if (consp w)
 289             (format nil "~A ~A ~A" (second w) (first w) (third w))
 290             (format nil "~A" w))))
 291
 292 (defun order-by-strings (order-by)
 293   (loop for o in order-by
 294         collect
 295         (if (atom o)
 296             (lisp->sql-name o)
 297             (format nil "~A ~A" (lisp->sql-name (car o))
 298                     (lisp->sql-name (cadr o))))))
 299
 300 (defun query-string (fields from where distinct order-by limit)
 301   (concatenate
 302    'string
 303    (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
 304            (if distinct "distinct " "") (field-names fields)
 305            (from-names from))
 306    (if where (format nil " where ~{~A~^ ~}"
 307                      (where-strings where)) "")
 308    (if order-by (format nil " order by ~{~A~^, ~}"
 309                         (order-by-strings order-by)))
 310    (if limit (format nil " limit ~D" limit) "")))
 311
 312 (defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
 313   (let ((d (gensym "DISTINCT-"))
 314         (bind-fields (loop for f in fields collect (car f)))
 315         (w (gensym "WHERE-"))
 316         (o (gensym "ORDER-BY-"))
 317         (frm (gensym "FROM-"))
 318         (l (gensym "LIMIT-"))
 319         (q (gensym "QUERY-")))
 320     `(let ((,frm ,from)
 321            (,w ,where)
 322            (,d ,distinct)
 323            (,l ,limit)
 324            (,o ,order-by))
 325       (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
 326         (loop for tuple in (query ,q)
 327               collect (destructuring-bind ,bind-fields tuple
 328                    ,@body))))))