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 *default-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
117 (symbol (symbol-name name
) database
))
121 ;; For SQL Identifiers for attributes
123 (defclass sql-ident-attribute
(sql-ident)
126 :initform
+null-string
+)
129 :initform
+null-string
+))
130 (:documentation
"An SQL Attribute identifier."))
132 (defmethod collect-table-refs (sql)
133 (declare (ignore sql
))
136 (defmethod collect-table-refs ((sql sql-ident-attribute
))
137 (let ((qual (slot-value sql
'qualifier
)))
139 (list (make-instance 'sql-ident-table
:name qual
)))))
141 (defmethod make-load-form ((sql sql-ident-attribute
) &optional environment
)
142 (declare (ignore environment
))
143 (with-slots (qualifier type name
)
145 `(make-instance 'sql-ident-attribute
:name
',name
146 :qualifier
',qualifier
149 (defmethod output-sql ((expr sql-ident-attribute
) database
)
150 (with-slots (qualifier name type
) expr
151 (if (and (not qualifier
) (not type
))
154 (write-string name
*sql-stream
*))
157 (sql-escape (symbol-name name
)) *sql-stream
*)))
159 ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it
160 ;;; should not be output in SQL statements
162 (format *sql-stream
* "~@[~A.~]~A~@[ ~A~]"
164 (sql-escape qualifier
))
168 (format *sql-stream
* "~@[~A.~]~A"
171 (string (format nil
"~s" qualifier
))
172 (t (sql-escape qualifier
))))
174 (string (format nil
"~s" (sql-escape name
)))
175 (t (sql-escape name
)))))
178 (defmethod output-sql-hash-key ((expr sql-ident-attribute
) database
)
179 (with-slots (qualifier name type
)
181 (list (and database
(database-underlying-type database
))
182 'sql-ident-attribute qualifier name type
)))
184 ;; For SQL Identifiers for tables
186 (defclass sql-ident-table
(sql-ident)
188 :initarg
:table-alias
:initform nil
))
189 (:documentation
"An SQL table identifier."))
191 (defmethod make-load-form ((sql sql-ident-table
) &optional environment
)
192 (declare (ignore environment
))
193 (with-slots (alias name
)
195 `(make-instance 'sql-ident-table
:name
',name
:table-alias
',alias
)))
197 (defmethod output-sql ((expr sql-ident-table
) database
)
198 (with-slots (name alias
) expr
201 (format *sql-stream
* "~s" (sql-escape name
)))
203 (write-string (sql-escape name
) *sql-stream
*)))
205 (format *sql-stream
* " ~s" alias
)))
208 (defmethod output-sql-hash-key ((expr sql-ident-table
) database
)
209 (with-slots (name alias
)
211 (list (and database
(database-underlying-type database
))
212 'sql-ident-table name alias
)))
214 (defclass sql-relational-exp
(%sql-expression
)
219 :initarg
:sub-expressions
221 (:documentation
"An SQL relational expression."))
223 (defmethod make-load-form ((self sql-relational-exp
) &optional environment
)
224 (make-load-form-saving-slots self
225 :slot-names
'(operator sub-expressions
)
226 :environment environment
))
228 (defmethod collect-table-refs ((sql sql-relational-exp
))
230 (dolist (exp (slot-value sql
'sub-expressions
))
231 (let ((refs (collect-table-refs exp
)))
232 (if refs
(setf tabs
(append refs tabs
)))))
233 (remove-duplicates tabs
234 :test
(lambda (tab1 tab2
)
235 (equal (slot-value tab1
'name
)
236 (slot-value tab2
'name
))))))
241 ;; Write SQL for relational operators (like 'AND' and 'OR').
242 ;; should do arity checking of subexpressions
244 (defmethod output-sql ((expr sql-relational-exp
) database
)
245 (with-slots (operator sub-expressions
)
247 (let ((subs (if (consp (car sub-expressions
))
248 (car sub-expressions
)
250 (write-char #\
( *sql-stream
*)
251 (do ((sub subs
(cdr sub
)))
252 ((null (cdr sub
)) (output-sql (car sub
) database
))
253 (output-sql (car sub
) database
)
254 (write-char #\Space
*sql-stream
*)
255 (output-sql operator database
)
256 (write-char #\Space
*sql-stream
*))
257 (write-char #\
) *sql-stream
*)))
260 (defclass sql-upcase-like
(sql-relational-exp)
262 (:documentation
"An SQL 'like' that upcases its arguments."))
264 (defmethod output-sql ((expr sql-upcase-like
) database
)
265 (flet ((write-term (term)
266 (write-string "upper(" *sql-stream
*)
267 (output-sql term database
)
268 (write-char #\
) *sql-stream
*)))
269 (with-slots (sub-expressions)
271 (let ((subs (if (consp (car sub-expressions
))
272 (car sub-expressions
)
274 (write-char #\
( *sql-stream
*)
275 (do ((sub subs
(cdr sub
)))
276 ((null (cdr sub
)) (write-term (car sub
)))
277 (write-term (car sub
))
278 (write-string " LIKE " *sql-stream
*))
279 (write-char #\
) *sql-stream
*))))
282 (defclass sql-assignment-exp
(sql-relational-exp)
284 (:documentation
"An SQL Assignment expression."))
287 (defmethod output-sql ((expr sql-assignment-exp
) database
)
288 (with-slots (operator sub-expressions
)
290 (do ((sub sub-expressions
(cdr sub
)))
291 ((null (cdr sub
)) (output-sql (car sub
) database
))
292 (output-sql (car sub
) database
)
293 (write-char #\Space
*sql-stream
*)
294 (output-sql operator database
)
295 (write-char #\Space
*sql-stream
*)))
298 (defclass sql-value-exp
(%sql-expression
)
306 "An SQL value expression.")
309 (defmethod collect-table-refs ((sql sql-value-exp
))
311 (if (listp (slot-value sql
'components
))
313 (dolist (exp (slot-value sql
'components
))
314 (let ((refs (collect-table-refs exp
)))
315 (if refs
(setf tabs
(append refs tabs
)))))
316 (remove-duplicates tabs
317 :test
(lambda (tab1 tab2
)
318 (equal (slot-value tab1
'name
)
319 (slot-value tab2
'name
)))))
324 (defmethod output-sql ((expr sql-value-exp
) database
)
325 (with-slots (modifier components
)
329 (write-char #\
( *sql-stream
*)
330 (output-sql modifier database
)
331 (write-char #\Space
*sql-stream
*)
332 (output-sql components database
)
333 (write-char #\
) *sql-stream
*))
334 (output-sql components database
))))
336 (defclass sql-typecast-exp
(sql-value-exp)
338 (:documentation
"An SQL typecast expression."))
340 (defmethod output-sql ((expr sql-typecast-exp
) database
)
341 (with-slots (components)
343 (output-sql components database
)))
345 (defmethod collect-table-refs ((sql sql-typecast-exp
))
346 (when (slot-value sql
'components
)
347 (collect-table-refs (slot-value sql
'components
))))
349 (defclass sql-function-exp
(%sql-expression
)
357 "An SQL function expression."))
359 (defmethod collect-table-refs ((sql sql-function-exp
))
361 (dolist (exp (slot-value sql
'args
))
362 (let ((refs (collect-table-refs exp
)))
363 (if refs
(setf tabs
(append refs tabs
)))))
364 (remove-duplicates tabs
365 :test
(lambda (tab1 tab2
)
366 (equal (slot-value tab1
'name
)
367 (slot-value tab2
'name
))))))
368 (defvar *in-subselect
* nil
)
370 (defmethod output-sql ((expr sql-function-exp
) database
)
371 (with-slots (name args
)
373 (output-sql name database
)
374 (let ((*in-subselect
* nil
)) ;; aboid double parens
375 (when args
(output-sql args database
))))
379 (defclass sql-between-exp
(sql-function-exp)
381 (:documentation
"An SQL between expression."))
383 (defmethod output-sql ((expr sql-between-exp
) database
)
386 (output-sql (first args
) database
)
387 (write-string " BETWEEN " *sql-stream
*)
388 (output-sql (second args
) database
)
389 (write-string " AND " *sql-stream
*)
390 (output-sql (third args
) database
))
393 (defclass sql-query-modifier-exp
(%sql-expression
)
394 ((modifier :initarg
:modifier
:initform nil
)
395 (components :initarg
:components
:initform nil
))
396 (:documentation
"An SQL query modifier expression."))
398 (defmethod output-sql ((expr sql-query-modifier-exp
) database
)
399 (with-slots (modifier components
)
401 (output-sql modifier database
)
402 (write-string " " *sql-stream
*)
403 (output-sql (car components
) database
)
405 (mapc #'(lambda (comp)
406 (write-string ", " *sql-stream
*)
407 (output-sql comp database
))
411 (defclass sql-set-exp
(%sql-expression
)
416 :initarg
:sub-expressions
418 (:documentation
"An SQL set expression."))
420 (defmethod collect-table-refs ((sql sql-set-exp
))
422 (dolist (exp (slot-value sql
'sub-expressions
))
423 (let ((refs (collect-table-refs exp
)))
424 (if refs
(setf tabs
(append refs tabs
)))))
425 (remove-duplicates tabs
426 :test
(lambda (tab1 tab2
)
427 (equal (slot-value tab1
'name
)
428 (slot-value tab2
'name
))))))
430 (defmethod output-sql ((expr sql-set-exp
) database
)
431 (with-slots (operator sub-expressions
)
433 (let ((subs (if (consp (car sub-expressions
))
434 (car sub-expressions
)
436 (when (= (length subs
) 1)
437 (output-sql operator database
)
438 (write-char #\Space
*sql-stream
*))
439 (do ((sub subs
(cdr sub
)))
440 ((null (cdr sub
)) (output-sql (car sub
) database
))
441 (output-sql (car sub
) database
)
442 (write-char #\Space
*sql-stream
*)
443 (output-sql operator database
)
444 (write-char #\Space
*sql-stream
*))))
447 (defclass sql-query
(%sql-expression
)
458 :initarg
:set-operation
490 (:documentation
"An SQL SELECT query."))
492 (defclass sql-object-query
(%sql-expression
)
506 (defmethod collect-table-refs ((sql sql-query
))
507 (remove-duplicates (collect-table-refs (slot-value sql
'where
))
508 :test
(lambda (tab1 tab2
)
509 (equal (slot-value tab1
'name
)
510 (slot-value tab2
'name
)))))
512 (defvar *select-arguments
*
513 '(:all
:database
:distinct
:flatp
:from
:group-by
:having
:order-by
514 :set-operation
:where
:offset
:limit
:inner-join
:on
515 ;; below keywords are not a SQL argument, but these keywords may terminate select
518 (defun query-arg-p (sym)
519 (member sym
*select-arguments
*))
521 (defun query-get-selections (select-args)
522 "Return two values: the list of select-args up to the first keyword,
523 uninclusive, and the args from that keyword to the end."
524 (let ((first-key-arg (position-if #'query-arg-p select-args
)))
526 (values (subseq select-args
0 first-key-arg
)
527 (subseq select-args first-key-arg
))
530 (defun make-query (&rest args
)
531 (flet ((select-objects (target-args)
533 (every #'(lambda (arg)
535 (find-class arg nil
)))
537 (multiple-value-bind (selections arglist
)
538 (query-get-selections args
)
539 (if (select-objects selections
)
540 (destructuring-bind (&key flatp refresh
&allow-other-keys
) arglist
541 (make-instance 'sql-object-query
:objects selections
542 :flatp flatp
:refresh refresh
544 (destructuring-bind (&key all flatp set-operation distinct from where
545 group-by having order-by
546 offset limit inner-join on
&allow-other-keys
)
548 (if (null selections
)
549 (error "No target columns supplied to select statement."))
551 (error "No source tables supplied to select statement."))
552 (make-instance 'sql-query
:selections selections
553 :all all
:flatp flatp
:set-operation set-operation
554 :distinct distinct
:from from
:where where
555 :limit limit
:offset offset
556 :group-by group-by
:having having
:order-by order-by
557 :inner-join inner-join
:on on
))))))
559 (defmethod output-sql ((query sql-query
) database
)
560 (with-slots (distinct selections from where group-by having order-by
561 limit offset inner-join on all set-operation
)
564 (write-string "(" *sql-stream
*))
565 (write-string "SELECT " *sql-stream
*)
567 (write-string "ALL " *sql-stream
*))
568 (when (and distinct
(not all
))
569 (write-string "DISTINCT " *sql-stream
*)
570 (unless (eql t distinct
)
571 (write-string "ON " *sql-stream
*)
572 (output-sql distinct database
)
573 (write-char #\Space
*sql-stream
*)))
574 (output-sql (apply #'vector selections
) database
)
576 (write-string " FROM " *sql-stream
*)
577 (flet ((ident-table-equal (a b
)
578 (and (if (and (eql (type-of a
) 'sql-ident-table
)
579 (eql (type-of b
) 'sql-ident-table
))
580 (string-equal (slot-value a
'alias
)
581 (slot-value b
'alias
))
583 (string-equal (sql-escape (slot-value a
'name
))
584 (sql-escape (slot-value b
'name
))))))
586 (list (output-sql (apply #'vector
587 (remove-duplicates from
588 :test
#'ident-table-equal
))
590 (string (format *sql-stream
* "~s" (sql-escape from
)))
591 (t (let ((*in-subselect
* t
))
592 (output-sql from database
))))))
594 (write-string " INNER JOIN " *sql-stream
*)
595 (output-sql inner-join database
))
597 (write-string " ON " *sql-stream
*)
598 (output-sql on database
))
600 (write-string " WHERE " *sql-stream
*)
601 (let ((*in-subselect
* t
))
602 (output-sql where database
)))
604 (write-string " GROUP BY " *sql-stream
*)
606 (do ((order group-by
(cdr order
)))
608 (let ((item (car order
)))
611 (output-sql (car item
) database
)
612 (format *sql-stream
* " ~A" (cadr item
)))
614 (output-sql item database
)))
616 (write-char #\
, *sql-stream
*))))
617 (output-sql group-by database
)))
619 (write-string " HAVING " *sql-stream
*)
620 (output-sql having database
))
622 (write-string " ORDER BY " *sql-stream
*)
624 (do ((order order-by
(cdr order
)))
626 (let ((item (car order
)))
629 (output-sql (car item
) database
)
630 (format *sql-stream
* " ~A" (cadr item
)))
632 (output-sql item database
)))
634 (write-char #\
, *sql-stream
*))))
635 (output-sql order-by database
)))
637 (write-string " LIMIT " *sql-stream
*)
638 (output-sql limit database
))
640 (write-string " OFFSET " *sql-stream
*)
641 (output-sql offset database
))
643 (write-string ")" *sql-stream
*))
645 (write-char #\Space
*sql-stream
*)
646 (output-sql set-operation database
)))
649 (defmethod output-sql ((query sql-object-query
) database
)
650 (declare (ignore database
))
651 (with-slots (objects)
654 (format *sql-stream
* "(~{~A~^ ~})" objects
))))
659 (defclass sql-insert
(%sql-expression
)
673 "An SQL INSERT statement."))
675 (defmethod output-sql ((ins sql-insert
) database
)
676 (with-slots (into attributes values query
)
678 (write-string "INSERT INTO " *sql-stream
*)
681 (string (sql-expression :table into
))
685 (write-char #\Space
*sql-stream
*)
686 (output-sql attributes database
))
688 (write-string " VALUES " *sql-stream
*)
689 (output-sql values database
))
691 (write-char #\Space
*sql-stream
*)
692 (output-sql query database
)))
697 (defclass sql-delete
(%sql-expression
)
705 "An SQL DELETE statement."))
707 (defmethod output-sql ((stmt sql-delete
) database
)
708 (with-slots (from where
)
710 (write-string "DELETE FROM " *sql-stream
*)
712 ((or symbol string
) (write-string (sql-escape from
) *sql-stream
*))
713 (t (output-sql from database
)))
715 (write-string " WHERE " *sql-stream
*)
716 (output-sql where database
)))
721 (defclass sql-update
(%sql-expression
)
734 (:documentation
"An SQL UPDATE statement."))
736 (defmethod output-sql ((expr sql-update
) database
)
737 (with-slots (table where attributes values
)
739 (flet ((update-assignments ()
740 (mapcar #'(lambda (a b
)
741 (make-instance 'sql-assignment-exp
743 :sub-expressions
(list a b
)))
745 (write-string "UPDATE " *sql-stream
*)
746 (output-sql table database
)
747 (write-string " SET " *sql-stream
*)
748 (output-sql (apply #'vector
(update-assignments)) database
)
750 (write-string " WHERE " *sql-stream
*)
751 (output-sql where database
))))
756 (defclass sql-create-table
(%sql-expression
)
767 :initarg
:transactions
770 "An SQL CREATE TABLE statement."))
772 ;; Here's a real warhorse of a function!
774 (declaim (inline listify
))
780 (defmethod output-sql ((stmt sql-create-table
) database
)
781 (flet ((output-column (column-spec)
782 (destructuring-bind (name type
&optional db-type
&rest constraints
)
784 (let ((type (listify type
)))
785 (output-sql name database
)
786 (write-char #\Space
*sql-stream
*)
788 (if (stringp db-type
) db-type
; override definition
789 (database-get-type-specifier (car type
) (cdr type
) database
790 (database-underlying-type database
)))
792 (let ((constraints (database-constraint-statement
793 (if (and db-type
(symbolp db-type
))
794 (cons db-type constraints
)
798 (write-string " " *sql-stream
*)
799 (write-string constraints
*sql-stream
*)))))))
800 (with-slots (name columns modifiers transactions
)
802 (write-string "CREATE TABLE " *sql-stream
*)
804 (string (format *sql-stream
* "~s" (sql-escape name
)))
805 (symbol (write-string (sql-escape name
) *sql-stream
*))
806 (sql-ident (output-sql name database
)))
807 (write-string " (" *sql-stream
*)
808 (do ((column columns
(cdr column
)))
810 (output-column (car column
)))
811 (output-column (car column
))
812 (write-string ", " *sql-stream
*))
814 (do ((modifier (listify modifiers
) (cdr modifier
)))
816 (write-string ", " *sql-stream
*)
817 (write-string (car modifier
) *sql-stream
*)))
818 (write-char #\
) *sql-stream
*)
819 (when (and (eq :mysql
(database-underlying-type database
))
821 (db-type-transaction-capable?
:mysql database
))
822 (write-string " Type=InnoDB" *sql-stream
*))))
828 (defclass sql-create-view
(%sql-expression
)
829 ((name :initarg
:name
:initform nil
)
830 (column-list :initarg
:column-list
:initform nil
)
831 (query :initarg
:query
:initform nil
)
832 (with-check-option :initarg
:with-check-option
:initform nil
))
833 (:documentation
"An SQL CREATE VIEW statement."))
835 (defmethod output-sql ((stmt sql-create-view
) database
)
836 (with-slots (name column-list query with-check-option
) stmt
837 (write-string "CREATE VIEW " *sql-stream
*)
838 (output-sql name database
)
839 (when column-list
(write-string " " *sql-stream
*)
840 (output-sql (listify column-list
) database
))
841 (write-string " AS " *sql-stream
*)
842 (output-sql query database
)
843 (when with-check-option
(write-string " WITH CHECK OPTION" *sql-stream
*))))
847 ;; DATABASE-OUTPUT-SQL
850 (defmethod database-output-sql ((str string
) database
)
851 (declare (optimize (speed 3) (safety 1)
852 #+cmu
(extensions:inhibit-warnings
3)))
853 (let ((len (length str
)))
854 (declare (type fixnum len
))
857 ((and (null (position #\' str
))
858 (null (position #\\ str
)))
859 (concatenate 'string
"'" str
"'"))
861 (let ((buf (make-string (+ (* len
2) 2) :initial-element
#\')))
862 (declare (simple-string buf
))
865 ((= i len
) (subseq buf
0 (1+ j
)))
866 (declare (type fixnum i j
))
867 (let ((char (aref str i
)))
868 (declare (character char
))
869 (cond ((char= char
#\')
870 (setf (aref buf j
) #\')
872 (setf (aref buf j
) #\'))
873 ((and (char= char
#\\)
874 ;; MTP: only escape backslash with pgsql/mysql
875 (member (database-underlying-type database
)
876 '(:postgresql
:mysql
)
878 (setf (aref buf j
) #\\)
880 (setf (aref buf j
) #\\))
882 (setf (aref buf j
) char
))))))))))
884 (let ((keyword-package (symbol-package :foo
)))
885 (defmethod database-output-sql ((sym symbol
) database
)
888 (if (equal (symbol-package sym
) keyword-package
)
889 (concatenate 'string
"'" (string sym
) "'")
890 (symbol-name sym
)))))
892 (defmethod database-output-sql ((tee (eql t
)) database
)
894 (let ((val (database-output-sql-as-type 'boolean t database
(database-type database
))))
897 (string (format nil
"'~A'" val
))
898 (integer (format nil
"~A" val
)))))
901 #+nil
(defmethod database-output-sql ((tee (eql t
)) database
)
902 (declare (ignore database
))
905 (defmethod database-output-sql ((num number
) database
)
906 (declare (ignore database
))
907 (number-to-sql-string num
))
909 (defmethod database-output-sql ((arg list
) database
)
912 (format nil
"(~{~A~^,~})" (mapcar #'(lambda (val)
913 (sql-output val database
))
916 (defmethod database-output-sql ((arg vector
) database
)
917 (format nil
"~{~A~^,~}" (map 'list
#'(lambda (val)
918 (sql-output val database
))
921 (defmethod output-sql-hash-key ((arg vector
) database
)
922 (list 'vector
(map 'list
(lambda (arg)
923 (or (output-sql-hash-key arg database
)
924 (return-from output-sql-hash-key nil
)))
927 (defmethod database-output-sql ((self wall-time
) database
)
928 (declare (ignore database
))
929 (db-timestring self
))
931 (defmethod database-output-sql ((self date
) database
)
932 (declare (ignore database
))
933 (db-datestring self
))
935 (defmethod database-output-sql ((self duration
) database
)
936 (declare (ignore database
))
937 (format nil
"'~a'" (duration-timestring self
)))
940 (defmethod database-output-sql ((self money
) database
)
941 (database-output-sql (slot-value self
'odcl
::units
) database
))
943 (defmethod database-output-sql (thing database
)
947 (error 'sql-user-error
950 "No type conversion to SQL for ~A is defined for DB ~A."
951 (type-of thing
) (type-of database
)))))
955 ;; Column constraint types and conversion to SQL
958 (defparameter *constraint-types
*
960 (cons (symbol-name-default-case "NOT-NULL") "NOT NULL")
961 (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY")
962 (cons (symbol-name-default-case "NOT") "NOT")
963 (cons (symbol-name-default-case "NULL") "NULL")
964 (cons (symbol-name-default-case "PRIMARY") "PRIMARY")
965 (cons (symbol-name-default-case "KEY") "KEY")
966 (cons (symbol-name-default-case "UNSIGNED") "UNSIGNED")
967 (cons (symbol-name-default-case "ZEROFILL") "ZEROFILL")
968 (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT")
969 (cons (symbol-name-default-case "UNIQUE") "UNIQUE")))
971 (defmethod database-constraint-statement (constraint-list database
)
972 (declare (ignore database
))
973 (make-constraints-description constraint-list
))
975 (defun make-constraints-description (constraint-list)
978 (do ((constraint constraint-list
(cdr constraint
)))
979 ((null constraint
) string
)
980 (let ((output (assoc (symbol-name (car constraint
))
984 (error 'sql-user-error
985 :message
(format nil
"unsupported column constraint '~A'"
987 (setq string
(concatenate 'string string
(cdr output
))))
988 (if (< 1 (length constraint
))
989 (setq string
(concatenate 'string string
" "))))))))