sql/sql.lisp

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