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