sql/sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:         sql.lisp
   6 ;;;; Purpose:      High-level SQL interface
   7 ;;;; Authors:      Kevin M. Rosenberg based on code by Pierre R. Mai
   8 ;;;; Date Started: Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:clsql-sys)
  21
  22
  23 (defun map-query (output-type-spec function query-expression
  24                   &key (database *default-database*)
  25                   (types nil))
  26   "Map the function over all tuples that are returned by the query in
  27 query-expression.  The results of the function are collected as
  28 specified in output-type-spec and returned like in MAP."
  29   ;; DANGER Will Robinson: Parts of the code for implementing
  30   ;; map-query (including the code below and the helper functions
  31   ;; called) are highly CMU CL specific.
  32   ;; KMR -- these have been replaced with cross-platform instructions above
  33   (macrolet ((type-specifier-atom (type)
  34                `(if (atom ,type) ,type (car ,type))))
  35     (case (type-specifier-atom output-type-spec)
  36       ((nil)
  37        (map-query-for-effect function query-expression database types))
  38       (list
  39        (map-query-to-list function query-expression database types))
  40       ((simple-vector simple-string vector string array simple-array
  41         bit-vector simple-bit-vector base-string
  42         simple-base-string)
  43        (map-query-to-simple output-type-spec function query-expression database types))
  44       (t
  45        (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
  46               function query-expression :database database :types types)))))
  47
  48 (defun map-query-for-effect (function query-expression database types)
  49   (multiple-value-bind (result-set columns)
  50       (database-query-result-set query-expression database :full-set nil
  51                                  :types types)
  52     (when result-set
  53       (unwind-protect
  54            (do ((row (make-list columns)))
  55                ((not (database-store-next-row result-set database row))
  56                 nil)
  57              (apply function row))
  58         (database-dump-result-set result-set database)))))
  59
  60 (defun map-query-to-list (function query-expression database types)
  61   (multiple-value-bind (result-set columns)
  62       (database-query-result-set query-expression database :full-set nil
  63                                  :types types)
  64     (when result-set
  65       (unwind-protect
  66            (let ((result (list nil)))
  67              (do ((row (make-list columns))
  68                   (current-cons result (cdr current-cons)))
  69                  ((not (database-store-next-row result-set database row))
  70                   (cdr result))
  71                (rplacd current-cons (list (apply function row)))))
  72         (database-dump-result-set result-set database)))))
  73
  74
  75 (defun map-query-to-simple (output-type-spec function query-expression database types)
  76   (multiple-value-bind (result-set columns rows)
  77       (database-query-result-set query-expression database :full-set t
  78                                  :types types)
  79     (when result-set
  80       (unwind-protect
  81            (if rows
  82                ;; We know the row count in advance, so we allocate once
  83                (do ((result
  84                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
  85                     (row (make-list columns))
  86                     (index 0 (1+ index)))
  87                    ((not (database-store-next-row result-set database row))
  88                     result)
  89                  (declare (fixnum index))
  90                  (setf (aref result index)
  91                        (apply function row)))
  92                ;; Database can't report row count in advance, so we have
  93                ;; to grow and shrink our vector dynamically
  94                (do ((result
  95                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
  96                     (allocated-length 100)
  97                     (row (make-list columns))
  98                     (index 0 (1+ index)))
  99                    ((not (database-store-next-row result-set database row))
 100                     (cmucl-compat:shrink-vector result index))
 101                  (declare (fixnum allocated-length index))
 102                  (when (>= index allocated-length)
 103                    (setq allocated-length (* allocated-length 2)
 104                          result (adjust-array result allocated-length)))
 105                  (setf (aref result index)
 106                        (apply function row))))
 107         (database-dump-result-set result-set database)))))
 108
 109 (defmacro do-query (((&rest args) query-expression
 110                      &key (database '*default-database*)
 111                      (types nil))
 112                     &body body)
 113   (let ((result-set (gensym))
 114         (columns (gensym))
 115         (row (gensym))
 116         (db (gensym)))
 117     `(let ((,db ,database))
 118        (multiple-value-bind (,result-set ,columns)
 119            (database-query-result-set ,query-expression ,db
 120                                       :full-set nil :types ,types)
 121          (when ,result-set
 122            (unwind-protect
 123                 (do ((,row (make-list ,columns)))
 124                     ((not (database-store-next-row ,result-set ,db ,row))
 125                      nil)
 126                   (destructuring-bind ,args ,row
 127                     ,@body))
 128              (database-dump-result-set ,result-set ,db)))))))
 129
 130
 131 ;;; Row processing macro
 132
 133
 134
 135 (defun lisp->sql-name (field)
 136   (typecase field
 137     (string field)
 138     (symbol (string-upcase (symbol-name field)))
 139     (cons (cadr field))
 140     (t (format nil "~A" field))))
 141
 142 (defun field-names (field-forms)
 143   "Return a list of field name strings from a fields form"
 144   (loop for field-form in field-forms
 145         collect
 146         (lisp->sql-name
 147          (if (cadr field-form)
 148              (cadr field-form)
 149              (car field-form)))))
 150
 151 (defun from-names (from)
 152   "Return a list of field name strings from a fields form"
 153   (loop for table in (if (atom from) (list from) from)
 154         collect (lisp->sql-name table)))
 155
 156
 157 (defun where-strings (where)
 158   (loop for w in (if (atom (car where)) (list where) where)
 159         collect
 160         (if (consp w)
 161             (format nil "~A ~A ~A" (second w) (first w) (third w))
 162             (format nil "~A" w))))
 163
 164 (defun order-by-strings (order-by)
 165   (loop for o in order-by
 166         collect
 167         (if (atom o)
 168             (lisp->sql-name o)
 169             (format nil "~A ~A" (lisp->sql-name (car o))
 170                     (lisp->sql-name (cadr o))))))
 171
 172 (defun query-string (fields from where distinct order-by limit)
 173   (concatenate
 174    'string
 175    (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
 176            (if distinct "distinct " "") (field-names fields)
 177            (from-names from))
 178    (if where (format nil " where ~{~A~^ ~}"
 179                      (where-strings where)) "")
 180    (if order-by (format nil " order by ~{~A~^, ~}"
 181                         (order-by-strings order-by)))
 182    (if limit (format nil " limit ~D" limit) "")))
 183
 184 (defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
 185   (let ((d (gensym "DISTINCT-"))
 186         (bind-fields (loop for f in fields collect (car f)))
 187         (w (gensym "WHERE-"))
 188         (o (gensym "ORDER-BY-"))
 189         (frm (gensym "FROM-"))
 190         (l (gensym "LIMIT-"))
 191         (q (gensym "QUERY-")))
 192     `(let ((,frm ,from)
 193            (,w ,where)
 194            (,d ,distinct)
 195            (,l ,limit)
 196            (,o ,order-by))
 197       (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
 198         (loop for tuple in (query ,q)
 199               collect (destructuring-bind ,bind-fields tuple
 200                    ,@body))))))
 201
 202 ;;; Marc Battyani : Large objects support
 203
 204 (defun create-large-object (&key (database *default-database*))
 205   "Creates a new large object in the database and returns the object identifier"
 206   (database-create-large-object database))
 207
 208 (defun write-large-object (object-id data &key (database *default-database*))
 209   "Writes data to the large object"
 210   (database-write-large-object object-id data database))
 211
 212 (defun read-large-object (object-id &key (database *default-database*))
 213   "Reads the large object content"
 214   (database-read-large-object object-id database))
 215
 216 (defun delete-large-object (object-id &key (database *default-database*))
 217   "Deletes the large object in the database"
 218   (database-delete-large-object object-id database))
 219
 220