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.6 2002/03/25 23:48:46 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 (defgeneric database-type-library-loaded (database-type)
 162   (:documentation
 163    "The internal generic implementation for checking if
 164 database type library loaded successfully."))
 165
 166 (defvar *default-database-type* nil
 167   "Specifies the default type of database.  Currently only :mysql is
 168 supported.")
 169
 170 (defvar *initialized-database-types* nil
 171   "Contains a list of database types which have been initialized by calls
 172 to initialize-database-type.")
 173
 174 (defun initialize-database-type (&key (database-type *default-database-type*))
 175   "Initialize the given database-type, if it is not already
 176 initialized, as indicated by `*initialized-database-types*'."
 177   (if (member database-type *initialized-database-types*)
 178       t
 179       (when (database-initialize-database-type database-type)
 180         (push database-type *initialized-database-types*)
 181         t)))
 182
 183 (defgeneric database-initialize-database-type (database-type)
 184   (:documentation
 185    "The internal generic implementation of initialize-database-type."))
 186
 187 ;;; Database handling
 188
 189 (defvar *connect-if-exists* :error
 190   "Default value for the if-exists parameter of connect calls.")
 191
 192 (defvar *connected-databases* nil
 193   "List of active database objects.")
 194
 195 (defun connected-databases ()
 196   "Return the list of active database objects."
 197   *connected-databases*)
 198
 199 (defvar *default-database* nil
 200   "Specifies the default database to be used.")
 201
 202 (defclass database ()
 203   ((name :initarg :name :reader database-name))
 204   (:documentation
 205    "This class is the supertype of all databases handled by CLSQL."))
 206
 207 (defmethod print-object ((object database) stream)
 208   (print-unreadable-object (object stream :type t :identity t)
 209     (write-string (if (slot-boundp object 'name)
 210                       (database-name object)
 211                       "<unbound>")
 212                   stream)))
 213
 214 (defclass closed-database ()
 215   ((name :initarg :name :reader database-name))
 216   (:documentation
 217    "This class represents all databases after they are closed via
 218 `disconnect'."))
 219
 220 (defmethod print-object ((object closed-database) stream)
 221   (print-unreadable-object (object stream :type t :identity t)
 222     (write-string (if (slot-boundp object 'name)
 223                       (database-name object)
 224                       "<unbound>")
 225                   stream)))
 226
 227 (defun signal-closed-database-error (database)
 228   (cerror "Ignore this error and return nil."
 229           'clsql-closed-error
 230           :database database))
 231
 232 (defun find-database (database &optional (errorp t))
 233   (etypecase database
 234     (database
 235      ;; Return the database object itself
 236      database)
 237     (string
 238      (or (find database (connected-databases)
 239                :key #'database-name
 240                :test #'string=)
 241          (when errorp
 242            (cerror "Return nil."
 243                    'clsql-simple-error
 244                    :format-control "There exists no database called ~A."
 245                    :format-arguments (list database)))))))
 246
 247 (defun connect (connection-spec
 248                 &key (if-exists *connect-if-exists*)
 249                 (database-type *default-database-type*))
 250   "Connects to a database of the given database-type, using the type-specific
 251 connection-spec.  if-exists is currently ignored."
 252   (let* ((db-name (database-name-from-spec connection-spec database-type))
 253          (old-db (find-database db-name nil))
 254          (result nil))
 255     (if old-db
 256         (case if-exists
 257           (:new
 258            (setq result
 259                  (database-connect connection-spec database-type)))
 260           (:warn-new
 261            (setq result
 262                  (database-connect connection-spec database-type))
 263            (warn 'clsql-exists-warning :old-db old-db :new-db result))
 264           (:error
 265            (restart-case
 266                (error 'clsql-exists-error :old-db old-db)
 267              (create-new ()
 268                :report "Create a new connection."
 269                (setq result
 270                      (database-connect connection-spec database-type)))
 271              (use-old ()
 272                :report "Use the existing connection."
 273                (setq result old-db))))
 274           (:warn-old
 275            (setq result old-db)
 276            (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
 277           (:old
 278            (setq result old-db)))
 279         (setq result
 280               (database-connect connection-spec database-type)))
 281     (when result
 282       (pushnew result *connected-databases*)
 283       (setq *default-database* result)
 284       result)))
 285
 286 (defgeneric database-name-from-spec (connection-spec database-type)
 287   (:documentation
 288    "Returns the name of the database that would be created if connect
 289 was called with the connection-spec."))
 290
 291 (defgeneric database-connect (connection-spec database-type)
 292   (:documentation "Internal generic implementation of connect."))
 293
 294 (defun disconnect (&key (database *default-database*))
 295   "Closes the connection to database. Resets *default-database* if that
 296 database was disconnected and only one other connection exists."
 297   (when (database-disconnect database)
 298     (setq *connected-databases* (delete database *connected-databases*))
 299     (when (eq database *default-database*)
 300       (setq *default-database* (car *connected-databases*)))
 301     (change-class database 'closed-database)
 302     t))
 303
 304 (defgeneric database-disconnect (database)
 305   (:method ((database closed-database))
 306            (signal-closed-database-error database))
 307   (:documentation "Internal generic implementation of disconnect."))
 308
 309 ;;; Basic operations on databases
 310
 311 (defmethod query (query-expression &key (database *default-database*)
 312                   types)
 313   "Execute the SQL query expression query-expression on the given database.
 314 Returns a list of lists of values of the result of that expression."
 315   (database-query query-expression database types))
 316
 317 (defgeneric database-query (query-expression database types)
 318   (:method (query-expression (database closed-database) types)
 319            (declare (ignore query-expression types))
 320            (signal-closed-database-error database))
 321   (:documentation "Internal generic implementation of query."))
 322
 323 (defmethod execute-command (sql-expression &key (database *default-database*))
 324   "Execute the SQL command expression sql-expression on the given database.
 325 Returns true on success or nil on failure."
 326   (database-execute-command sql-expression database))
 327
 328 (defgeneric database-execute-command (sql-expression database)
 329   (:method (sql-expression (database closed-database))
 330            (declare (ignore sql-expression))
 331            (signal-closed-database-error database))
 332   (:documentation "Internal generic implementation of execute-command."))
 333
 334 ;;; Mapping and iteration
 335 (defgeneric database-query-result-set
 336     (query-expression database &key full-set types)
 337   (:method (query-expression (database closed-database) &key full-set types)
 338            (declare (ignore query-expression full-set types))
 339            (signal-closed-database-error database)
 340            (values nil nil nil))
 341   (:documentation
 342    "Internal generic implementation of query mapping.  Starts the
 343 query specified by query-expression on the given database and returns
 344 a result-set to be used with database-store-next-row and
 345 database-dump-result-set to access the returned data.  The second
 346 value is the number of columns in the result-set, if there are any.
 347 If full-set is true, the number of rows in the result-set is returned
 348 as a third value, if this is possible (otherwise nil is returned for
 349 the third value).  This might have memory and resource usage
 350 implications, since many databases will require the query to be
 351 executed in full to answer this question.  If the query produced no
 352 results then nil is returned for all values that would have been
 353 returned otherwise.  If an error occurs during query execution, the
 354 function should signal a clsql-sql-error."))
 355
 356 (defgeneric database-dump-result-set (result-set database)
 357   (:method (result-set (database closed-database))
 358            (declare (ignore result-set))
 359            (signal-closed-database-error database))
 360   (:documentation "Dumps the received result-set."))
 361
 362 (defgeneric database-store-next-row (result-set database list)
 363   (:method (result-set (database closed-database) list)
 364            (declare (ignore result-set list))
 365            (signal-closed-database-error database))
 366   (:documentation
 367    "Returns t and stores the next row in the result set in list or
 368 returns nil when result-set is finished."))
 369
 370
 371
 372 (defun map-query (output-type-spec function query-expression
 373                   &key (database *default-database*)
 374                   (types nil))
 375   "Map the function over all tuples that are returned by the query in
 376 query-expression.  The results of the function are collected as
 377 specified in output-type-spec and returned like in MAP."
 378   ;; DANGER Will Robinson: Parts of the code for implementing
 379   ;; map-query (including the code below and the helper functions
 380   ;; called) are highly CMU CL specific.
 381   ;; KMR -- these have been replaced with cross-platform instructions above
 382   (macrolet ((type-specifier-atom (type)
 383                `(if (atom ,type) ,type (car ,type))))
 384     (case (type-specifier-atom output-type-spec)
 385       ((nil)
 386        (map-query-for-effect function query-expression database types))
 387       (list
 388        (map-query-to-list function query-expression database types))
 389       ((simple-vector simple-string vector string array simple-array
 390         bit-vector simple-bit-vector base-string
 391         simple-base-string)
 392        (map-query-to-simple output-type-spec function query-expression database types))
 393       (t
 394        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
 395               function query-expression :database database :types types)))))
 396
 397 (defun map-query-for-effect (function query-expression database types)
 398   (multiple-value-bind (result-set columns)
 399       (database-query-result-set query-expression database :full-set nil
 400                                  :types types)
 401     (when result-set
 402       (unwind-protect
 403            (do ((row (make-list columns)))
 404                ((not (database-store-next-row result-set database row))
 405                 nil)
 406              (apply function row))
 407         (database-dump-result-set result-set database)))))
 408
 409 (defun map-query-to-list (function query-expression database types)
 410   (multiple-value-bind (result-set columns)
 411       (database-query-result-set query-expression database :full-set nil
 412                                  :types types)
 413     (when result-set
 414       (unwind-protect
 415            (let ((result (list nil)))
 416              (do ((row (make-list columns))
 417                   (current-cons result (cdr current-cons)))
 418                  ((not (database-store-next-row result-set database row))
 419                   (cdr result))
 420                (rplacd current-cons (list (apply function row)))))
 421         (database-dump-result-set result-set database)))))
 422
 423
 424 (defun map-query-to-simple (output-type-spec function query-expression database types)
 425   (multiple-value-bind (result-set columns rows)
 426       (database-query-result-set query-expression database :full-set t
 427                                  :types types)
 428     (when result-set
 429       (unwind-protect
 430            (if rows
 431                ;; We know the row count in advance, so we allocate once
 432                (do ((result
 433                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 434                     (row (make-list columns))
 435                     (index 0 (1+ index)))
 436                    ((not (database-store-next-row result-set database row))
 437                     result)
 438                  (declare (fixnum index))
 439                  (setf (aref result index)
 440                        (apply function row)))
 441                ;; Database can't report row count in advance, so we have
 442                ;; to grow and shrink our vector dynamically
 443                (do ((result
 444                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 445                     (allocated-length 100)
 446                     (row (make-list columns))
 447                     (index 0 (1+ index)))
 448                    ((not (database-store-next-row result-set database row))
 449                     (cmucl-compat:shrink-vector result index))
 450                  (declare (fixnum allocated-length index))
 451                  (when (>= index allocated-length)
 452                    (setq allocated-length (* allocated-length 2)
 453                          result (adjust-array result allocated-length)))
 454                  (setf (aref result index)
 455                        (apply function row))))
 456         (database-dump-result-set result-set database)))))
 457
 458 (defmacro do-query (((&rest args) query-expression
 459                      &key (database '*default-database*)
 460                      (types nil))
 461                     &body body)
 462   (let ((result-set (gensym))
 463         (columns (gensym))
 464         (row (gensym))
 465         (db (gensym)))
 466     `(let ((,db ,database))
 467        (multiple-value-bind (,result-set ,columns)
 468            (database-query-result-set ,query-expression ,db
 469                                       :full-set nil :types ,types)
 470          (when ,result-set
 471            (unwind-protect
 472                 (do ((,row (make-list ,columns)))
 473                     ((not (database-store-next-row ,result-set ,db ,row))
 474                      nil)
 475                   (destructuring-bind ,args ,row
 476                     ,@body))
 477              (database-dump-result-set ,result-set ,db)))))))
 478
 479
 480