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