sql/sql.cl

   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 ;;;; Programmers:   Kevin M. Rosenberg based on
   8 ;;;;                 Original code by Pierre R. Mai
   9 ;;;; Date Started:  Feb 2002
  10 ;;;;
  11 ;;;; $Id: sql.cl,v 1.8 2002/03/29 07:42:10 kevin Exp $
  12 ;;;;
  13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  14 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  15 ;;;;
  16 ;;;; CLSQL users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;; *************************************************************************
  20
  21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  22 (in-package :clsql-sys)
  23
  24 ;;; Modified by KMR
  25 ;;; - to use CMUCL-COMPAT library
  26 ;;; - fix format strings in error messages
  27 ;;; - use field types
  28
  29
  30 ;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
  31
  32
  33 ;;; Database Types
  34
  35 (defvar *loaded-database-types* nil
  36   "Contains a list of database types which have been defined/loaded.")
  37
  38 (defun reload-database-types ()
  39   "Reloads any foreign code for the loaded database types after a dump."
  40   (mapc #'database-type-load-foreign *loaded-database-types*))
  41
  42
  43 (defvar *default-database-type* nil
  44   "Specifies the default type of database.  Currently only :mysql is
  45 supported.")
  46
  47 (defvar *initialized-database-types* nil
  48   "Contains a list of database types which have been initialized by calls
  49 to initialize-database-type.")
  50
  51 (defun initialize-database-type (&key (database-type *default-database-type*))
  52   "Initialize the given database-type, if it is not already
  53 initialized, as indicated by `*initialized-database-types*'."
  54   (if (member database-type *initialized-database-types*)
  55       t
  56       (when (database-initialize-database-type database-type)
  57         (push database-type *initialized-database-types*)
  58         t)))
  59
  60
  61 ;;; Database handling
  62
  63 (defvar *connect-if-exists* :error
  64   "Default value for the if-exists parameter of connect calls.")
  65
  66 (defvar *connected-databases* nil
  67   "List of active database objects.")
  68
  69 (defun connected-databases ()
  70   "Return the list of active database objects."
  71   *connected-databases*)
  72
  73 (defvar *default-database* nil
  74   "Specifies the default database to be used.")
  75
  76 (defclass database ()
  77   ((name :initarg :name :reader database-name))
  78   (:documentation
  79    "This class is the supertype of all databases handled by CLSQL."))
  80
  81 (defmethod print-object ((object database) stream)
  82   (print-unreadable-object (object stream :type t :identity t)
  83     (write-string (if (slot-boundp object 'name)
  84                       (database-name object)
  85                       "<unbound>")
  86                   stream)))
  87
  88 (defclass closed-database ()
  89   ((name :initarg :name :reader database-name))
  90   (:documentation
  91    "This class represents all databases after they are closed via
  92 `disconnect'."))
  93
  94 (defmethod print-object ((object closed-database) stream)
  95   (print-unreadable-object (object stream :type t :identity t)
  96     (write-string (if (slot-boundp object 'name)
  97                       (database-name object)
  98                       "<unbound>")
  99                   stream)))
 100
 101 (defun signal-closed-database-error (database)
 102   (cerror "Ignore this error and return nil."
 103           'clsql-closed-error
 104           :database database))
 105
 106 (defun find-database (database &optional (errorp t))
 107   (etypecase database
 108     (database
 109      ;; Return the database object itself
 110      database)
 111     (string
 112      (or (find database (connected-databases)
 113                :key #'database-name
 114                :test #'string=)
 115          (when errorp
 116            (cerror "Return nil."
 117                    'clsql-simple-error
 118                    :format-control "There exists no database called ~A."
 119                    :format-arguments (list database)))))))
 120
 121 (defun connect (connection-spec
 122                 &key (if-exists *connect-if-exists*)
 123                 (database-type *default-database-type*))
 124   "Connects to a database of the given database-type, using the type-specific
 125 connection-spec.  if-exists is currently ignored."
 126   (let* ((db-name (database-name-from-spec connection-spec database-type))
 127          (old-db (find-database db-name nil))
 128          (result nil))
 129     (if old-db
 130         (case if-exists
 131           (:new
 132            (setq result
 133                  (database-connect connection-spec database-type)))
 134           (:warn-new
 135            (setq result
 136                  (database-connect connection-spec database-type))
 137            (warn 'clsql-exists-warning :old-db old-db :new-db result))
 138           (:error
 139            (restart-case
 140                (error 'clsql-exists-error :old-db old-db)
 141              (create-new ()
 142                :report "Create a new connection."
 143                (setq result
 144                      (database-connect connection-spec database-type)))
 145              (use-old ()
 146                :report "Use the existing connection."
 147                (setq result old-db))))
 148           (:warn-old
 149            (setq result old-db)
 150            (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
 151           (:old
 152            (setq result old-db)))
 153         (setq result
 154               (database-connect connection-spec database-type)))
 155     (when result
 156       (pushnew result *connected-databases*)
 157       (setq *default-database* result)
 158       result)))
 159
 160
 161
 162 (defun disconnect (&key (database *default-database*))
 163   "Closes the connection to database. Resets *default-database* if that
 164 database was disconnected and only one other connection exists."
 165   (when (database-disconnect database)
 166     (setq *connected-databases* (delete database *connected-databases*))
 167     (when (eq database *default-database*)
 168       (setq *default-database* (car *connected-databases*)))
 169     (change-class database 'closed-database)
 170     t))
 171
 172
 173
 174 ;;; Basic operations on databases
 175
 176 (defmethod query (query-expression &key (database *default-database*)
 177                   types)
 178   "Execute the SQL query expression query-expression on the given database.
 179 Returns a list of lists of values of the result of that expression."
 180   (database-query query-expression database types))
 181
 182
 183
 184 (defmethod execute-command (sql-expression &key (database *default-database*))
 185   "Execute the SQL command expression sql-expression on the given database.
 186 Returns true on success or nil on failure."
 187   (database-execute-command sql-expression database))
 188
 189
 190
 191 (defun map-query (output-type-spec function query-expression
 192                   &key (database *default-database*)
 193                   (types nil))
 194   "Map the function over all tuples that are returned by the query in
 195 query-expression.  The results of the function are collected as
 196 specified in output-type-spec and returned like in MAP."
 197   ;; DANGER Will Robinson: Parts of the code for implementing
 198   ;; map-query (including the code below and the helper functions
 199   ;; called) are highly CMU CL specific.
 200   ;; KMR -- these have been replaced with cross-platform instructions above
 201   (macrolet ((type-specifier-atom (type)
 202                `(if (atom ,type) ,type (car ,type))))
 203     (case (type-specifier-atom output-type-spec)
 204       ((nil)
 205        (map-query-for-effect function query-expression database types))
 206       (list
 207        (map-query-to-list function query-expression database types))
 208       ((simple-vector simple-string vector string array simple-array
 209         bit-vector simple-bit-vector base-string
 210         simple-base-string)
 211        (map-query-to-simple output-type-spec function query-expression database types))
 212       (t
 213        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
 214               function query-expression :database database :types types)))))
 215
 216 (defun map-query-for-effect (function query-expression database types)
 217   (multiple-value-bind (result-set columns)
 218       (database-query-result-set query-expression database :full-set nil
 219                                  :types types)
 220     (when result-set
 221       (unwind-protect
 222            (do ((row (make-list columns)))
 223                ((not (database-store-next-row result-set database row))
 224                 nil)
 225              (apply function row))
 226         (database-dump-result-set result-set database)))))
 227
 228 (defun map-query-to-list (function query-expression database types)
 229   (multiple-value-bind (result-set columns)
 230       (database-query-result-set query-expression database :full-set nil
 231                                  :types types)
 232     (when result-set
 233       (unwind-protect
 234            (let ((result (list nil)))
 235              (do ((row (make-list columns))
 236                   (current-cons result (cdr current-cons)))
 237                  ((not (database-store-next-row result-set database row))
 238                   (cdr result))
 239                (rplacd current-cons (list (apply function row)))))
 240         (database-dump-result-set result-set database)))))
 241
 242
 243 (defun map-query-to-simple (output-type-spec function query-expression database types)
 244   (multiple-value-bind (result-set columns rows)
 245       (database-query-result-set query-expression database :full-set t
 246                                  :types types)
 247     (when result-set
 248       (unwind-protect
 249            (if rows
 250                ;; We know the row count in advance, so we allocate once
 251                (do ((result
 252                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 253                     (row (make-list columns))
 254                     (index 0 (1+ index)))
 255                    ((not (database-store-next-row result-set database row))
 256                     result)
 257                  (declare (fixnum index))
 258                  (setf (aref result index)
 259                        (apply function row)))
 260                ;; Database can't report row count in advance, so we have
 261                ;; to grow and shrink our vector dynamically
 262                (do ((result
 263                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 264                     (allocated-length 100)
 265                     (row (make-list columns))
 266                     (index 0 (1+ index)))
 267                    ((not (database-store-next-row result-set database row))
 268                     (cmucl-compat:shrink-vector result index))
 269                  (declare (fixnum allocated-length index))
 270                  (when (>= index allocated-length)
 271                    (setq allocated-length (* allocated-length 2)
 272                          result (adjust-array result allocated-length)))
 273                  (setf (aref result index)
 274                        (apply function row))))
 275         (database-dump-result-set result-set database)))))
 276
 277 (defmacro do-query (((&rest args) query-expression
 278                      &key (database '*default-database*)
 279                      (types nil))
 280                     &body body)
 281   (let ((result-set (gensym))
 282         (columns (gensym))
 283         (row (gensym))
 284         (db (gensym)))
 285     `(let ((,db ,database))
 286        (multiple-value-bind (,result-set ,columns)
 287            (database-query-result-set ,query-expression ,db
 288                                       :full-set nil :types ,types)
 289          (when ,result-set
 290            (unwind-protect
 291                 (do ((,row (make-list ,columns)))
 292                     ((not (database-store-next-row ,result-set ,db ,row))
 293                      nil)
 294                   (destructuring-bind ,args ,row
 295                     ,@body))
 296              (database-dump-result-set ,result-set ,db)))))))
 297
 298
 299