1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; ======================================================================
4 ;;;; Updated: <04/04/2004 12:05:32 marcusp>
5 ;;;; ======================================================================
7 ;;;; Description ==========================================================
8 ;;;; ======================================================================
10 ;;;; The CLSQL-USQL Functional Data Manipulation Language (FDML).
12 ;;;; ======================================================================
14 (in-package :clsql-usql-sys)
17 ;;; Basic operations on databases
20 (defmethod database-query-result-set ((expr %sql-expression) database
22 (database-query-result-set (sql-output expr database) database
23 :full-set full-set :types types))
25 (defmethod execute-command ((expr %sql-expression)
26 &key (database *default-database*))
27 (execute-command (sql-output expr database) :database database)
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))
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
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 "))
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)))))
70 (defun insert-records (&key (into 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
87 (execute-command stmt :database database)))
89 (defun make-sql-insert (&key (into nil)
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)
99 (cond ((and vals (not attrs) (not query) (not av-pairs))
101 ((and vals attrs (not subquery) (not av-pairs))
102 (setf attributes attrs)
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))
113 (error 'clsql-sql-syntax-error
114 :reason "bad or ambiguous keyword combination.")))
117 (defun delete-records (&key (from 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
124 (let ((stmt (make-instance 'sql-delete :from from :where where)))
125 (execute-command stmt :database database)))
127 (defun update-records (table &key
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
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
143 (execute-command stmt :database database)))
150 (defmethod database-output-sql ((str string) database)
151 (declare (ignore database)
152 (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3))
153 (type (simple-array * (*)) str))
154 (let ((len (length str)))
155 (declare (type fixnum len))
158 ((and (null (position #\' str))
159 (null (position #\\ str)))
160 (concatenate 'string "'" str "'"))
162 (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
165 ((= i len) (subseq buf 0 (1+ j)))
166 (declare (type integer i j))
167 (let ((char (aref str i)))
168 (cond ((eql char #\')
169 (setf (aref buf j) #\\)
171 (setf (aref buf j) #\'))
173 (setf (aref buf j) #\\)
175 (setf (aref buf j) #\\))
177 (setf (aref buf j) char))))))))))
179 (let ((keyword-package (symbol-package :foo)))
180 (defmethod database-output-sql ((sym symbol) database)
181 (declare (ignore database))
182 (if (equal (symbol-package sym) keyword-package)
183 (concatenate 'string "'" (string sym) "'")
186 (defmethod database-output-sql ((tee (eql t)) database)
187 (declare (ignore database))
190 (defmethod database-output-sql ((num number) database)
191 (declare (ignore database))
192 (princ-to-string num))
194 (defmethod database-output-sql ((arg list) database)
197 (format nil "(~{~A~^,~})" (mapcar #'(lambda (val)
198 (sql-output val database))
201 (defmethod database-output-sql ((arg vector) database)
202 (format nil "~{~A~^,~}" (map 'list #'(lambda (val)
203 (sql-output val database))
206 (defmethod database-output-sql ((self wall-time) database)
207 (declare (ignore database))
208 (db-timestring self))
210 (defmethod database-output-sql (thing database)
214 (error 'clsql-simple-error
216 "No type conversion to SQL for ~A is defined for DB ~A."
217 :format-arguments (list (type-of thing) (type-of database)))))
219 (defmethod output-sql-hash-key ((arg vector) &optional database)
220 (list 'vector (map 'list (lambda (arg)
221 (or (output-sql-hash-key arg database)
222 (return-from output-sql-hash-key nil)))
225 (defmethod output-sql (expr &optional (database *default-database*))
226 (write-string (database-output-sql expr database) *sql-stream*)
229 (defmethod output-sql ((expr list) &optional (database *default-database*))
231 (write-string +null-string+ *sql-stream*)
233 (write-char #\( *sql-stream*)
234 (do ((item expr (cdr item)))
236 (output-sql (car item) database))
237 (output-sql (car item) database)
238 (write-char #\, *sql-stream*))
239 (write-char #\) *sql-stream*)))