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.14 2002/05/01 20:22:16 marc.battyani 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 (defmethod database-type-load-foreign :after (database-type)
  39   (when (database-type-library-loaded database-type)
  40      (pushnew database-type *loaded-database-types*)))
  41
  42 (defun reload-database-types ()
  43   "Reloads any foreign code for the loaded database types after a dump."
  44   (mapc #'database-type-load-foreign *loaded-database-types*))
  45
  46 (defvar *default-database-type* nil
  47   "Specifies the default type of database.  Currently only :mysql is
  48 supported.")
  49
  50 (defvar *initialized-database-types* nil
  51   "Contains a list of database types which have been initialized by calls
  52 to initialize-database-type.")
  53
  54 (defun initialize-database-type (&key (database-type *default-database-type*))
  55   "Initialize the given database-type, if it is not already
  56 initialized, as indicated by `*initialized-database-types*'."
  57   (if (member database-type *initialized-database-types*)
  58       t
  59       (when (database-initialize-database-type database-type)
  60         (push database-type *initialized-database-types*)
  61         t)))
  62
  63
  64 ;;; Database handling
  65
  66 (defvar *connect-if-exists* :error
  67   "Default value for the if-exists parameter of connect calls.")
  68
  69 (defvar *connected-databases* nil
  70   "List of active database objects.")
  71
  72 (defun connected-databases ()
  73   "Return the list of active database objects."
  74   *connected-databases*)
  75
  76 (defvar *default-database* nil
  77   "Specifies the default database to be used.")
  78
  79 (defun find-database (database &optional (errorp t))
  80   (etypecase database
  81     (database
  82      ;; Return the database object itself
  83      database)
  84     (string
  85      (or (find database (connected-databases)
  86                :key #'database-name
  87                :test #'string=)
  88          (when errorp
  89            (cerror "Return nil."
  90                    'clsql-simple-error
  91                    :format-control "There exists no database called ~A."
  92                    :format-arguments (list database)))))))
  93
  94 (defun connect (connection-spec
  95                 &key (if-exists *connect-if-exists*)
  96                 (database-type *default-database-type*)
  97                 (pool nil))
  98   "Connects to a database of the given database-type, using the type-specific
  99 connection-spec.  if-exists is currently ignored."
 100   (let* ((db-name (database-name-from-spec connection-spec database-type))
 101          (old-db (unless (eq if-exists :new) (find-database db-name nil)))
 102          (result nil))
 103     (if pool
 104         (setq result (acquire-from-pool connection-spec database-type))
 105       (if old-db
 106           (case if-exists
 107 ;           (:new
 108 ;            (setq result
 109 ;              (database-connect connection-spec database-type)))
 110             (:warn-new
 111              (setq result
 112                (database-connect connection-spec database-type))
 113              (warn 'clsql-exists-warning :old-db old-db :new-db result))
 114             (:error
 115              (restart-case
 116                  (error 'clsql-exists-error :old-db old-db)
 117                (create-new ()
 118                    :report "Create a new connection."
 119                  (setq result
 120                    (database-connect connection-spec database-type)))
 121                (use-old ()
 122                    :report "Use the existing connection."
 123                  (setq result old-db))))
 124             (:warn-old
 125              (setq result old-db)
 126              (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
 127             (:old
 128              (setq result old-db)))
 129         (setq result
 130           (database-connect connection-spec database-type))))
 131     (when result
 132       (pushnew result *connected-databases*)
 133       (setq *default-database* result)
 134       result)))
 135
 136
 137 (defun disconnect (&key (database *default-database*)
 138                    (pool nil))
 139   "Closes the connection to database. Resets *default-database* if that
 140 database was disconnected and only one other connection exists."
 141   (if pool
 142       (release-to-pool database)
 143     (when (database-disconnect database)
 144       (setq *connected-databases* (delete database *connected-databases*))
 145       (when (eq database *default-database*)
 146         (setq *default-database* (car *connected-databases*)))
 147       (change-class database 'closed-database)
 148       t)))
 149
 150 ;;; Basic operations on databases
 151
 152 (defmethod query (query-expression &key (database *default-database*)
 153                   types)
 154   "Execute the SQL query expression query-expression on the given database.
 155 Returns a list of lists of values of the result of that expression."
 156   (database-query query-expression database types))
 157
 158
 159
 160 (defmethod execute-command (sql-expression &key (database *default-database*))
 161   "Execute the SQL command expression sql-expression on the given database.
 162 Returns true on success or nil on failure."
 163   (database-execute-command sql-expression database))
 164
 165
 166
 167 (defun map-query (output-type-spec function query-expression
 168                   &key (database *default-database*)
 169                   (types nil))
 170   "Map the function over all tuples that are returned by the query in
 171 query-expression.  The results of the function are collected as
 172 specified in output-type-spec and returned like in MAP."
 173   ;; DANGER Will Robinson: Parts of the code for implementing
 174   ;; map-query (including the code below and the helper functions
 175   ;; called) are highly CMU CL specific.
 176   ;; KMR -- these have been replaced with cross-platform instructions above
 177   (macrolet ((type-specifier-atom (type)
 178                `(if (atom ,type) ,type (car ,type))))
 179     (case (type-specifier-atom output-type-spec)
 180       ((nil)
 181        (map-query-for-effect function query-expression database types))
 182       (list
 183        (map-query-to-list function query-expression database types))
 184       ((simple-vector simple-string vector string array simple-array
 185         bit-vector simple-bit-vector base-string
 186         simple-base-string)
 187        (map-query-to-simple output-type-spec function query-expression database types))
 188       (t
 189        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
 190               function query-expression :database database :types types)))))
 191
 192 (defun map-query-for-effect (function query-expression database types)
 193   (multiple-value-bind (result-set columns)
 194       (database-query-result-set query-expression database :full-set nil
 195                                  :types types)
 196     (when result-set
 197       (unwind-protect
 198            (do ((row (make-list columns)))
 199                ((not (database-store-next-row result-set database row))
 200                 nil)
 201              (apply function row))
 202         (database-dump-result-set result-set database)))))
 203
 204 (defun map-query-to-list (function query-expression database types)
 205   (multiple-value-bind (result-set columns)
 206       (database-query-result-set query-expression database :full-set nil
 207                                  :types types)
 208     (when result-set
 209       (unwind-protect
 210            (let ((result (list nil)))
 211              (do ((row (make-list columns))
 212                   (current-cons result (cdr current-cons)))
 213                  ((not (database-store-next-row result-set database row))
 214                   (cdr result))
 215                (rplacd current-cons (list (apply function row)))))
 216         (database-dump-result-set result-set database)))))
 217
 218
 219 (defun map-query-to-simple (output-type-spec function query-expression database types)
 220   (multiple-value-bind (result-set columns rows)
 221       (database-query-result-set query-expression database :full-set t
 222                                  :types types)
 223     (when result-set
 224       (unwind-protect
 225            (if rows
 226                ;; We know the row count in advance, so we allocate once
 227                (do ((result
 228                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 229                     (row (make-list columns))
 230                     (index 0 (1+ index)))
 231                    ((not (database-store-next-row result-set database row))
 232                     result)
 233                  (declare (fixnum index))
 234                  (setf (aref result index)
 235                        (apply function row)))
 236                ;; Database can't report row count in advance, so we have
 237                ;; to grow and shrink our vector dynamically
 238                (do ((result
 239                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 240                     (allocated-length 100)
 241                     (row (make-list columns))
 242                     (index 0 (1+ index)))
 243                    ((not (database-store-next-row result-set database row))
 244                     (cmucl-compat:shrink-vector result index))
 245                  (declare (fixnum allocated-length index))
 246                  (when (>= index allocated-length)
 247                    (setq allocated-length (* allocated-length 2)
 248                          result (adjust-array result allocated-length)))
 249                  (setf (aref result index)
 250                        (apply function row))))
 251         (database-dump-result-set result-set database)))))
 252
 253 (defmacro do-query (((&rest args) query-expression
 254                      &key (database '*default-database*)
 255                      (types nil))
 256                     &body body)
 257   (let ((result-set (gensym))
 258         (columns (gensym))
 259         (row (gensym))
 260         (db (gensym)))
 261     `(let ((,db ,database))
 262        (multiple-value-bind (,result-set ,columns)
 263            (database-query-result-set ,query-expression ,db
 264                                       :full-set nil :types ,types)
 265          (when ,result-set
 266            (unwind-protect
 267                 (do ((,row (make-list ,columns)))
 268                     ((not (database-store-next-row ,result-set ,db ,row))
 269                      nil)
 270                   (destructuring-bind ,args ,row
 271                     ,@body))
 272              (database-dump-result-set ,result-set ,db)))))))
 273
 274 ;;; Marc Battyani : Large objects support
 275
 276 (defun create-large-object (&key (database *default-database*))
 277   "Creates a new large object in the database and returns the object identifier"
 278   (database-create-large-object database))
 279
 280 (defun write-large-object (object-id data &key (database *default-database*))
 281   "Writes data to the large object"
 282   (database-write-large-object object-id data database))
 283
 284 (defun read-large-object (object-id &key (database *default-database*))
 285   "Reads the large object content"
 286   (database-read-large-object object-id database))
 287
 288 (defun delete-large-object (object-id &key (database *default-database*))
 289   "Deletes the large object in the database"
 290   (database-delete-large-object object-id database))