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.1 2002/03/23 14:04:54 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 to use CMUCL-COMPAT library and to fix format strings in
  25 ;;;; error messages
  26
  27 ;;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
  28
  29 ;;; Conditions
  30 (define-condition clsql-condition ()
  31   ())
  32
  33 (define-condition clsql-error (error clsql-condition)
  34   ())
  35
  36 (define-condition clsql-simple-error (simple-condition clsql-error)
  37   ())
  38
  39 (define-condition clsql-warning (warning clsql-condition)
  40   ())
  41
  42 (define-condition clsql-simple-warning (simple-condition clsql-warning)
  43   ())
  44
  45 (define-condition clsql-invalid-spec-error (clsql-error)
  46   ((connection-spec :initarg :connection-spec
  47                     :reader clsql-invalid-spec-error-connection-spec)
  48    (database-type :initarg :database-type
  49                   :reader clsql-invalid-spec-error-database-type)
  50    (template :initarg :template
  51              :reader clsql-invalid-spec-error-template))
  52   (:report (lambda (c stream)
  53              (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
  54                      (clsql-invalid-spec-error-connection-spec c)
  55                      (clsql-invalid-spec-error-database-type c)
  56                      (clsql-invalid-spec-error-template c)))))
  57
  58 (defmacro check-connection-spec (connection-spec database-type template)
  59   "Check the connection specification against the provided template,
  60 and signal an clsql-invalid-spec-error if they don't match."
  61   `(handler-case
  62     (destructuring-bind ,template ,connection-spec
  63       (declare (ignore ,@template))
  64       t)
  65     (error () (error 'clsql-invalid-spec-error
  66                      :connection-spec ,connection-spec
  67                      :database-type ,database-type
  68                      :template (quote ,template)))))
  69
  70 (define-condition clsql-connect-error (clsql-error)
  71   ((database-type :initarg :database-type
  72                   :reader clsql-connect-error-database-type)
  73    (connection-spec :initarg :connection-spec
  74                     :reader clsql-connect-error-connection-spec)
  75    (errno :initarg :errno :reader clsql-connect-error-errno)
  76    (error :initarg :error :reader clsql-connect-error-error))
  77   (:report (lambda (c stream)
  78              (format stream "While trying to connect to database ~A~%  using database-type ~A:~%  Error ~D / ~A~%  has occurred."
  79                      (database-name-from-spec
  80                       (clsql-connect-error-connection-spec c)
  81                       (clsql-connect-error-database-type c))
  82                      (clsql-connect-error-database-type c)
  83                      (clsql-connect-error-errno c)
  84                      (clsql-connect-error-error c)))))
  85
  86 (define-condition clsql-sql-error (clsql-error)
  87   ((database :initarg :database :reader clsql-sql-error-database)
  88    (expression :initarg :expression :reader clsql-sql-error-expression)
  89    (errno :initarg :errno :reader clsql-sql-error-errno)
  90    (error :initarg :error :reader clsql-sql-error-error))
  91   (:report (lambda (c stream)
  92              (format stream "While accessing database ~A~%  with expression ~S:~%  Error ~D / ~A~%  has occurred."
  93                      (clsql-sql-error-database c)
  94                      (clsql-sql-error-expression c)
  95                      (clsql-sql-error-errno c)
  96                      (clsql-sql-error-error c)))))
  97
  98 (define-condition clsql-database-warning (clsql-warning)
  99   ((database :initarg :database :reader clsql-database-warning-database)
 100    (message :initarg :message :reader clsql-database-warning-message))
 101   (:report (lambda (c stream)
 102              (format stream "While accessing database ~A~%  Warning: ~A~%  has occurred."
 103                      (clsql-database-warning-database c)
 104                      (clsql-database-warning-message c)))))
 105
 106 (define-condition clsql-exists-condition (clsql-condition)
 107    ((old-db :initarg :old-db :reader clsql-exists-condition-old-db)
 108     (new-db :initarg :new-db :reader clsql-exists-condition-new-db
 109             :initform nil))
 110    (:report (lambda (c stream)
 111               (format stream "In call to ~S:~%" 'connect)
 112               (cond
 113                 ((null (clsql-exists-condition-new-db c))
 114                  (format stream
 115                          "  There is an existing connection ~A to database ~A."
 116                          (clsql-exists-condition-old-db c)
 117                          (database-name (clsql-exists-condition-old-db c))))
 118                 ((eq (clsql-exists-condition-new-db c)
 119                      (clsql-exists-condition-old-db c))
 120                  (format stream
 121                          "  Using existing connection ~A to database ~A."
 122                          (clsql-exists-condition-old-db c)
 123                          (database-name (clsql-exists-condition-old-db c))))
 124                 (t
 125                  (format stream
 126                          "  Created new connection ~A to database ~A~%  ~
 127 although there is an existing connection (~A)."
 128                          (clsql-exists-condition-new-db c)
 129                          (database-name (clsql-exists-condition-new-db c))
 130                          (clsql-exists-condition-old-db c)))))))
 131
 132 (define-condition clsql-exists-warning (clsql-exists-condition
 133                                          clsql-warning)
 134   ())
 135
 136 (define-condition clsql-exists-error (clsql-exists-condition
 137                                        clsql-error)
 138   ())
 139
 140 (define-condition clsql-closed-error (clsql-error)
 141   ((database :initarg :database :reader clsql-closed-error-database))
 142   (:report (lambda (c stream)
 143              (format stream "The database ~A has already been closed."
 144                      (clsql-closed-error-database c)))))
 145
 146 ;;; Database Types
 147
 148 (defvar *loaded-database-types* nil
 149   "Contains a list of database types which have been defined/loaded.")
 150
 151 (defun reload-database-types ()
 152   "Reloads any foreign code for the loaded database types after a dump."
 153   (mapc #'database-type-load-foreign *loaded-database-types*))
 154
 155 (defgeneric database-type-load-foreign (database-type)
 156   (:documentation
 157    "The internal generic implementation of reload-database-types.")
 158   (:method :after (database-type)
 159            (pushnew database-type *loaded-database-types*)))
 160
 161 (defvar *default-database-type* nil
 162   "Specifies the default type of database.  Currently only :mysql is
 163 supported.")
 164
 165 (defvar *initialized-database-types* nil
 166   "Contains a list of database types which have been initialized by calls
 167 to initialize-database-type.")
 168
 169 (defun initialize-database-type (&key (database-type *default-database-type*))
 170   "Initialize the given database-type, if it is not already
 171 initialized, as indicated by `*initialized-database-types*'."
 172   (if (member database-type *initialized-database-types*)
 173       t
 174       (when (database-initialize-database-type database-type)
 175         (push database-type *initialized-database-types*)
 176         t)))
 177
 178 (defgeneric database-initialize-database-type (database-type)
 179   (:documentation
 180    "The internal generic implementation of initialize-database-type."))
 181
 182 ;;; Database handling
 183
 184 (defvar *connect-if-exists* :error
 185   "Default value for the if-exists parameter of connect calls.")
 186
 187 (defvar *connected-databases* nil
 188   "List of active database objects.")
 189
 190 (defun connected-databases ()
 191   "Return the list of active database objects."
 192   *connected-databases*)
 193
 194 (defvar *default-database* nil
 195   "Specifies the default database to be used.")
 196
 197 (defclass database ()
 198   ((name :initarg :name :reader database-name))
 199   (:documentation
 200    "This class is the supertype of all databases handled by CLSQL."))
 201
 202 (defmethod print-object ((object database) stream)
 203   (print-unreadable-object (object stream :type t :identity t)
 204     (write-string (if (slot-boundp object 'name)
 205                       (database-name object)
 206                       "<unbound>")
 207                   stream)))
 208
 209 (defclass closed-database ()
 210   ((name :initarg :name :reader database-name))
 211   (:documentation
 212    "This class represents all databases after they are closed via
 213 `disconnect'."))
 214
 215 (defmethod print-object ((object closed-database) stream)
 216   (print-unreadable-object (object stream :type t :identity t)
 217     (write-string (if (slot-boundp object 'name)
 218                       (database-name object)
 219                       "<unbound>")
 220                   stream)))
 221
 222 (defun signal-closed-database-error (database)
 223   (cerror "Ignore this error and return nil."
 224           'clsql-closed-error
 225           :database database))
 226
 227 (defun find-database (database &optional (errorp t))
 228   (etypecase database
 229     (database
 230      ;; Return the database object itself
 231      database)
 232     (string
 233      (or (find database (connected-databases)
 234                :key #'database-name
 235                :test #'string=)
 236          (when errorp
 237            (cerror "Return nil."
 238                    'clsql-simple-error
 239                    :format-control "There exists no database called ~A."
 240                    :format-arguments (list database)))))))
 241
 242 (defun connect (connection-spec
 243                 &key (if-exists *connect-if-exists*)
 244                 (database-type *default-database-type*))
 245   "Connects to a database of the given database-type, using the type-specific
 246 connection-spec.  if-exists is currently ignored."
 247   (let* ((db-name (database-name-from-spec connection-spec database-type))
 248          (old-db (find-database db-name nil))
 249          (result nil))
 250     (if old-db
 251         (case if-exists
 252           (:new
 253            (setq result
 254                  (database-connect connection-spec database-type)))
 255           (:warn-new
 256            (setq result
 257                  (database-connect connection-spec database-type))
 258            (warn 'clsql-exists-warning :old-db old-db :new-db result))
 259           (:error
 260            (restart-case
 261                (error 'clsql-exists-error :old-db old-db)
 262              (create-new ()
 263                :report "Create a new connection."
 264                (setq result
 265                      (database-connect connection-spec database-type)))
 266              (use-old ()
 267                :report "Use the existing connection."
 268                (setq result old-db))))
 269           (:warn-old
 270            (setq result old-db)
 271            (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
 272           (:old
 273            (setq result old-db)))
 274         (setq result
 275               (database-connect connection-spec database-type)))
 276     (when result
 277       (pushnew result *connected-databases*)
 278       (setq *default-database* result)
 279       result)))
 280
 281 (defgeneric database-name-from-spec (connection-spec database-type)
 282   (:documentation
 283    "Returns the name of the database that would be created if connect
 284 was called with the connection-spec."))
 285
 286 (defgeneric database-connect (connection-spec database-type)
 287   (:documentation "Internal generic implementation of connect."))
 288
 289 (defun disconnect (&key (database *default-database*))
 290   "Closes the connection to database. Resets *default-database* if that
 291 database was disconnected and only one other connection exists."
 292   (when (database-disconnect database)
 293     (setq *connected-databases* (delete database *connected-databases*))
 294     (when (eq database *default-database*)
 295       (setq *default-database* (car *connected-databases*)))
 296     (change-class database 'closed-database)
 297     t))
 298
 299 (defgeneric database-disconnect (database)
 300   (:method ((database closed-database))
 301            (signal-closed-database-error database))
 302   (:documentation "Internal generic implementation of disconnect."))
 303
 304 ;;; Basic operations on databases
 305
 306 (defmethod query (query-expression &key (database *default-database*))
 307   "Execute the SQL query expression query-expression on the given database.
 308 Returns a list of lists of values of the result of that expression."
 309   (database-query query-expression database))
 310
 311 (defgeneric database-query (query-expression database)
 312   (:method (query-expression (database closed-database))
 313            (declare (ignore query-expression))
 314            (signal-closed-database-error database))
 315   (:documentation "Internal generic implementation of query."))
 316
 317 (defmethod execute-command (sql-expression &key (database *default-database*))
 318   "Execute the SQL command expression sql-expression on the given database.
 319 Returns true on success or nil on failure."
 320   (database-execute-command sql-expression database))
 321
 322 (defgeneric database-execute-command (sql-expression database)
 323   (:method (sql-expression (database closed-database))
 324            (declare (ignore sql-expression))
 325            (signal-closed-database-error database))
 326   (:documentation "Internal generic implementation of execute-command."))
 327
 328 ;;; Mapping and iteration
 329 (defgeneric database-query-result-set
 330     (query-expression database &optional full-set)
 331   (:method (query-expression (database closed-database) &optional full-set)
 332            (declare (ignore query-expression full-set))
 333            (signal-closed-database-error database)
 334            (values nil nil nil))
 335   (:documentation
 336    "Internal generic implementation of query mapping.  Starts the
 337 query specified by query-expression on the given database and returns
 338 a result-set to be used with database-store-next-row and
 339 database-dump-result-set to access the returned data.  The second
 340 value is the number of columns in the result-set, if there are any.
 341 If full-set is true, the number of rows in the result-set is returned
 342 as a third value, if this is possible (otherwise nil is returned for
 343 the third value).  This might have memory and resource usage
 344 implications, since many databases will require the query to be
 345 executed in full to answer this question.  If the query produced no
 346 results then nil is returned for all values that would have been
 347 returned otherwise.  If an error occurs during query execution, the
 348 function should signal a clsql-sql-error."))
 349
 350 (defgeneric database-dump-result-set (result-set database)
 351   (:method (result-set (database closed-database))
 352            (declare (ignore result-set))
 353            (signal-closed-database-error database))
 354   (:documentation "Dumps the received result-set."))
 355
 356 (defgeneric database-store-next-row (result-set database list)
 357   (:method (result-set (database closed-database) list)
 358            (declare (ignore result-set list))
 359            (signal-closed-database-error database))
 360   (:documentation
 361    "Returns t and stores the next row in the result set in list or
 362 returns nil when result-set is finished."))
 363
 364
 365
 366 (defun map-query (output-type-spec function query-expression
 367                                    &key (database *default-database*))
 368   "Map the function over all tuples that are returned by the query in
 369 query-expression.  The results of the function are collected as
 370 specified in output-type-spec and returned like in MAP."
 371   ;; DANGER Will Robinson: Parts of the code for implementing
 372   ;; map-query (including the code below and the helper functions
 373   ;; called) are highly CMU CL specific.
 374   ;; KMR -- these have been replaced with cross-platform instructions above
 375   (macrolet ((type-specifier-atom (type)
 376                `(if (atom ,type) ,type (car ,type))))
 377     (case (type-specifier-atom output-type-spec)
 378       ((nil) (map-query-for-effect function query-expression database))
 379       (list (map-query-to-list function query-expression database))
 380       ((simple-vector simple-string vector string array simple-array
 381         bit-vector simple-bit-vector base-string
 382         simple-base-string)
 383        (map-query-to-simple output-type-spec
 384                             function query-expression database))
 385       (t
 386        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
 387               function query-expression :database database)))))
 388
 389 (defun map-query-for-effect (function query-expression database)
 390   (multiple-value-bind (result-set columns)
 391       (database-query-result-set query-expression database)
 392     (when result-set
 393       (unwind-protect
 394            (do ((row (make-list columns)))
 395                ((not (database-store-next-row result-set database row))
 396                 nil)
 397              (apply function row))
 398         (database-dump-result-set result-set database)))))
 399
 400 (defun map-query-to-list (function query-expression database)
 401   (multiple-value-bind (result-set columns)
 402       (database-query-result-set query-expression database)
 403     (when result-set
 404       (unwind-protect
 405            (let ((result (list nil)))
 406              (do ((row (make-list columns))
 407                   (current-cons result (cdr current-cons)))
 408                  ((not (database-store-next-row result-set database row))
 409                   (cdr result))
 410                (rplacd current-cons (list (apply function row)))))
 411         (database-dump-result-set result-set database)))))
 412
 413
 414 (defun map-query-to-simple (output-type-spec function query-expression database)
 415   (multiple-value-bind (result-set columns rows)
 416       (database-query-result-set query-expression database t)
 417     (when result-set
 418       (unwind-protect
 419            (if rows
 420                ;; We know the row count in advance, so we allocate once
 421                (do ((result
 422                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 423                     (row (make-list columns))
 424                     (index 0 (1+ index)))
 425                    ((not (database-store-next-row result-set database row))
 426                     result)
 427                  (declare (fixnum index))
 428                  (setf (aref result index)
 429                        (apply function row)))
 430                ;; Database can't report row count in advance, so we have
 431                ;; to grow and shrink our vector dynamically
 432                (do ((result
 433                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 434                     (allocated-length 100)
 435                     (row (make-list columns))
 436                     (index 0 (1+ index)))
 437                    ((not (database-store-next-row result-set database row))
 438                     (cmucl-compat:shrink-vector result index))
 439                  (declare (fixnum allocated-length index))
 440                  (when (>= index allocated-length)
 441                    (setq allocated-length (* allocated-length 2)
 442                          result (adjust-array result allocated-length)))
 443                  (setf (aref result index)
 444                        (apply function row))))
 445         (database-dump-result-set result-set database)))))
 446
 447 (defmacro do-query (((&rest args) query-expression
 448                      &key (database '*default-database*))
 449                     &body body)
 450   (let ((result-set (gensym))
 451         (columns (gensym))
 452         (row (gensym))
 453         (db (gensym)))
 454     `(let ((,db ,database))
 455        (multiple-value-bind (,result-set ,columns)
 456            (database-query-result-set ,query-expression ,db)
 457          (when ,result-set
 458            (unwind-protect
 459                 (do ((,row (make-list ,columns)))
 460                     ((not (database-store-next-row ,result-set ,db ,row))
 461                      nil)
 462                   (destructuring-bind ,args ,row
 463                     ,@body))
 464              (database-dump-result-set ,result-set ,db)))))))
 465
 466
 467