1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; Classes defining SQL expressions and methods for formatting the
7 ;;;; appropriate SQL commands.
9 ;;;; This file is part of CLSQL.
11 ;;;; CLSQL users are granted the rights to distribute and use this software
12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
14 ;;;; *************************************************************************
16 (in-package #:clsql-sys
)
18 (defvar +empty-string
+ "''")
20 (defvar +null-string
+ "NULL")
22 (defvar *sql-stream
* nil
23 "stream which accumulates SQL output")
25 (defun sql-output (sql-expr &optional database
)
26 "Top-level call for generating SQL strings. Returns an SQL
27 string appropriate for DATABASE which corresponds to the
28 supplied lisp expression SQL-EXPR."
29 (progv '(*sql-stream
*)
30 `(,(make-string-output-stream))
31 (output-sql sql-expr database
)
32 (get-output-stream-string *sql-stream
*)))
34 (defmethod output-sql (expr database
)
35 (write-string (database-output-sql expr database
) *sql-stream
*)
38 (defvar *output-hash
* (make-hash-table :test
#'equal
)
39 "For caching generated SQL strings.")
41 (defmethod output-sql :around
((sql t
) database
)
42 (let* ((hash-key (output-sql-hash-key sql database
))
43 (hash-value (when hash-key
(gethash hash-key
*output-hash
*))))
44 (cond ((and hash-key hash-value
)
45 (write-string hash-value
*sql-stream
*))
47 (let ((*sql-stream
* (make-string-output-stream)))
49 (setf hash-value
(get-output-stream-string *sql-stream
*))
50 (setf (gethash hash-key
*output-hash
*) hash-value
))
51 (write-string hash-value
*sql-stream
*))
53 (call-next-method)))))
55 (defmethod output-sql-hash-key (expr database
)
56 (declare (ignore expr database
))
60 (defclass %sql-expression
()
63 (defmethod output-sql ((expr %sql-expression
) database
)
64 (declare (ignore database
))
65 (write-string +null-string
+ *sql-stream
*))
67 (defmethod print-object ((self %sql-expression
) stream
)
68 (print-unreadable-object
70 (write-string (sql-output self
) stream
))
73 ;; For straight up strings
75 (defclass sql
(%sql-expression
)
79 (:documentation
"A literal SQL expression."))
81 (defmethod make-load-form ((sql sql
) &optional environment
)
82 (declare (ignore environment
))
85 `(make-instance 'sql
:string
',text
)))
87 (defmethod output-sql ((expr sql
) database
)
88 (declare (ignore database
))
89 (write-string (slot-value expr
'text
) *sql-stream
*)
92 (defmethod print-object ((ident sql
) stream
)
93 (format stream
"#<~S \"~A\">"
95 (sql-output ident nil
))
98 ;; For SQL Identifiers of generic type
100 (defclass sql-ident
(%sql-expression
)
103 :initform
+null-string
+))
104 (:documentation
"An SQL identifer."))
106 (defmethod make-load-form ((sql sql-ident
) &optional environment
)
107 (declare (ignore environment
))
110 `(make-instance 'sql-ident
:name
',name
)))
112 (defmethod output-sql ((expr sql-ident
) database
)
113 (with-slots (name) expr
115 (convert-to-db-default-case
118 (symbol (symbol-name name
)))
123 ;; For SQL Identifiers for attributes
125 (defclass sql-ident-attribute
(sql-ident)
128 :initform
+null-string
+)
131 :initform
+null-string
+))
132 (:documentation
"An SQL Attribute identifier."))
134 (defmethod collect-table-refs (sql)
135 (declare (ignore sql
))
138 (defmethod collect-table-refs ((sql sql-ident-attribute
))
139 (let ((qual (slot-value sql
'qualifier
)))
140 (if (and qual
(symbolp (slot-value sql
'qualifier
)))
141 (list (make-instance 'sql-ident-table
:name
142 (slot-value sql
'qualifier
))))))
144 (defmethod make-load-form ((sql sql-ident-attribute
) &optional environment
)
145 (declare (ignore environment
))
146 (with-slots (qualifier type name
)
148 `(make-instance 'sql-ident-attribute
:name
',name
149 :qualifier
',qualifier
152 (defmethod output-sql ((expr sql-ident-attribute
) database
)
153 (with-slots (qualifier name type
) expr
154 (if (and (not qualifier
) (not type
))
156 ;; Honor care of name
158 (write-string name
*sql-stream
*))
160 (write-string (sql-escape (convert-to-db-default-case
161 (symbol-name name
) database
)) *sql-stream
*)))
163 ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it
164 ;;; should not be output in SQL statements
166 (format *sql-stream
* "~@[~A.~]~A~@[ ~A~]"
168 (convert-to-db-default-case (sql-escape qualifier
) database
))
169 (sql-escape (convert-to-db-default-case name database
))
171 (convert-to-db-default-case (symbol-name type
) database
)))
172 (format *sql-stream
* "~@[~A.~]~A"
175 (string (format nil
"~s" qualifier
))
176 (t (convert-to-db-default-case (sql-escape qualifier
)
178 (sql-escape (convert-to-db-default-case name database
))))
181 (defmethod output-sql-hash-key ((expr sql-ident-attribute
) database
)
182 (with-slots (qualifier name type
)
184 (list (and database
(database-underlying-type database
))
185 'sql-ident-attribute qualifier name type
)))
187 ;; For SQL Identifiers for tables
189 (defclass sql-ident-table
(sql-ident)
191 :initarg
:table-alias
:initform nil
))
192 (:documentation
"An SQL table identifier."))
194 (defmethod make-load-form ((sql sql-ident-table
) &optional environment
)
195 (declare (ignore environment
))
196 (with-slots (alias name
)
198 `(make-instance 'sql-ident-table
:name
',name
:table-alias
',alias
)))
200 (defmethod output-sql ((expr sql-ident-table
) database
)
201 (with-slots (name alias
) expr
202 (let ((namestr (if (symbolp name
)
207 (sql-escape (convert-to-db-default-case namestr database
))
211 (sql-escape (convert-to-db-default-case namestr database
))
213 (write-char #\Space
*sql-stream
*)
214 (format *sql-stream
* "~s" alias
)))))
217 (defmethod output-sql-hash-key ((expr sql-ident-table
) database
)
218 (with-slots (name alias
)
220 (list (and database
(database-underlying-type database
))
221 'sql-ident-table name alias
)))
223 (defclass sql-relational-exp
(%sql-expression
)
228 :initarg
:sub-expressions
230 (:documentation
"An SQL relational expression."))
232 (defmethod make-load-form ((self sql-relational-exp
) &optional environment
)
233 (make-load-form-saving-slots self
234 :slot-names
'(operator sub-expressions
)
235 :environment environment
))
237 (defmethod collect-table-refs ((sql sql-relational-exp
))
239 (dolist (exp (slot-value sql
'sub-expressions
))
240 (let ((refs (collect-table-refs exp
)))
241 (if refs
(setf tabs
(append refs tabs
)))))
242 (remove-duplicates tabs
243 :test
(lambda (tab1 tab2
)
244 (equal (slot-value tab1
'name
)
245 (slot-value tab2
'name
))))))
250 ;; Write SQL for relational operators (like 'AND' and 'OR').
251 ;; should do arity checking of subexpressions
253 (defmethod output-sql ((expr sql-relational-exp
) database
)
254 (with-slots (operator sub-expressions
)
256 (let ((subs (if (consp (car sub-expressions
))
257 (car sub-expressions
)
259 (write-char #\
( *sql-stream
*)
260 (do ((sub subs
(cdr sub
)))
261 ((null (cdr sub
)) (output-sql (car sub
) database
))
262 (output-sql (car sub
) database
)
263 (write-char #\Space
*sql-stream
*)
264 (output-sql operator database
)
265 (write-char #\Space
*sql-stream
*))
266 (write-char #\
) *sql-stream
*)))
269 (defclass sql-upcase-like
(sql-relational-exp)
271 (:documentation
"An SQL 'like' that upcases its arguments."))
273 (defmethod output-sql ((expr sql-upcase-like
) database
)
274 (flet ((write-term (term)
275 (write-string "upper(" *sql-stream
*)
276 (output-sql term database
)
277 (write-char #\
) *sql-stream
*)))
278 (with-slots (sub-expressions)
280 (let ((subs (if (consp (car sub-expressions
))
281 (car sub-expressions
)
283 (write-char #\
( *sql-stream
*)
284 (do ((sub subs
(cdr sub
)))
285 ((null (cdr sub
)) (write-term (car sub
)))
286 (write-term (car sub
))
287 (write-string " LIKE " *sql-stream
*))
288 (write-char #\
) *sql-stream
*))))
291 (defclass sql-assignment-exp
(sql-relational-exp)
293 (:documentation
"An SQL Assignment expression."))
296 (defmethod output-sql ((expr sql-assignment-exp
) database
)
297 (with-slots (operator sub-expressions
)
299 (do ((sub sub-expressions
(cdr sub
)))
300 ((null (cdr sub
)) (output-sql (car sub
) database
))
301 (output-sql (car sub
) database
)
302 (write-char #\Space
*sql-stream
*)
303 (output-sql operator database
)
304 (write-char #\Space
*sql-stream
*)))
307 (defclass sql-value-exp
(%sql-expression
)
315 "An SQL value expression.")
318 (defmethod collect-table-refs ((sql sql-value-exp
))
320 (if (listp (slot-value sql
'components
))
322 (dolist (exp (slot-value sql
'components
))
323 (let ((refs (collect-table-refs exp
)))
324 (if refs
(setf tabs
(append refs tabs
)))))
325 (remove-duplicates tabs
326 :test
(lambda (tab1 tab2
)
327 (equal (slot-value tab1
'name
)
328 (slot-value tab2
'name
)))))
333 (defmethod output-sql ((expr sql-value-exp
) database
)
334 (with-slots (modifier components
)
338 (write-char #\
( *sql-stream
*)
339 (output-sql modifier database
)
340 (write-char #\Space
*sql-stream
*)
341 (output-sql components database
)
342 (write-char #\
) *sql-stream
*))
343 (output-sql components database
))))
345 (defclass sql-typecast-exp
(sql-value-exp)
347 (:documentation
"An SQL typecast expression."))
349 (defmethod output-sql ((expr sql-typecast-exp
) database
)
350 (with-slots (components)
352 (output-sql components database
)))
354 (defmethod collect-table-refs ((sql sql-typecast-exp
))
355 (when (slot-value sql
'components
)
356 (collect-table-refs (slot-value sql
'components
))))
358 (defclass sql-function-exp
(%sql-expression
)
366 "An SQL function expression."))
368 (defmethod collect-table-refs ((sql sql-function-exp
))
370 (dolist (exp (slot-value sql
'args
))
371 (let ((refs (collect-table-refs exp
)))
372 (if refs
(setf tabs
(append refs tabs
)))))
373 (remove-duplicates tabs
374 :test
(lambda (tab1 tab2
)
375 (equal (slot-value tab1
'name
)
376 (slot-value tab2
'name
))))))
377 (defvar *in-subselect
* nil
)
379 (defmethod output-sql ((expr sql-function-exp
) database
)
380 (with-slots (name args
)
382 (output-sql name database
)
383 (let ((*in-subselect
* nil
)) ;; aboid double parens
384 (when args
(output-sql args database
))))
388 (defclass sql-between-exp
(sql-function-exp)
390 (:documentation
"An SQL between expression."))
392 (defmethod output-sql ((expr sql-between-exp
) database
)
393 (with-slots (name args
)
395 (output-sql (first args
) database
)
396 (write-string " BETWEEN " *sql-stream
*)
397 (output-sql (second args
) database
)
398 (write-string " AND " *sql-stream
*)
399 (output-sql (third args
) database
))
402 (defclass sql-query-modifier-exp
(%sql-expression
)
403 ((modifier :initarg
:modifier
:initform nil
)
404 (components :initarg
:components
:initform nil
))
405 (:documentation
"An SQL query modifier expression."))
407 (defmethod output-sql ((expr sql-query-modifier-exp
) database
)
408 (with-slots (modifier components
)
410 (output-sql modifier database
)
411 (write-string " " *sql-stream
*)
412 (output-sql (car components
) database
)
414 (mapc #'(lambda (comp)
415 (write-string ", " *sql-stream
*)
416 (output-sql comp database
))
420 (defclass sql-set-exp
(%sql-expression
)
425 :initarg
:sub-expressions
427 (:documentation
"An SQL set expression."))
429 (defmethod collect-table-refs ((sql sql-set-exp
))
431 (dolist (exp (slot-value sql
'sub-expressions
))
432 (let ((refs (collect-table-refs exp
)))
433 (if refs
(setf tabs
(append refs tabs
)))))
434 (remove-duplicates tabs
435 :test
(lambda (tab1 tab2
)
436 (equal (slot-value tab1
'name
)
437 (slot-value tab2
'name
))))))
439 (defmethod output-sql ((expr sql-set-exp
) database
)
440 (with-slots (operator sub-expressions
)
442 (let ((subs (if (consp (car sub-expressions
))
443 (car sub-expressions
)
445 (when (= (length subs
) 1)
446 (output-sql operator database
)
447 (write-char #\Space
*sql-stream
*))
448 (do ((sub subs
(cdr sub
)))
449 ((null (cdr sub
)) (output-sql (car sub
) database
))
450 (output-sql (car sub
) database
)
451 (write-char #\Space
*sql-stream
*)
452 (output-sql operator database
)
453 (write-char #\Space
*sql-stream
*))))
456 (defclass sql-query
(%sql-expression
)
467 :initarg
:set-operation
499 (:documentation
"An SQL SELECT query."))
501 (defclass sql-object-query
(%sql-expression
)
515 (defmethod collect-table-refs ((sql sql-query
))
516 (remove-duplicates (collect-table-refs (slot-value sql
'where
))
517 :test
(lambda (tab1 tab2
)
518 (equal (slot-value tab1
'name
)
519 (slot-value tab2
'name
)))))
521 (defvar *select-arguments
*
522 '(:all
:database
:distinct
:flatp
:from
:group-by
:having
:order-by
523 :set-operation
:where
:offset
:limit
:inner-join
:on
524 ;; below keywords are not a SQL argument, but these keywords may terminate select
527 (defun query-arg-p (sym)
528 (member sym
*select-arguments
*))
530 (defun query-get-selections (select-args)
531 "Return two values: the list of select-args up to the first keyword,
532 uninclusive, and the args from that keyword to the end."
533 (let ((first-key-arg (position-if #'query-arg-p select-args
)))
535 (values (subseq select-args
0 first-key-arg
)
536 (subseq select-args first-key-arg
))
539 (defun make-query (&rest args
)
540 (flet ((select-objects (target-args)
542 (every #'(lambda (arg)
544 (find-class arg nil
)))
546 (multiple-value-bind (selections arglist
)
547 (query-get-selections args
)
548 (if (select-objects selections
)
549 (destructuring-bind (&key flatp refresh
&allow-other-keys
) arglist
550 (make-instance 'sql-object-query
:objects selections
551 :flatp flatp
:refresh refresh
553 (destructuring-bind (&key all flatp set-operation distinct from where
554 group-by having order-by
555 offset limit inner-join on
&allow-other-keys
)
557 (if (null selections
)
558 (error "No target columns supplied to select statement."))
560 (error "No source tables supplied to select statement."))
561 (make-instance 'sql-query
:selections selections
562 :all all
:flatp flatp
:set-operation set-operation
563 :distinct distinct
:from from
:where where
564 :limit limit
:offset offset
565 :group-by group-by
:having having
:order-by order-by
566 :inner-join inner-join
:on on
))))))
568 (defmethod output-sql ((query sql-query
) database
)
569 (with-slots (distinct selections from where group-by having order-by
570 limit offset inner-join on all set-operation
)
573 (write-string "(" *sql-stream
*))
574 (write-string "SELECT " *sql-stream
*)
576 (write-string "ALL " *sql-stream
*))
577 (when (and distinct
(not all
))
578 (write-string "DISTINCT " *sql-stream
*)
579 (unless (eql t distinct
)
580 (write-string "ON " *sql-stream
*)
581 (output-sql distinct database
)
582 (write-char #\Space
*sql-stream
*)))
583 (output-sql (apply #'vector selections
) database
)
585 (write-string " FROM " *sql-stream
*)
586 (flet ((ident-table-equal (a b
)
587 (and (if (and (eql (type-of a
) 'sql-ident-table
)
588 (eql (type-of b
) 'sql-ident-table
))
589 (string-equal (slot-value a
'alias
)
590 (slot-value b
'alias
))
592 (string-equal (sql-escape (slot-value a
'name
))
593 (sql-escape (slot-value b
'name
))))))
595 (list (output-sql (apply #'vector
596 (remove-duplicates from
597 :test
#'ident-table-equal
))
599 (string (write-string from
*sql-stream
*))
600 (t (let ((*in-subselect
* t
))
601 (output-sql from database
))))))
603 (write-string " INNER JOIN " *sql-stream
*)
604 (output-sql inner-join database
))
606 (write-string " ON " *sql-stream
*)
607 (output-sql on database
))
609 (write-string " WHERE " *sql-stream
*)
610 (let ((*in-subselect
* t
))
611 (output-sql where database
)))
613 (write-string " GROUP BY " *sql-stream
*)
615 (do ((order group-by
(cdr order
)))
617 (let ((item (car order
)))
620 (output-sql (car item
) database
)
621 (format *sql-stream
* " ~A" (cadr item
)))
623 (output-sql item database
)))
625 (write-char #\
, *sql-stream
*))))
626 (output-sql group-by database
)))
628 (write-string " HAVING " *sql-stream
*)
629 (output-sql having database
))
631 (write-string " ORDER BY " *sql-stream
*)
633 (do ((order order-by
(cdr order
)))
635 (let ((item (car order
)))
638 (output-sql (car item
) database
)
639 (format *sql-stream
* " ~A" (cadr item
)))
641 (output-sql item database
)))
643 (write-char #\
, *sql-stream
*))))
644 (output-sql order-by database
)))
646 (write-string " LIMIT " *sql-stream
*)
647 (output-sql limit database
))
649 (write-string " OFFSET " *sql-stream
*)
650 (output-sql offset database
))
652 (write-string ")" *sql-stream
*))
654 (write-char #\Space
*sql-stream
*)
655 (output-sql set-operation database
)))
658 (defmethod output-sql ((query sql-object-query
) database
)
659 (declare (ignore database
))
660 (with-slots (objects)
663 (format *sql-stream
* "(~{~A~^ ~})" objects
))))
668 (defclass sql-insert
(%sql-expression
)
682 "An SQL INSERT statement."))
684 (defmethod output-sql ((ins sql-insert
) database
)
685 (with-slots (into attributes values query
)
687 (write-string "INSERT INTO " *sql-stream
*)
690 (string (sql-expression :attribute into
))
694 (write-char #\Space
*sql-stream
*)
695 (output-sql attributes database
))
697 (write-string " VALUES " *sql-stream
*)
698 (output-sql values database
))
700 (write-char #\Space
*sql-stream
*)
701 (output-sql query database
)))
706 (defclass sql-delete
(%sql-expression
)
714 "An SQL DELETE statement."))
716 (defmethod output-sql ((stmt sql-delete
) database
)
717 (with-slots (from where
)
719 (write-string "DELETE FROM " *sql-stream
*)
721 ((or symbol string
) (write-string (sql-escape from
) *sql-stream
*))
722 (t (output-sql from database
)))
724 (write-string " WHERE " *sql-stream
*)
725 (output-sql where database
)))
730 (defclass sql-update
(%sql-expression
)
743 (:documentation
"An SQL UPDATE statement."))
745 (defmethod output-sql ((expr sql-update
) database
)
746 (with-slots (table where attributes values
)
748 (flet ((update-assignments ()
749 (mapcar #'(lambda (a b
)
750 (make-instance 'sql-assignment-exp
752 :sub-expressions
(list a b
)))
754 (write-string "UPDATE " *sql-stream
*)
755 (output-sql table database
)
756 (write-string " SET " *sql-stream
*)
757 (output-sql (apply #'vector
(update-assignments)) database
)
759 (write-string " WHERE " *sql-stream
*)
760 (output-sql where database
))))
765 (defclass sql-create-table
(%sql-expression
)
776 :initarg
:transactions
779 "An SQL CREATE TABLE statement."))
781 ;; Here's a real warhorse of a function!
783 (declaim (inline listify
))
789 (defmethod output-sql ((stmt sql-create-table
) database
)
790 (flet ((output-column (column-spec)
791 (destructuring-bind (name type
&optional db-type
&rest constraints
)
793 (let ((type (listify type
)))
794 (output-sql name database
)
795 (write-char #\Space
*sql-stream
*)
797 (if (stringp db-type
) db-type
; override definition
798 (database-get-type-specifier (car type
) (cdr type
) database
799 (database-underlying-type database
)))
801 (let ((constraints (database-constraint-statement
802 (if (and db-type
(symbolp db-type
))
803 (cons db-type constraints
)
807 (write-string " " *sql-stream
*)
808 (write-string constraints
*sql-stream
*)))))))
809 (with-slots (name columns modifiers transactions
)
811 (write-string "CREATE TABLE " *sql-stream
*)
812 (output-sql name database
)
813 (write-string " (" *sql-stream
*)
814 (do ((column columns
(cdr column
)))
816 (output-column (car column
)))
817 (output-column (car column
))
818 (write-string ", " *sql-stream
*))
820 (do ((modifier (listify modifiers
) (cdr modifier
)))
822 (write-string ", " *sql-stream
*)
823 (write-string (car modifier
) *sql-stream
*)))
824 (write-char #\
) *sql-stream
*)
825 (when (and (eq :mysql
(database-underlying-type database
))
827 (db-type-transaction-capable?
:mysql database
))
828 (write-string " Type=InnoDB" *sql-stream
*))))
834 (defclass sql-create-view
(%sql-expression
)
835 ((name :initarg
:name
:initform nil
)
836 (column-list :initarg
:column-list
:initform nil
)
837 (query :initarg
:query
:initform nil
)
838 (with-check-option :initarg
:with-check-option
:initform nil
))
839 (:documentation
"An SQL CREATE VIEW statement."))
841 (defmethod output-sql ((stmt sql-create-view
) database
)
842 (with-slots (name column-list query with-check-option
) stmt
843 (write-string "CREATE VIEW " *sql-stream
*)
844 (output-sql name database
)
845 (when column-list
(write-string " " *sql-stream
*)
846 (output-sql (listify column-list
) database
))
847 (write-string " AS " *sql-stream
*)
848 (output-sql query database
)
849 (when with-check-option
(write-string " WITH CHECK OPTION" *sql-stream
*))))
853 ;; DATABASE-OUTPUT-SQL
856 (defmethod database-output-sql ((str string
) database
)
857 (declare (optimize (speed 3) (safety 1)
858 #+cmu
(extensions:inhibit-warnings
3)))
859 (let ((len (length str
)))
860 (declare (type fixnum len
))
863 ((and (null (position #\' str
))
864 (null (position #\\ str
)))
865 (concatenate 'string
"'" str
"'"))
867 (let ((buf (make-string (+ (* len
2) 2) :initial-element
#\')))
868 (declare (simple-string buf
))
871 ((= i len
) (subseq buf
0 (1+ j
)))
872 (declare (type fixnum i j
))
873 (let ((char (aref str i
)))
874 (declare (character char
))
875 (cond ((char= char
#\')
876 (setf (aref buf j
) #\')
878 (setf (aref buf j
) #\'))
879 ((and (char= char
#\\)
880 ;; MTP: only escape backslash with pgsql/mysql
881 (member (database-underlying-type database
)
882 '(:postgresql
:mysql
)
884 (setf (aref buf j
) #\\)
886 (setf (aref buf j
) #\\))
888 (setf (aref buf j
) char
))))))))))
890 (let ((keyword-package (symbol-package :foo
)))
891 (defmethod database-output-sql ((sym symbol
) database
)
894 (convert-to-db-default-case
895 (if (equal (symbol-package sym
) keyword-package
)
896 (concatenate 'string
"'" (string sym
) "'")
900 (defmethod database-output-sql ((tee (eql t
)) database
)
901 (declare (ignore database
))
904 (defmethod database-output-sql ((num number
) database
)
905 (declare (ignore database
))
906 (number-to-sql-string num
))
908 (defmethod database-output-sql ((arg list
) database
)
911 (format nil
"(~{~A~^,~})" (mapcar #'(lambda (val)
912 (sql-output val database
))
915 (defmethod database-output-sql ((arg vector
) database
)
916 (format nil
"~{~A~^,~}" (map 'list
#'(lambda (val)
917 (sql-output val database
))
920 (defmethod output-sql-hash-key ((arg vector
) database
)
921 (list 'vector
(map 'list
(lambda (arg)
922 (or (output-sql-hash-key arg database
)
923 (return-from output-sql-hash-key nil
)))
926 (defmethod database-output-sql ((self wall-time
) database
)
927 (declare (ignore database
))
928 (db-timestring self
))
930 (defmethod database-output-sql ((self date
) database
)
931 (declare (ignore database
))
932 (db-datestring self
))
934 (defmethod database-output-sql ((self duration
) database
)
935 (declare (ignore database
))
936 (format nil
"'~a'" (duration-timestring self
)))
939 (defmethod database-output-sql ((self money
) database
)
940 (database-output-sql (slot-value self
'odcl
::units
) database
))
942 (defmethod database-output-sql (thing database
)
946 (error 'sql-user-error
949 "No type conversion to SQL for ~A is defined for DB ~A."
950 (type-of thing
) (type-of database
)))))
954 ;; Column constraint types and conversion to SQL
957 (defparameter *constraint-types
*
959 (cons (symbol-name-default-case "NOT-NULL") "NOT NULL")
960 (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY")
961 (cons (symbol-name-default-case "NOT") "NOT")
962 (cons (symbol-name-default-case "NULL") "NULL")
963 (cons (symbol-name-default-case "PRIMARY") "PRIMARY")
964 (cons (symbol-name-default-case "KEY") "KEY")
965 (cons (symbol-name-default-case "UNSIGNED") "UNSIGNED")
966 (cons (symbol-name-default-case "ZEROFILL") "ZEROFILL")
967 (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT")
968 (cons (symbol-name-default-case "UNIQUE") "UNIQUE")))
970 (defmethod database-constraint-statement (constraint-list database
)
971 (declare (ignore database
))
972 (make-constraints-description constraint-list
))
974 (defun make-constraints-description (constraint-list)
977 (do ((constraint constraint-list
(cdr constraint
)))
978 ((null constraint
) string
)
979 (let ((output (assoc (symbol-name (car constraint
))
983 (error 'sql-user-error
984 :message
(format nil
"unsupported column constraint '~A'"
986 (setq string
(concatenate 'string string
(cdr output
))))
987 (if (< 1 (length constraint
))
988 (setq string
(concatenate 'string string
" "))))))))