-
-
Notifications
You must be signed in to change notification settings - Fork 39
/
emacsql.el
416 lines (342 loc) · 15.5 KB
/
emacsql.el
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
405
406
407
408
409
410
411
412
413
414
415
416
;;; emacsql.el --- high-level SQL database front-end -*- lexical-binding: t; -*-
;; This is free and unencumbered software released into the public domain.
;; Author: Christopher Wellons <wellons@nullprogram.com>
;; URL: https://github.com/skeeto/emacsql
;; Version: 3.0.0
;; Package-Requires: ((emacs "25.1"))
;;; Commentary:
;; EmacSQL is a high-level Emacs Lisp front-end for SQLite
;; (primarily), PostgreSQL, MySQL, and potentially other SQL
;; databases. On MELPA, each of the backends is provided through
;; separate packages: emacsql-sqlite, emacsql-psql, emacsql-mysql.
;; Most EmacSQL functions operate on a database connection. For
;; example, a connection to SQLite is established with
;; `emacsql-sqlite'. For each such connection a sqlite3 inferior
;; process is kept alive in the background. Connections are closed
;; with `emacsql-close'.
;; (defvar db (emacsql-sqlite "company.db"))
;; Use `emacsql' to send an s-expression SQL statements to a connected
;; database. Identifiers for tables and columns are symbols. SQL
;; keywords are lisp keywords. Anything else is data.
;; (emacsql db [:create-table people ([name id salary])])
;; Column constraints can optionally be provided in the schema.
;; (emacsql db [:create-table people ([name (id integer :unique) salary])])
;; Insert some values.
;; (emacsql db [:insert :into people
;; :values (["Jeff" 1000 60000.0] ["Susan" 1001 64000.0])])
;; Currently all actions are synchronous and Emacs will block until
;; SQLite has indicated it is finished processing the last command.
;; Query the database for results:
;; (emacsql db [:select [name id] :from employees :where (> salary 60000)])
;; ;; => (("Susan" 1001))
;; Queries can be templates -- $i1, $s2, etc. -- so they don't need to
;; be built up dynamically:
;; (emacsql db
;; [:select [name id] :from employees :where (> salary $s1)]
;; 50000)
;; ;; => (("Jeff" 1000) ("Susan" 1001))
;; The letter declares the type (identifier, scalar, vector, Schema)
;; and the number declares the argument position.
;; See README.md for much more complete documentation.
;;; Code:
(require 'cl-lib)
(require 'cl-generic)
(require 'eieio)
(require 'emacsql-compiler)
(defgroup emacsql nil
"The EmacSQL SQL database front-end."
:group 'comm)
(defconst emacsql-version "3.0.0")
(defvar emacsql-global-timeout 30
"Maximum number of seconds to wait before bailing out on a SQL command.
If nil, wait forever.")
(defvar emacsql-data-root
(file-name-directory (or load-file-name buffer-file-name))
"Directory where EmacSQL is installed.")
;;; Database connection
(defclass emacsql-connection ()
((process :type process
:initarg :process
:accessor emacsql-process)
(log-buffer :type (or null buffer)
:initarg :log-buffer
:initform nil
:accessor emacsql-log-buffer
:documentation "Output log (debug).")
(finalizer :documentation "Object returned from `make-finalizer'.")
(types :allocation :class
:initform nil
:reader emacsql-types
:documentation "Maps EmacSQL types to SQL types."))
(:documentation "A connection to a SQL database.")
:abstract t)
(cl-defgeneric emacsql-close (connection)
"Close CONNECTION and free all resources.")
(cl-defgeneric emacsql-reconnect (connection)
"Re-establish CONNECTION with the same parameters.")
(cl-defmethod emacsql-live-p ((connection emacsql-connection))
"Return non-nil if CONNECTION is still alive and ready."
(not (null (process-live-p (emacsql-process connection)))))
(cl-defgeneric emacsql-types (connection)
"Return an alist mapping EmacSQL types to database types.
This will mask `emacsql-type-map' during expression compilation.
This alist should have four key symbols: integer, float, object,
nil (default type). The values are strings to be inserted into a
SQL expression.")
(cl-defmethod emacsql-buffer ((connection emacsql-connection))
"Get process buffer for CONNECTION."
(process-buffer (emacsql-process connection)))
(cl-defmethod emacsql-enable-debugging ((connection emacsql-connection))
"Enable debugging on CONNECTION."
(unless (buffer-live-p (emacsql-log-buffer connection))
(setf (emacsql-log-buffer connection)
(generate-new-buffer " *emacsql-log*"))))
(cl-defmethod emacsql-log ((connection emacsql-connection) message)
"Log MESSAGE into CONNECTION's log.
MESSAGE should not have a newline on the end."
(let ((log (emacsql-log-buffer connection)))
(when log
(with-current-buffer log
(setf (point) (point-max))
(princ (concat message "\n") log)))))
;;; Sending and receiving
(cl-defgeneric emacsql-send-message ((connection emacsql-connection) message)
"Send MESSAGE to CONNECTION.")
(cl-defmethod emacsql-send-message :before
((connection emacsql-connection) message)
(emacsql-log connection message))
(cl-defmethod emacsql-clear ((connection emacsql-connection))
"Clear the process buffer for CONNECTION-SPEC."
(with-current-buffer (emacsql-buffer connection)
(erase-buffer)))
(cl-defgeneric emacsql-waiting-p (connection)
"Return non-nil if CONNECTION is ready for more input.")
(cl-defmethod emacsql-wait ((connection emacsql-connection) &optional timeout)
"Block until CONNECTION is waiting for further input."
(let* ((real-timeout (or timeout emacsql-global-timeout))
(end (when real-timeout (+ (float-time) real-timeout))))
(while (and (or (null real-timeout) (< (float-time) end))
(not (emacsql-waiting-p connection)))
(save-match-data
(accept-process-output (emacsql-process connection) real-timeout)))
(unless (emacsql-waiting-p connection)
(signal 'emacsql-timeout (list "Query timed out" real-timeout)))))
(cl-defgeneric emacsql-parse (connection)
"Return the results of parsing the latest output or signal an error.")
(defun emacsql-compile (connection sql &rest args)
"Compile s-expression SQL for CONNECTION into a string."
(let* ((mask (when connection (emacsql-types connection)))
(emacsql-type-map (or mask emacsql-type-map)))
(concat (apply #'emacsql-format (emacsql-prepare sql) args) ";")))
(cl-defmethod emacsql ((connection emacsql-connection) sql &rest args)
"Send SQL s-expression to CONNECTION and return the results."
(let ((sql-string (apply #'emacsql-compile connection sql args)))
(emacsql-clear connection)
(emacsql-send-message connection sql-string)
(emacsql-wait connection)
(emacsql-parse connection)))
;;; Helper mixin class
(defclass emacsql-protocol-mixin ()
()
(:documentation
"A mixin for back-ends following the EmacSQL protocol.
The back-end prompt must be a single \"]\" character. This prompt
value was chosen because it is unreadable. Output must have
exactly one row per line, fields separated by whitespace. NULL
must display as \"nil\".")
:abstract t)
(cl-defmethod emacsql-waiting-p ((connection emacsql-protocol-mixin))
"Return true if the end of the buffer has a properly-formatted prompt."
(with-current-buffer (emacsql-buffer connection)
(and (>= (buffer-size) 2)
(string= "#\n" (buffer-substring (- (point-max) 2) (point-max))))))
(cl-defmethod emacsql-handle ((_ emacsql-protocol-mixin) code message)
"Signal a specific condition for CODE from CONNECTION.
Subclasses should override this method in order to provide more
specific error conditions."
(signal 'emacsql-error (list code message)))
(cl-defmethod emacsql-parse ((connection emacsql-protocol-mixin))
"Parse well-formed output into an s-expression."
(with-current-buffer (emacsql-buffer connection)
(setf (point) (point-min))
(let* ((standard-input (current-buffer))
(value (read)))
(if (eql value 'error)
(emacsql-handle connection (read) (read))
(prog1 value
(unless (eq 'success (read))
(emacsql-handle connection (read) (read))))))))
(provide 'emacsql) ; end of generic function declarations
;;; Automatic connection cleanup
(defun emacsql-register (connection)
"Register CONNECTION for automatic cleanup and return CONNECTION."
(let ((finalizer (make-finalizer (lambda () (emacsql-close connection)))))
(prog1 connection
(setf (slot-value connection 'finalizer) finalizer))))
;;; Useful macros
(defmacro emacsql-with-connection (connection-spec &rest body)
"Open an EmacSQL connection, evaluate BODY, and close the connection.
CONNECTION-SPEC establishes a single binding.
(emacsql-with-connection (db (emacsql-sqlite \"company.db\"))
(emacsql db [:create-table foo [x]])
(emacsql db [:insert :into foo :values ([1] [2] [3])])
(emacsql db [:select * :from foo]))"
(declare (indent 1))
`(let ((,(car connection-spec) ,(cadr connection-spec)))
(unwind-protect
(progn ,@body)
(emacsql-close ,(car connection-spec)))))
(defvar emacsql--transaction-level 0
"Keeps track of nested transactions in `emacsql-with-transaction'.")
(defmacro emacsql-with-transaction (connection &rest body)
"Evaluate BODY inside a single transaction, issuing a rollback on error.
This macro can be nested indefinitely, wrapping everything in a
single transaction at the lowest level.
Warning: BODY should *not* have any side effects besides making
changes to the database behind CONNECTION. Body may be evaluated
multiple times before the changes are committed."
(declare (indent 1))
`(let ((emacsql--connection ,connection)
(emacsql--completed nil)
(emacsql--transaction-level (1+ emacsql--transaction-level))
(emacsql--result))
(unwind-protect
(while (not emacsql--completed)
(condition-case nil
(progn
(when (= 1 emacsql--transaction-level)
(emacsql emacsql--connection [:begin]))
(let ((result (progn ,@body)))
(setf emacsql--result result)
(when (= 1 emacsql--transaction-level)
(emacsql emacsql--connection [:commit]))
(setf emacsql--completed t)))
(emacsql-locked (emacsql emacsql--connection [:rollback])
(sleep-for 0.05))))
(when (and (= 1 emacsql--transaction-level)
(not emacsql--completed))
(emacsql emacsql--connection [:rollback])))
emacsql--result))
(defmacro emacsql-thread (connection &rest statements)
"Thread CONNECTION through STATEMENTS.
A statement can be a list, containing a statement with its arguments."
(declare (indent 1))
`(let ((emacsql--conn ,connection))
(emacsql-with-transaction emacsql--conn
,@(cl-loop for statement in statements
when (vectorp statement)
collect (list 'emacsql 'emacsql--conn statement)
else
collect (append (list 'emacsql 'emacsql--conn) statement)))))
(defmacro emacsql-with-bind (connection sql-and-args &rest body)
"For each result row bind the column names for each returned row.
Returns the result of the last evaluated BODY.
All column names must be provided in the query ($ and * are not
allowed). Hint: all of the bound identifiers must be known at
compile time. For example, in the expression below the variables
'name' and 'phone' will be bound for the body.
(emacsql-with-bind db [:select [name phone] :from people]
(message \"Found %s with %s\" name phone))
(emacsql-with-bind db ([:select [name phone]
:from people
:where (= name $1)] my-name)
(message \"Found %s with %s\" name phone))
Each column must be a plain symbol, no expressions allowed here."
(declare (indent 2))
(let ((sql (if (vectorp sql-and-args) sql-and-args (car sql-and-args)))
(args (unless (vectorp sql-and-args) (cdr sql-and-args))))
(cl-assert (eq :select (elt sql 0)))
(let ((vars (elt sql 1)))
(when (eq '* vars)
(error "Must explicitly list columns in `emacsql-with-bind'."))
(cl-assert (cl-every #'symbolp vars))
`(let ((emacsql--results (emacsql ,connection ,sql ,@args))
(emacsql--final nil))
(dolist (emacsql--result emacsql--results emacsql--final)
(setf emacsql--final
(cl-destructuring-bind ,(cl-coerce vars 'list) emacsql--result
,@body)))))))
;;; User interaction functions
(defvar emacsql-show-buffer-name "*emacsql-show*"
"Name of the buffer for displaying intermediate SQL.")
(defun emacsql--indent ()
"Indent and wrap the SQL expression in the current buffer."
(save-excursion
(setf (point) (point-min))
(let ((case-fold-search nil))
(while (search-forward-regexp " [A-Z]+" nil :no-error)
(when (> (current-column) (* fill-column 0.8))
(backward-word)
(insert "\n "))))))
(defun emacsql-show-sql (string)
"Fontify and display the SQL expression in STRING."
(let ((fontified
(with-temp-buffer
(insert string)
(sql-mode)
(with-no-warnings ;; autoloaded by previous line
(sql-highlight-sqlite-keywords))
(if (and (fboundp 'font-lock-flush)
(fboundp 'font-lock-ensure))
(save-restriction
(widen)
(font-lock-flush)
(font-lock-ensure))
(with-no-warnings
(font-lock-fontify-buffer)))
(emacsql--indent)
(buffer-string))))
(with-current-buffer (get-buffer-create emacsql-show-buffer-name)
(if (< (length string) fill-column)
(message "%s" fontified)
(let ((buffer-read-only nil))
(erase-buffer)
(insert fontified))
(special-mode)
(visual-line-mode)
(pop-to-buffer (current-buffer))))))
(defun emacsql-flatten-sql (sql)
"Convert a s-expression SQL into a flat string for display."
(cl-destructuring-bind (string . vars) (emacsql-prepare sql)
(concat
(apply #'format string (cl-loop for i in (mapcar #'car vars)
collect (intern (format "$%d" (1+ i)))))
";")))
;;;###autoload
(defun emacsql-show-last-sql (&optional prefix)
"Display the compiled SQL of the s-expression SQL expression before point.
A prefix argument causes the SQL to be printed into the current buffer."
(interactive "P")
(let ((sexp (if (fboundp 'elisp--preceding-sexp)
(elisp--preceding-sexp)
(with-no-warnings
(preceding-sexp)))))
(if (emacsql-sql-p sexp)
(let ((sql (emacsql-flatten-sql sexp)))
(if prefix
(insert sql)
(emacsql-show-sql sql)))
(user-error "Invalid SQL: %S" sexp))))
;;; Fix Emacs' broken vector indentation
(defun emacsql--inside-vector-p ()
"Return non-nil if point is inside a vector expression."
(let ((start (point)))
(save-excursion
(beginning-of-defun)
(let ((containing-sexp (elt (parse-partial-sexp (point) start) 1)))
(when containing-sexp
(setf (point) containing-sexp)
(looking-at "\\["))))))
(defadvice calculate-lisp-indent (around emacsql-vector-indent disable)
"Don't indent vectors in `emacs-lisp-mode' like lists."
(if (save-excursion (beginning-of-line) (emacsql--inside-vector-p))
(let ((lisp-indent-offset 1))
ad-do-it)
ad-do-it))
(defun emacsql-fix-vector-indentation ()
"When called, advise `calculate-lisp-indent' to stop indenting vectors.
Once activate, vector contents no longer indent like lists."
(interactive)
(ad-enable-advice 'calculate-lisp-indent 'around 'emacsql-vector-indent)
(ad-activate 'calculate-lisp-indent))
;;; emacsql.el ends here