1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
|
;;; emacsql-compile.el --- s-expression SQL compiler -*- lexical-binding: t; -*-
;;; Code:
(require 'cl-lib)
;;; Error symbols
(defmacro emacsql-deferror (symbol parents message)
"Defines a new error symbol for EmacSQL."
(declare (indent 2))
(let ((conditions (cl-remove-duplicates
(append parents (list symbol 'emacsql-error 'error)))))
`(prog1 ',symbol
(setf (get ',symbol 'error-conditions) ',conditions
(get ',symbol 'error-message) ,message))))
(emacsql-deferror emacsql-error () ;; parent condition for all others
"EmacSQL had an unhandled condition")
(emacsql-deferror emacsql-syntax () "Invalid SQL statement")
(emacsql-deferror emacsql-internal () "Internal error")
(emacsql-deferror emacsql-locked () "Database locked")
(emacsql-deferror emacsql-fatal () "Fatal error")
(emacsql-deferror emacsql-memory () "Out of memory")
(emacsql-deferror emacsql-corruption () "Database corrupted")
(emacsql-deferror emacsql-access () "Database access error")
(emacsql-deferror emacsql-timeout () "Query timeout error")
(emacsql-deferror emacsql-warning () "Warning message")
(defun emacsql-error (format &rest args)
"Like `error', but signal an emacsql-syntax condition."
(signal 'emacsql-syntax (list (apply #'format format args))))
;;; Escaping functions
(defvar emacsql-reserved (make-hash-table :test 'equal)
"Collection of all known reserved words, used for escaping.")
(defun emacsql-register-reserved (seq)
"Register sequence of keywords as reserved words, returning SEQ."
(cl-loop for word being the elements of seq
do (setf (gethash (upcase (format "%s" word)) emacsql-reserved) t)
finally (cl-return seq)))
(defun emacsql-reserved-p (name)
"Returns non-nil if string NAME is a SQL keyword."
(gethash (upcase name) emacsql-reserved))
(defun emacsql-quote-scalar (string)
"Single-quote (scalar) STRING for use in a SQL expression."
(with-temp-buffer
(insert string)
(setf (point) (point-min))
(while (re-search-forward "'" nil t)
(replace-match "''"))
(setf (point) (point-min))
(insert "'")
(setf (point) (point-max))
(insert "'")
(buffer-string)))
(defun emacsql-quote-identifier (string)
"Double-quote (identifier) STRING for use in a SQL expression."
(format "\"%s\"" (replace-regexp-in-string "\"" "\"\"" string)))
(defun emacsql-escape-identifier (identifier)
"Escape an identifier, if needed, for SQL."
(when (or (null identifier)
(keywordp identifier)
(not (or (symbolp identifier)
(vectorp identifier))))
(emacsql-error "Invalid identifier: %S" identifier))
(cond
((vectorp identifier)
(mapconcat #'emacsql-escape-identifier identifier ", "))
((eq identifier '*) "*")
(t
(let ((name (symbol-name identifier)))
(if (string-match-p ":" name)
(mapconcat #'emacsql-escape-identifier
(mapcar #'intern (split-string name ":")) ".")
(let ((print (replace-regexp-in-string "-" "_" (format "%S" identifier)))
(special "[]-\000-\040!\"#%&'()*+,./:;<=>?@[\\^`{|}~\177]"))
(if (or (string-match-p special print)
(string-match-p "^[0-9$]" print)
(emacsql-reserved-p print))
(emacsql-quote-identifier print)
print)))))))
(defun emacsql-escape-scalar (value)
"Escape VALUE for sending to SQLite."
(let ((print-escape-newlines t)
(print-escape-control-characters t))
(cond ((null value) "NULL")
((numberp value) (prin1-to-string value))
((emacsql-quote-scalar (prin1-to-string value))))))
(defun emacsql-escape-raw (value)
"Escape VALUE for sending to SQLite."
(cond ((null value) "NULL")
((stringp value) (emacsql-quote-scalar value))
((error "Expected string or nil"))))
(defun emacsql-escape-vector (vector)
"Encode VECTOR into a SQL vector scalar."
(cl-typecase vector
(null (emacsql-error "Empty SQL vector expression."))
(list (mapconcat #'emacsql-escape-vector vector ", "))
(vector (concat "(" (mapconcat #'emacsql-escape-scalar vector ", ") ")"))
(otherwise (emacsql-error "Invalid vector %S" vector))))
(defun emacsql-escape-format (thing)
"Escape THING for use as a `format' spec."
(replace-regexp-in-string "%" "%%" thing))
;;; Schema compiler
(defvar emacsql-type-map
'((integer "&INTEGER")
(float "&REAL")
(object "&TEXT")
(nil "&NONE"))
"An alist mapping EmacSQL types to SQL types.")
(defun emacsql--from-keyword (keyword)
"Convert KEYWORD into SQL."
(let ((name (substring (symbol-name keyword) 1)))
(upcase (replace-regexp-in-string "-" " " name))))
(defun emacsql--prepare-constraints (constraints)
"Compile CONSTRAINTS into a partial SQL expresson."
(mapconcat
#'identity
(cl-loop for constraint in constraints collect
(cl-typecase constraint
(null "NULL")
(keyword (emacsql--from-keyword constraint))
(symbol (emacsql-escape-identifier constraint))
(vector (format "(%s)"
(mapconcat
#'emacsql-escape-identifier
constraint
", ")))
(list (format "(%s)"
(car (emacsql--*expr constraint))))
(otherwise
(emacsql-escape-scalar constraint))))
" "))
(defun emacsql--prepare-column (column)
"Convert COLUMN into a partial SQL string."
(mapconcat
#'identity
(cl-etypecase column
(symbol (list (emacsql-escape-identifier column)
(cadr (assoc nil emacsql-type-map))))
(list (cl-destructuring-bind (name . constraints) column
(cl-delete-if
(lambda (s) (zerop (length s)))
(list (emacsql-escape-identifier name)
(if (member (car constraints) '(integer float object))
(cadr (assoc (pop constraints) emacsql-type-map))
(cadr (assoc nil emacsql-type-map)))
(emacsql--prepare-constraints constraints))))))
" "))
(defun emacsql-prepare-schema (schema)
"Compile SCHEMA into a SQL string."
(if (vectorp schema)
(emacsql-prepare-schema (list schema))
(cl-destructuring-bind (columns . constraints) schema
(mapconcat
#'identity
(nconc
(mapcar #'emacsql--prepare-column columns)
(mapcar #'emacsql--prepare-constraints constraints))
", "))))
;;; Statement compilation
(defvar emacsql-prepare-cache (make-hash-table :test 'equal :weakness 'key)
"Cache used to memoize `emacsql-prepare'.")
(defvar emacsql--vars ()
"Used within `emacsql-with-params' to collect parameters.")
(defun emacsql-sql-p (thing)
"Return non-nil if THING looks like a prepared statement."
(and (vectorp thing) (> (length thing) 0) (keywordp (aref thing 0))))
(defun emacsql-param (thing)
"Return the index and type of THING, or nil if THING is not a parameter.
A parameter is a symbol that looks like $i1, $s2, $v3, etc. The
letter refers to the type: identifier (i), scalar (s),
vector (v), raw string (r), schema (S)."
(when (symbolp thing)
(let ((name (symbol-name thing)))
(when (string-match-p "^\\$[isvrS][0-9]+$" name)
(cons (1- (read (substring name 2)))
(cl-ecase (aref name 1)
(?i :identifier)
(?s :scalar)
(?v :vector)
(?r :raw)
(?S :schema)))))))
(defmacro emacsql-with-params (prefix &rest body)
"Evaluate BODY, collecting parameters.
Provided local functions: `param', `identifier', `scalar', `raw',
`svector', `expr', `subsql', and `combine'. BODY should return a
string, which will be combined with variable definitions."
(declare (indent 1))
`(let ((emacsql--vars ()))
(cl-flet* ((combine (prepared) (emacsql--*combine prepared))
(param (thing) (emacsql--!param thing))
(identifier (thing) (emacsql--!param thing :identifier))
(scalar (thing) (emacsql--!param thing :scalar))
(raw (thing) (emacsql--!param thing :raw))
(svector (thing) (combine (emacsql--*vector thing)))
(expr (thing) (combine (emacsql--*expr thing)))
(subsql (thing)
(format "(%s)" (combine (emacsql-prepare thing)))))
(cons (concat ,prefix (progn ,@body)) emacsql--vars))))
(defun emacsql--!param (thing &optional kind)
"Parse, escape, and store THING.
If optional KIND is not specified, then try to guess it.
Only use within `emacsql-with-params'!"
(cl-flet ((check (param)
(when (and kind (not (eq kind (cdr param))))
(emacsql-error
"Invalid parameter type %s, expecting %s" thing kind))))
(let ((param (emacsql-param thing)))
(if (null param)
(emacsql-escape-format
(if kind
(cl-case kind
(:identifier (emacsql-escape-identifier thing))
(:scalar (emacsql-escape-scalar thing))
(:vector (emacsql-escape-vector thing))
(:raw (emacsql-escape-raw thing))
(:schema (emacsql-prepare-schema thing)))
(if (and (not (null thing))
(not (keywordp thing))
(symbolp thing))
(emacsql-escape-identifier thing)
(emacsql-escape-scalar thing))))
(prog1 (if (eq (cdr param) :schema) "(%s)" "%s")
(check param)
(setf emacsql--vars (nconc emacsql--vars (list param))))))))
(defun emacsql--*vector (vector)
"Prepare VECTOR."
(emacsql-with-params ""
(cl-typecase vector
(symbol (emacsql--!param vector :vector))
(list (mapconcat #'svector vector ", "))
(vector (format "(%s)" (mapconcat #'scalar vector ", ")))
(otherwise (emacsql-error "Invalid vector: %S" vector)))))
(defun emacsql--*expr (expr)
"Expand EXPR recursively."
(emacsql-with-params ""
(cond
((emacsql-sql-p expr) (subsql expr))
((vectorp expr) (svector expr))
((atom expr) (param expr))
((cl-destructuring-bind (op . args) expr
(cl-flet ((recur (n) (combine (emacsql--*expr (nth n args))))
(nops (op)
(emacsql-error "Wrong number of operands for %s" op)))
(cl-case op
;; Special cases <= >=
((<= >=)
(cl-case (length args)
(2 (format "%s %s %s" (recur 0) op (recur 1)))
(3 (format "%s BETWEEN %s AND %s"
(recur 1)
(recur (if (eq op '>=) 2 0))
(recur (if (eq op '>=) 0 2))))
(otherwise (nops op))))
;; Special case -
((-)
(cl-case (length args)
(1 (format "-(%s)" (recur 0)))
(2 (format "%s - %s" (recur 0) (recur 1)))
(otherwise (nops op))))
;; Unary
((not)
(format "NOT %s" (recur 0)))
((notnull)
(format "%s NOTNULL" (recur 0)))
((isnull)
(format "%s ISNULL" (recur 0)))
;; Ordering
((asc desc)
(format "%s %s" (recur 0) (upcase (symbol-name op))))
;; Special case quote
((quote) (let ((arg (nth 0 args)))
(if (stringp arg)
(raw arg)
(scalar arg))))
;; Special case funcall
((funcall)
(format "%s(%s)" (recur 0)
(cond
((and (= 2 (length args))
(eq '* (nth 1 args)))
"*")
((and (= 3 (length args))
(eq :distinct (nth 1 args))
(format "DISTINCT %s" (recur 2))))
((mapconcat
#'recur (cl-loop for i from 1 below (length args)
collect i)
", ")))))
;; Guess
(otherwise
(mapconcat
#'recur (cl-loop for i from 0 below (length args) collect i)
(format " %s " (upcase (symbol-name op))))))))))))
(defun emacsql--*idents (idents)
"Read in a vector of IDENTS identifiers, or just an single identifier."
(emacsql-with-params ""
(mapconcat #'expr idents ", ")))
(defun emacsql--*combine (prepared)
"Append parameters from PREPARED to `emacsql--vars', return the string.
Only use within `emacsql-with-params'!"
(cl-destructuring-bind (string . vars) prepared
(setf emacsql--vars (nconc emacsql--vars vars))
string))
(defun emacsql-prepare--string (string)
"Create a prepared statement from STRING."
(emacsql-with-params ""
(replace-regexp-in-string
"\\$[isv][0-9]+" (lambda (v) (param (intern v))) string)))
(defun emacsql-prepare--sexp (sexp)
"Create a prepared statement from SEXP."
(emacsql-with-params ""
(cl-loop with items = (cl-coerce sexp 'list)
and last = nil
while (not (null items))
for item = (pop items)
collect
(cl-typecase item
(keyword (if (eq :values item)
(concat "VALUES " (svector (pop items)))
(emacsql--from-keyword item)))
(symbol (if (eq item '*)
"*"
(param item)))
(vector (if (emacsql-sql-p item)
(subsql item)
(let ((idents (combine
(emacsql--*idents item))))
(if (keywordp last)
idents
(format "(%s)" idents)))))
(list (if (vectorp (car item))
(emacsql-escape-format
(format "(%s)"
(emacsql-prepare-schema item)))
(combine (emacsql--*expr item))))
(otherwise
(emacsql-escape-format
(emacsql-escape-scalar item))))
into parts
do (setf last item)
finally (cl-return
(mapconcat #'identity parts " ")))))
(defun emacsql-prepare (sql)
"Expand SQL (string or sexp) into a prepared statement."
(let* ((cache emacsql-prepare-cache)
(key (cons emacsql-type-map sql)))
(or (gethash key cache)
(setf (gethash key cache)
(if (stringp sql)
(emacsql-prepare--string sql)
(emacsql-prepare--sexp sql))))))
(defun emacsql-format (expansion &rest args)
"Fill in the variables EXPANSION with ARGS."
(cl-destructuring-bind (format . vars) expansion
(apply #'format format
(cl-loop for (i . kind) in vars collect
(let ((thing (nth i args)))
(cl-case kind
(:identifier (emacsql-escape-identifier thing))
(:scalar (emacsql-escape-scalar thing))
(:vector (emacsql-escape-vector thing))
(:raw (emacsql-escape-raw thing))
(:schema (emacsql-prepare-schema thing))
(otherwise
(emacsql-error "Invalid var type %S" kind))))))))
(provide 'emacsql-compiler)
;;; emacsql-compile.el ends here
|
