usql/sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; ======================================================================
   3 ;;;; File:    sql.lisp
   4 ;;;; Updated: <04/04/2004 12:05:32 marcusp>
   5 ;;;; ======================================================================
   6 ;;;;
   7 ;;;; Description ==========================================================
   8 ;;;; ======================================================================
   9 ;;;;
  10 ;;;; The CLSQL-USQL Functional Data Manipulation Language (FDML).
  11 ;;;;
  12 ;;;; ======================================================================
  13
  14 (in-package :clsql-usql-sys)
  15
  16
  17 ;;; Basic operations on databases
  18
  19
  20 (defmethod database-query-result-set ((expr %sql-expression) database
  21                                       &key full-set types)
  22   (database-query-result-set (sql-output expr database) database
  23                              :full-set full-set :types types))
  24
  25 (defmethod execute-command ((expr %sql-expression)
  26                             &key (database *default-database*))
  27   (execute-command (sql-output expr database) :database database)
  28   (values))
  29
  30
  31
  32 (defmethod query ((expr %sql-expression) &key (database *default-database*)
  33                   (result-types nil) (flatp nil))
  34   (query (sql-output expr database) :database database :flatp flatp
  35          :result-types result-types))
  36
  37 (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t)
  38                               (database *default-database*))
  39   "The PRINT-QUERY function takes a symbolic SQL query expression and
  40 formatting information and prints onto STREAM a table containing the
  41 results of the query. A list of strings to use as column headings is
  42 given by TITLES, which has a default value of NIL. The FORMATS
  43 argument is a list of format strings used to print each attribute, and
  44 has a default value of T, which means that ~A or ~VA are used if sizes
  45 are provided or computed. The field sizes are given by SIZES. It has a
  46 default value of T, which specifies that minimum sizes are
  47 computed. The output stream is given by STREAM, which has a default
  48 value of T. This specifies that *STANDARD-OUTPUT* is used."
  49   (flet ((compute-sizes (data)
  50            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
  51                    (apply #'mapcar (cons #'list data))))
  52          (format-record (record control sizes)
  53            (format stream "~&~?" control
  54                    (if (null sizes) record
  55                        (mapcan #'(lambda (s f) (list s f)) sizes record)))))
  56     (let* ((query-exp (etypecase query-exp
  57                         (string query-exp)
  58                         (sql-query (sql-output query-exp))))
  59            (data (query query-exp :database database))
  60            (sizes (if (or (null sizes) (listp sizes)) sizes
  61                       (compute-sizes (if titles (cons titles data) data))))
  62            (formats (if (or (null formats) (not (listp formats)))
  63                         (make-list (length (car data)) :initial-element
  64                                    (if (null sizes) "~A " "~VA "))
  65                         formats))
  66            (control-string (format nil "~{~A~}" formats)))
  67       (when titles (format-record titles control-string sizes))
  68       (dolist (d data (values)) (format-record d control-string sizes)))))
  69
  70 (defun insert-records (&key (into nil)
  71                             (attributes nil)
  72                             (values nil)
  73                             (av-pairs nil)
  74                             (query nil)
  75                             (database *default-database*))
  76   "Inserts a set of values into a table. The records created contain
  77 values for attributes (or av-pairs). The argument VALUES is a list of
  78 values. If ATTRIBUTES is supplied then VALUES must be a corresponding
  79 list of values for each of the listed attribute names. If AV-PAIRS is
  80 non-nil, then both ATTRIBUTES and VALUES must be nil. If QUERY is
  81 non-nil, then neither VALUES nor AV-PAIRS should be. QUERY should be a
  82 query expression, and the attribute names in it must also exist in the
  83 table INTO. The default value of DATABASE is *DEFAULT-DATABASE*."
  84   (let ((stmt (make-sql-insert :into into :attrs attributes
  85                                :vals values :av-pairs av-pairs
  86                                :subquery query)))
  87     (execute-command stmt :database database)))
  88
  89 (defun make-sql-insert (&key (into nil)
  90                             (attrs nil)
  91                             (vals nil)
  92                             (av-pairs nil)
  93                             (subquery nil))
  94   (if (null into)
  95       (error 'clsql-sql-syntax-error :reason ":into keyword not supplied"))
  96   (let ((ins (make-instance 'sql-insert :into into)))
  97     (with-slots (attributes values query)
  98       ins
  99       (cond ((and vals (not attrs) (not query) (not av-pairs))
 100              (setf values vals))
 101             ((and vals attrs (not subquery) (not av-pairs))
 102              (setf attributes attrs)
 103              (setf values vals))
 104             ((and av-pairs (not vals) (not attrs) (not subquery))
 105              (setf attributes (mapcar #'car av-pairs))
 106              (setf values (mapcar #'cadr av-pairs)))
 107             ((and subquery (not vals) (not attrs) (not av-pairs))
 108              (setf query subquery))
 109             ((and subquery attrs (not vals) (not av-pairs))
 110              (setf attributes attrs)
 111              (setf query subquery))
 112             (t
 113              (error 'clsql-sql-syntax-error
 114                     :reason "bad or ambiguous keyword combination.")))
 115       ins)))
 116
 117 (defun delete-records (&key (from nil)
 118                             (where nil)
 119                             (database *default-database*))
 120   "Deletes rows from a database table specified by FROM in which the
 121 WHERE condition is true. The argument DATABASE specifies a database
 122 from which the records are to be removed, and defaults to
 123 *default-database*."
 124   (let ((stmt (make-instance 'sql-delete :from from :where where)))
 125     (execute-command stmt :database database)))
 126
 127 (defun update-records (table &key
 128                            (attributes nil)
 129                            (values nil)
 130                            (av-pairs nil)
 131                            (where nil)
 132                            (database *default-database*))
 133   "Changes the values of existing fields in TABLE with columns
 134 specified by ATTRIBUTES and VALUES (or AV-PAIRS) where the WHERE
 135 condition is true."
 136   (when av-pairs
 137     (setf attributes (mapcar #'car av-pairs)
 138           values (mapcar #'cadr av-pairs)))
 139   (let ((stmt (make-instance 'sql-update :table table
 140                              :attributes attributes
 141                              :values values
 142                              :where where)))
 143     (execute-command stmt :database database)))
 144
 145
 146 ;; iteration
 147
 148 (defun map-query (output-type-spec function query-expression
 149                                    &key (database *default-database*)
 150                                    (types nil))
 151   "Map the function over all tuples that are returned by the query in
 152 query-expression.  The results of the function are collected as
 153 specified in output-type-spec and returned like in MAP."
 154   ;; DANGER Will Robinson: Parts of the code for implementing
 155   ;; map-query (including the code below and the helper functions
 156   ;; called) are highly CMU CL specific.
 157   ;; KMR -- these have been replaced with cross-platform instructions above
 158   (macrolet ((type-specifier-atom (type)
 159                `(if (atom ,type) ,type (car ,type))))
 160     (case (type-specifier-atom output-type-spec)
 161       ((nil)
 162        (map-query-for-effect function query-expression database types))
 163       (list
 164        (map-query-to-list function query-expression database types))
 165       ((simple-vector simple-string vector string array simple-array
 166                       bit-vector simple-bit-vector base-string
 167                       simple-base-string)
 168        (map-query-to-simple output-type-spec function query-expression
 169                             database types))
 170       (t
 171        (funcall #'map-query
 172                 (cmucl-compat:result-type-or-lose output-type-spec t)
 173                 function query-expression :database database :types types)))))
 174
 175 (defun map-query-for-effect (function query-expression database types)
 176   (multiple-value-bind (result-set columns)
 177       (database-query-result-set query-expression database :full-set nil
 178                                  :types types)
 179     (when result-set
 180       (unwind-protect
 181            (do ((row (make-list columns)))
 182                ((not (database-store-next-row result-set database row))
 183                 nil)
 184              (apply function row))
 185         (database-dump-result-set result-set database)))))
 186
 187 (defun map-query-to-list (function query-expression database types)
 188   (multiple-value-bind (result-set columns)
 189       (database-query-result-set query-expression database :full-set nil
 190                                  :types types)
 191     (when result-set
 192       (unwind-protect
 193            (let ((result (list nil)))
 194              (do ((row (make-list columns))
 195                   (current-cons result (cdr current-cons)))
 196                  ((not (database-store-next-row result-set database row))
 197                   (cdr result))
 198                (rplacd current-cons (list (apply function row)))))
 199         (database-dump-result-set result-set database)))))
 200
 201 (defun map-query-to-simple (output-type-spec function query-expression
 202                                              database types)
 203   (multiple-value-bind (result-set columns rows)
 204       (database-query-result-set query-expression database :full-set t
 205                                  :types types)
 206     (when result-set
 207       (unwind-protect
 208            (if rows
 209                ;; We know the row count in advance, so we allocate once
 210                (do ((result
 211                      (cmucl-compat:make-sequence-of-type output-type-spec rows))
 212                     (row (make-list columns))
 213                     (index 0 (1+ index)))
 214                    ((not (database-store-next-row result-set database row))
 215                     result)
 216                  (declare (fixnum index))
 217                  (setf (aref result index)
 218                        (apply function row)))
 219                ;; Database can't report row count in advance, so we have
 220                ;; to grow and shrink our vector dynamically
 221                (do ((result
 222                      (cmucl-compat:make-sequence-of-type output-type-spec 100))
 223                     (allocated-length 100)
 224                     (row (make-list columns))
 225                     (index 0 (1+ index)))
 226                    ((not (database-store-next-row result-set database row))
 227                     (cmucl-compat:shrink-vector result index))
 228                  (declare (fixnum allocated-length index))
 229                  (when (>= index allocated-length)
 230                    (setf allocated-length (* allocated-length 2)
 231                          result (adjust-array result allocated-length)))
 232                  (setf (aref result index)
 233                        (apply function row))))
 234         (database-dump-result-set result-set database)))))
 235
 236 (defmacro do-query (((&rest args) query-expression
 237                      &key (database '*default-database*) (types nil))
 238                     &body body)
 239   "Repeatedly executes BODY within a binding of ARGS on the attributes
 240 of each record resulting from QUERY. The return value is determined by
 241 the result of executing BODY. The default value of DATABASE is
 242 *DEFAULT-DATABASE*."
 243   (let ((result-set (gensym))
 244         (columns (gensym))
 245         (row (gensym))
 246         (db (gensym)))
 247     `(let ((,db ,database))
 248       (multiple-value-bind (,result-set ,columns)
 249           (database-query-result-set ,query-expression ,db
 250                                      :full-set nil :types ,types)
 251         (when ,result-set
 252           (unwind-protect
 253                (do ((,row (make-list ,columns)))
 254                    ((not (database-store-next-row ,result-set ,db ,row))
 255                     nil)
 256                  (destructuring-bind ,args ,row
 257                    ,@body))
 258             (database-dump-result-set ,result-set ,db)))))))
 259
 260
 261 ;; output-sql
 262
 263 (defmethod database-output-sql ((str string) database)
 264   (declare (ignore database)
 265            (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
 266            (type (simple-array * (*)) str))
 267   (let ((len (length str)))
 268     (declare (type fixnum len))
 269     (cond ((= len 0)
 270            +empty-string+)
 271           ((and (null (position #\' str))
 272                 (null (position #\\ str)))
 273            (concatenate 'string "'" str "'"))
 274           (t
 275            (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
 276              (do* ((i 0 (incf i))
 277                    (j 1 (incf j)))
 278                   ((= i len) (subseq buf 0 (1+ j)))
 279                (declare (type integer i j))
 280                (let ((char (aref str i)))
 281                  (cond ((eql char #\')
 282                         (setf (aref buf j) #\\)
 283                         (incf j)
 284                         (setf (aref buf j) #\'))
 285                        ((eql char #\\)
 286                         (setf (aref buf j) #\\)
 287                         (incf j)
 288                         (setf (aref buf j) #\\))
 289                        (t
 290                         (setf (aref buf j) char))))))))))
 291
 292 (let ((keyword-package (symbol-package :foo)))
 293   (defmethod database-output-sql ((sym symbol) database)
 294     (declare (ignore database))
 295     (if (equal (symbol-package sym) keyword-package)
 296         (concatenate 'string "'" (string sym) "'")
 297         (symbol-name sym))))
 298
 299 (defmethod database-output-sql ((tee (eql t)) database)
 300   (declare (ignore database))
 301   "'Y'")
 302
 303 (defmethod database-output-sql ((num number) database)
 304   (declare (ignore database))
 305   (princ-to-string num))
 306
 307 (defmethod database-output-sql ((arg list) database)
 308   (if (null arg)
 309       "NULL"
 310       (format nil "(~{~A~^,~})" (mapcar #'(lambda (val)
 311                                             (sql-output val database))
 312                                         arg))))
 313
 314 (defmethod database-output-sql ((arg vector) database)
 315   (format nil "~{~A~^,~}" (map 'list #'(lambda (val)
 316                                          (sql-output val database))
 317                                arg)))
 318
 319 (defmethod database-output-sql ((self wall-time) database)
 320   (declare (ignore database))
 321   (db-timestring self))
 322
 323 (defmethod database-output-sql (thing database)
 324   (if (or (null thing)
 325           (eq 'null thing))
 326       "NULL"
 327     (error 'clsql-simple-error
 328            :format-control
 329            "No type conversion to SQL for ~A is defined for DB ~A."
 330            :format-arguments (list (type-of thing) (type-of database)))))
 331
 332 (defmethod output-sql-hash-key ((arg vector) &optional database)
 333   (list 'vector (map 'list (lambda (arg)
 334                              (or (output-sql-hash-key arg database)
 335                                  (return-from output-sql-hash-key nil)))
 336                      arg)))
 337
 338 (defmethod output-sql (expr &optional (database *default-database*))
 339   (write-string (database-output-sql expr database) *sql-stream*)
 340   t)
 341
 342 (defmethod output-sql ((expr list) &optional (database *default-database*))
 343   (if (null expr)
 344       (write-string +null-string+ *sql-stream*)
 345       (progn
 346         (write-char #\( *sql-stream*)
 347         (do ((item expr (cdr item)))
 348             ((null (cdr item))
 349              (output-sql (car item) database))
 350           (output-sql (car item) database)
 351           (write-char #\, *sql-stream*))
 352         (write-char #\) *sql-stream*)))
 353   t)
 354
 355