478 lines
19 KiB
EmacsLisp
478 lines
19 KiB
EmacsLisp
;;; 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>
|
|
;; Maintainer: Jonas Bernoulli <jonas@bernoul.li>
|
|
;; Homepage: https://github.com/magit/emacsql
|
|
|
|
;; Package-Version: 3.1.1.50-git
|
|
;; Package-Requires: ((emacs "25.1"))
|
|
;; SPDX-License-Identifier: Unlicense
|
|
|
|
;;; 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.1.1.50-git")
|
|
|
|
(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 :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 ((buffer (emacsql-log-buffer connection)))
|
|
(when buffer
|
|
(unless (buffer-live-p buffer)
|
|
(setq buffer (emacsql-enable-debugging connection)))
|
|
(with-current-buffer buffer
|
|
(goto-char (point-max))
|
|
(princ (concat message "\n") buffer)))))
|
|
|
|
;;; Sending and receiving
|
|
|
|
(cl-defgeneric emacsql-send-message (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."
|
|
(let ((buffer (emacsql-buffer connection)))
|
|
(when (and buffer (buffer-live-p buffer))
|
|
(with-current-buffer buffer
|
|
(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-defgeneric emacsql (connection sql &rest args)
|
|
"Send SQL s-expression to CONNECTION and return the results.")
|
|
|
|
(cl-defmethod emacsql ((connection emacsql-connection) sql &rest args)
|
|
(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 message code)))
|
|
|
|
(cl-defmethod emacsql-parse ((connection emacsql-protocol-mixin))
|
|
"Parse well-formed output into an s-expression."
|
|
(with-current-buffer (emacsql-buffer connection)
|
|
(goto-char (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
|
|
(goto-char (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))))
|
|
|
|
;;; Common SQLite values
|
|
|
|
(defconst emacsql-sqlite-reserved
|
|
'( ABORT ACTION ADD AFTER ALL ALTER ANALYZE AND AS ASC ATTACH
|
|
AUTOINCREMENT BEFORE BEGIN BETWEEN BY CASCADE CASE CAST CHECK
|
|
COLLATE COLUMN COMMIT CONFLICT CONSTRAINT CREATE CROSS
|
|
CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP DATABASE DEFAULT
|
|
DEFERRABLE DEFERRED DELETE DESC DETACH DISTINCT DROP EACH ELSE END
|
|
ESCAPE EXCEPT EXCLUSIVE EXISTS EXPLAIN FAIL FOR FOREIGN FROM FULL
|
|
GLOB GROUP HAVING IF IGNORE IMMEDIATE IN INDEX INDEXED INITIALLY
|
|
INNER INSERT INSTEAD INTERSECT INTO IS ISNULL JOIN KEY LEFT LIKE
|
|
LIMIT MATCH NATURAL NO NOT NOTNULL NULL OF OFFSET ON OR ORDER
|
|
OUTER PLAN PRAGMA PRIMARY QUERY RAISE RECURSIVE REFERENCES REGEXP
|
|
REINDEX RELEASE RENAME REPLACE RESTRICT RIGHT ROLLBACK ROW
|
|
SAVEPOINT SELECT SET TABLE TEMP TEMPORARY THEN TO TRANSACTION
|
|
TRIGGER UNION UNIQUE UPDATE USING VACUUM VALUES VIEW VIRTUAL WHEN
|
|
WHERE WITH WITHOUT)
|
|
"List of all of SQLite's reserved words.
|
|
Also see http://www.sqlite.org/lang_keywords.html.")
|
|
|
|
(defconst emacsql-sqlite-error-codes
|
|
'((1 SQLITE_ERROR emacsql-error "SQL logic error")
|
|
(2 SQLITE_INTERNAL emacsql-internal nil)
|
|
(3 SQLITE_PERM emacsql-access "access permission denied")
|
|
(4 SQLITE_ABORT emacsql-error "query aborted")
|
|
(5 SQLITE_BUSY emacsql-locked "database is locked")
|
|
(6 SQLITE_LOCKED emacsql-locked "database table is locked")
|
|
(7 SQLITE_NOMEM emacsql-memory "out of memory")
|
|
(8 SQLITE_READONLY emacsql-access "attempt to write a readonly database")
|
|
(9 SQLITE_INTERRUPT emacsql-error "interrupted")
|
|
(10 SQLITE_IOERR emacsql-access "disk I/O error")
|
|
(11 SQLITE_CORRUPT emacsql-corruption "database disk image is malformed")
|
|
(12 SQLITE_NOTFOUND emacsql-error "unknown operation")
|
|
(13 SQLITE_FULL emacsql-access "database or disk is full")
|
|
(14 SQLITE_CANTOPEN emacsql-access "unable to open database file")
|
|
(15 SQLITE_PROTOCOL emacsql-access "locking protocol")
|
|
(16 SQLITE_EMPTY emacsql-corruption nil)
|
|
(17 SQLITE_SCHEMA emacsql-error "database schema has changed")
|
|
(18 SQLITE_TOOBIG emacsql-error "string or blob too big")
|
|
(19 SQLITE_CONSTRAINT emacsql-constraint "constraint failed")
|
|
(20 SQLITE_MISMATCH emacsql-error "datatype mismatch")
|
|
(21 SQLITE_MISUSE emacsql-error "bad parameter or other API misuse")
|
|
(22 SQLITE_NOLFS emacsql-error "large file support is disabled")
|
|
(23 SQLITE_AUTH emacsql-access "authorization denied")
|
|
(24 SQLITE_FORMAT emacsql-corruption nil)
|
|
(25 SQLITE_RANGE emacsql-error "column index out of range")
|
|
(26 SQLITE_NOTADB emacsql-corruption "file is not a database")
|
|
(27 SQLITE_NOTICE emacsql-warning "notification message")
|
|
(28 SQLITE_WARNING emacsql-warning "warning message"))
|
|
"Alist mapping SQLite error codes to EmacSQL conditions.
|
|
Elements have the form (ERRCODE SYMBOLIC-NAME EMACSQL-ERROR
|
|
ERRSTR). Also see https://www.sqlite.org/rescode.html.")
|
|
|
|
;;; 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
|
|
(goto-char 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
|