branch: elpa/emacsql
commit 3229cd41afd28d276326919b067900b2473c02ec
Author: Christopher Wellons <well...@nullprogram.com>
Commit: Christopher Wellons <well...@nullprogram.com>
Change the requirements for front-end implementations.
---
Makefile | 3 +-
README.md | 7 +-
emacsql.el => emacsql-compiler.el | 302 +-------------------
emacsql-psql.el | 12 +-
emacsql-sqlite.el | 20 +-
emacsql.el | 575 +++-----------------------------------
6 files changed, 64 insertions(+), 855 deletions(-)
diff --git a/Makefile b/Makefile
index 477486dba3..175cf583c3 100644
--- a/Makefile
+++ b/Makefile
@@ -5,7 +5,8 @@ BATCH := $(EMACS) -batch -Q -L .
COMPILE := $(BATCH) -f batch-byte-compile
TEST := $(BATCH) -l $(PACKAGE)-tests.elc -f ert-run-tests-batch
-EL = emacsql.el emacsql-sqlite.el emacsql-psql.el $(PACKAGE)-tests.el
+EL = emacsql-compiler.el emacsql.el emacsql-sqlite.el emacsql-psql.el \
+ emacsql-tests.el
ELC = $(EL:.el=.elc)
diff --git a/README.md b/README.md
index 0e6d9e4f04..679da8f662 100644
--- a/README.md
+++ b/README.md
@@ -383,13 +383,16 @@ Emacsql uses EIEIO so that interactions with a connection
occur
through generic functions. You need to define a new class that
inherits from `emacsql-connection`.
- * Implement `emacsql-waiting-p`, `emacsql-close`, and `emacsql`.
+ * Implement `emacsql-waiting-p`, `emacsql-parse`, and `emacsql-close`.
* Provide a constructor that initializes the connection and calls
`emacsql-register` (for automatic connection cleanup).
+ * Provide `emacsql-types` if needed (hint: use a class-allocated slot).
* Ensure that you properly read NULL as nil (hint: ask your back-end
to print it that way).
-The provided implementations should serve as useful examples.
+The provided implementations should serve as useful examples. If your
+back-end outputs data in a clean, standard way you may be able to use
+the emacsql-simple-parser mixin class to do most of the work.
## See Also
diff --git a/emacsql.el b/emacsql-compiler.el
similarity index 63%
copy from emacsql.el
copy to emacsql-compiler.el
index 05c4f97747..ec572f81ab 100644
--- a/emacsql.el
+++ b/emacsql-compiler.el
@@ -1,106 +1,8 @@
-;;; 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 <well...@nullprogram.com>
-;; URL: https://github.com/skeeto/emacsql
-;; Version: 1.0.0
-
-;;; Commentary:
-
-;; The purpose of this package is to provide a high-level Elisp
-;; interface to a high-performance database back-end. Not every feature
-;; of SQL will be exposed, but the important parts should be.
-
-;; Most emacsql functions operate on a database connection. A
-;; connection to SQLite is established with `emacsql-connect'. For
-;; each such connection a sqlite3 inferior process is kept alive in
-;; the background. Connections are closed with `emacsql-close'.
-
-;; (defvar db (emacsql-connect "company.db"))
-
-;; Other types of database connections are available (PostgreSQL via
-;; `emacsql-psql').
-
-;; 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 -- $1, $2, etc. -- so they don't need to
-;; be built up dynamically:
-
-;; (emacsql db
-;; [:select [name id] :from employees :where (> salary $1)]
-;; 50000)
-;; ;; => (("Jeff" 1000) ("Susan" 1001))
-
-;; See README.md for much more complete documentation.
+;;; emacsql-compile.el --- s-expression SQL compiler -*- lexical-binding: t;
-*-
;;; Code:
(require 'cl-lib)
-(require 'eieio)
-
-(defclass emacsql-connection ()
- ((process :type process
- :initarg :process
- :reader emacsql-process)
- (log-buffer :type (or null buffer)
- :initarg :log-buffer
- :accessor emacsql-log-buffer
- :documentation "Output log (debug).")
- (types :initform nil
- :reader emacsql-types
- :documentation "Maps Emacsql types to SQL types."))
- (:documentation "A connection to a SQL database.")
- :abstract t)
-
-(defgeneric emacsql (connection sql &rest args)
- "Send SQL s-expression to CONNECTION and return the results.")
-
-(defgeneric emacsql-close (connection)
- "Close CONNECTION and free all resources.")
-
-(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.")
-
-(defmethod emacsql-buffer ((connection emacsql-connection))
- "Get proccess buffer for CONNECTION."
- (process-buffer (emacsql-process connection)))
-
-(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)))))
-
-;; Standard Emacsql errors:
(defmacro emacsql-deferror (symbol parents message)
"Defines a new error symbol for Emacsql."
@@ -125,147 +27,7 @@ MESSAGE should not have a newline on the end."
"Like `error', but signal an emacsql-syntax condition."
(signal 'emacsql-syntax (list (apply #'format format args))))
-;; Sending and receiving:
-
-(defmethod emacsql-send-string
- ((connection emacsql-connection) string &optional no-log)
- "Send STRING to CONNECTION, automatically appending newline."
- (let ((process (emacsql-process connection)))
- (unless no-log (emacsql-log connection string))
- (process-send-string process string)
- (process-send-string process "\n")))
-
-(defmethod emacsql-clear ((connection emacsql-connection))
- "Clear the process buffer for CONNECTION-SPEC."
- (with-current-buffer (emacsql-buffer connection)
- (erase-buffer)))
-
-(defgeneric emacsql-waiting-p (connection)
- "Return non-nil if CONNECTION is ready for more input.")
-
-(defmethod emacsql-wait ((connection emacsql-connection) &optional timeout)
- "Block until CONNECTION is waiting for further input."
- (let ((end (when timeout (+ (float-time) timeout))))
- (while (and (or (null timeout) (< (float-time) end))
- (not (emacsql-waiting-p connection)))
- (accept-process-output (emacsql-process connection) timeout))))
-
-;; Helper mix-in class:
-
-(defclass emacsql-simple-parser ()
- ()
- (:documentation "A mix-in for back-ends with a specific output format.")
- :abstract t)
-
-(defmethod emacsql-waiting-p ((connection emacsql-simple-parser))
- "The back-end must us a single \"]\" character as its prompt.
-This prompt value was chosen because it is unreadable."
- (with-current-buffer (emacsql-buffer connection)
- (cond ((= (buffer-size) 1) (string= "]" (buffer-string)))
- ((> (buffer-size) 1) (string= "\n]"
- (buffer-substring
- (- (point-max) 2) (point-max)))))))
-
-(defmethod emacsql-parse ((connection emacsql-simple-parser))
- "Parse output into an s-expression.
-Output should have one row per line, separated by whitespace."
- (with-current-buffer (emacsql-buffer connection)
- (let ((standard-input (current-buffer)))
- (setf (point) (point-min))
- (cl-loop until (looking-at "]")
- collect (read) into row
- when (looking-at "\n")
- collect row into rows
- and do (progn (forward-char 1) (setf row ()))
- finally (cl-return rows)))))
-
-(defmethod emacsql-error-check ((connection emacsql-simple-parser))
- "Return the error message from CONNECTION, or nil for no error."
- (with-current-buffer (emacsql-buffer connection)
- (let ((case-fold-search t))
- (setf (point) (point-min))
- (when (looking-at "error:")
- (buffer-substring (line-beginning-position) (line-end-position))))))
-
-(provide 'emacsql) ; end of generic function declarations
-
-;; Automatic connection cleanup:
-
-(defvar emacsql-connections ()
- "Collection of all known emacsql connections.
-This collection exists for cleanup purposes.")
-
-(defvar emacsql-reap-timer nil
- "Timer used to check for dead emacsql connections.")
-
-(defun emacsql-register (connection)
- "Add CONNECTION to the global connection list."
- (emacsql-start-reap-timer)
- (push (cons (copy-sequence connection) (emacsql--ref connection))
- emacsql-connections))
-
-(defun emacsql--ref (thing)
- "Create a weak reference to THING."
- (let ((ref (make-hash-table :test 'eq :size 1 :weakness 'value)))
- (prog1 ref
- (setf (gethash t ref) thing))))
-
-(defun emacsql--deref (ref)
- "Retrieve value from REF."
- (gethash t ref))
-
-(defun emacsql-reap ()
- "Clean up after lost connections."
- (cl-loop for (conn-copy . ref) in emacsql-connections
- when (null (emacsql--deref ref))
- count (prog1 t (ignore-errors (emacsql-close conn-copy)))
- into total
- else collect (cons conn-copy ref) into connections
- finally (progn
- (setf emacsql-connections connections)
- (cl-return total))))
-
-(cl-defun emacsql-start-reap-timer (&optional (interval 60))
- "Start the automatic `emacql-reap' timer."
- (unless emacsql-reap-timer
- (setf emacsql-reap-timer (run-at-time interval interval #'emacsql-reap))))
-
-(defun emacsql-stop-reap-timer ()
- "Stop the automatic `emacsql-reap' timer."
- (when (timerp emacsql-reap-timer)
- (cancel-timer emacsql-reap-timer)
- (setf emacsql-reap-timer nil)))
-
-;; Useful macros:
-
-(require 'emacsql-sqlite) ; for `emacsql-connect'
-
-(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)))))
-
-(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))
- ,@(cl-loop for statement in statements
- when (vectorp statement)
- collect (list 'emacsql 'emacsql--conn statement)
- else
- collect (append (list 'emacsql 'emacsql--conn) statement))))
-
-;; Escaping:
+;; Escaping functions:
(defun emacsql-quote (string)
"Quote STRING for use in a SQL expression."
@@ -299,7 +61,7 @@ A statement can be a list, containing a statement with its
arguments."
(vector (concat "(" (mapconcat #'emacsql-escape-value vector ", ") ")"))
(otherwise (emacsql-error "Invalid vector %S" vector))))
-;; S-expression SQL compilation:
+;; Statement compilers:
(defvar emacsql-expanders ()
"Alist of all expansion functions.")
@@ -381,12 +143,6 @@ a list of (<string> [arg-pos] ...)."
(otherwise
(emacsql-error "Invalid var type %S" kind))))))))
-(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)))
- (apply #'emacsql-format (emacsql-expand sql) args)))
-
(defun emacsql-var (var)
"Return the index number of VAR, or nil if VAR is not a variable.
A variable is a symbol that looks like $1, $2, $3, etc. A $ means
@@ -754,52 +510,6 @@ definitions for return from a `emacsql-defexpander'."
(emacsql-defexpander :vacuum ()
(list "VACUUM"))
-;; 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))
- (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-expand sql)
- (apply #'format string (cl-loop for i from 1 to (length vars)
- collect (intern (format "$%d" i))))))
-
-;;;###autoload
-(defun emacsql-show-last-sql ()
- "Display the compiled SQL of the s-expression SQL expression before point."
- (interactive)
- (emacsql-show-sql (emacsql-flatten-sql (preceding-sexp))))
-
-;;; emacsql.el ends here
+(provide 'emacsql-compiler)
+
+;;; emacsql-compile.el ends here
diff --git a/emacsql-psql.el b/emacsql-psql.el
index 0f07075ad4..abd3f7459e 100644
--- a/emacsql-psql.el
+++ b/emacsql-psql.el
@@ -64,7 +64,7 @@
(setf (emacsql-log-buffer connection)
(generate-new-buffer "*emacsql-log*")))
(emacsql-register connection)
- (mapc (apply-partially #'emacsql-send-string connection)
+ (mapc (lambda (s) (emacsql-send-string connection s :no-log))
'("\\pset pager off"
"\\pset null nil"
"\\a"
@@ -79,16 +79,6 @@
(when (process-live-p process)
(process-send-string process "\\q\n"))))
-(defmethod emacsql ((connection emacsql-psql-connection) sql &rest args)
- (let ((sql-string (apply #'emacsql-compile connection sql args)))
- (emacsql-clear connection)
- (emacsql-send-string connection sql-string)
- (emacsql-wait connection)
- (let ((error (emacsql-error-check connection)))
- (if error
- (signal 'emacsql-error (list error))
- (emacsql-parse connection)))))
-
(provide 'emacsql-psql)
;;; emacsql-psql.el ends here
diff --git a/emacsql-sqlite.el b/emacsql-sqlite.el
index 36eeba6647..0fa6c7f3f0 100644
--- a/emacsql-sqlite.el
+++ b/emacsql-sqlite.el
@@ -122,21 +122,13 @@ buffer. This is for debugging purposes."
("too many" emacsql-syntax))
"List of regexp's mapping sqlite3 output to conditions.")
-(defun emacsql-sqlite-get-condition (message)
+(defmethod emacsql-handle ((_ emacsql-sqlite-connection) message)
"Get condition for MESSAGE provided from SQLite."
- (or (cadr (cl-assoc message emacsql-sqlite-condition-alist
- :test (lambda (a b) (string-match-p b a))))
- 'emacsql-error))
-
-(defmethod emacsql ((connection emacsql-sqlite-connection) sql &rest args)
- (let ((sql-string (apply #'emacsql-compile connection sql args)))
- (emacsql-clear connection)
- (emacsql-send-string connection sql-string)
- (emacsql-wait connection)
- (let ((error (emacsql-error-check connection)))
- (if error
- (signal (emacsql-sqlite-get-condition error) (list error))
- (emacsql-parse connection)))))
+ (signal
+ (or (cadr (cl-assoc message emacsql-sqlite-condition-alist
+ :test (lambda (a b) (string-match-p b a))))
+ 'emacsql-error)
+ (list message)))
(provide 'emacsql-sqlite)
diff --git a/emacsql.el b/emacsql.el
index 05c4f97747..09155cfd56 100644
--- a/emacsql.el
+++ b/emacsql.el
@@ -59,6 +59,7 @@
(require 'cl-lib)
(require 'eieio)
+(require 'emacsql-compiler)
(defclass emacsql-connection ()
((process :type process
@@ -74,9 +75,6 @@
(:documentation "A connection to a SQL database.")
:abstract t)
-(defgeneric emacsql (connection sql &rest args)
- "Send SQL s-expression to CONNECTION and return the results.")
-
(defgeneric emacsql-close (connection)
"Close CONNECTION and free all resources.")
@@ -100,31 +98,6 @@ MESSAGE should not have a newline on the end."
(setf (point) (point-max))
(princ (concat message "\n") log)))))
-;; Standard Emacsql errors:
-
-(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-table () "Table error")
-(emacsql-deferror emacsql-lock () "Database locked")
-(emacsql-deferror emacsql-transaction () "Invalid transaction")
-(emacsql-deferror emacsql-fatal () "Fatal error")
-(emacsql-deferror emacsql-access () "Database access error")
-
-(defun emacsql-error (format &rest args)
- "Like `error', but signal an emacsql-syntax condition."
- (signal 'emacsql-syntax (list (apply #'format format args))))
-
;; Sending and receiving:
(defmethod emacsql-send-string
@@ -150,25 +123,62 @@ MESSAGE should not have a newline on the end."
(not (emacsql-waiting-p connection)))
(accept-process-output (emacsql-process connection) timeout))))
-;; Helper mix-in class:
+(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)))
+ (apply #'emacsql-format (emacsql-expand sql) args)))
+
+(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-string connection sql-string)
+ (emacsql-wait connection)
+ (emacsql-parse connection)))
+
+;; Helper mixin class:
(defclass emacsql-simple-parser ()
()
- (:documentation "A mix-in for back-ends with a specific output format.")
+ (:documentation
+ "A mixin for back-ends with a straightforward output format.
+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)
(defmethod emacsql-waiting-p ((connection emacsql-simple-parser))
- "The back-end must us a single \"]\" character as its prompt.
-This prompt value was chosen because it is unreadable."
+ "Return true of the end of the buffer has a properly-formatted prompt."
(with-current-buffer (emacsql-buffer connection)
(cond ((= (buffer-size) 1) (string= "]" (buffer-string)))
((> (buffer-size) 1) (string= "\n]"
(buffer-substring
(- (point-max) 2) (point-max)))))))
+(defmethod emacsql-handle ((_ emacsql-simple-parser) message)
+ "Signal a specific condition for MESSAGE from CONNECTION.
+Subclasses should override this method in order to provide more
+specific error conditions."
+ (signal 'emacsql-syntax (list message)))
+
+(defmethod emacsql-check-error ((connection emacsql-simple-parser))
+ "Return the error message from CONNECTION, or nil for no error."
+ (with-current-buffer (emacsql-buffer connection)
+ (let ((case-fold-search t))
+ (setf (point) (point-min))
+ (when (looking-at "error:")
+ (let* ((beg (line-beginning-position))
+ (end (line-end-position)))
+ (emacsql-handle connection (buffer-substring beg end)))))))
+
(defmethod emacsql-parse ((connection emacsql-simple-parser))
- "Parse output into an s-expression.
-Output should have one row per line, separated by whitespace."
+ "Parse well-formed output into an s-expression."
+ (emacsql-check-error connection)
(with-current-buffer (emacsql-buffer connection)
(let ((standard-input (current-buffer)))
(setf (point) (point-min))
@@ -179,14 +189,6 @@ Output should have one row per line, separated by
whitespace."
and do (progn (forward-char 1) (setf row ()))
finally (cl-return rows)))))
-(defmethod emacsql-error-check ((connection emacsql-simple-parser))
- "Return the error message from CONNECTION, or nil for no error."
- (with-current-buffer (emacsql-buffer connection)
- (let ((case-fold-search t))
- (setf (point) (point-min))
- (when (looking-at "error:")
- (buffer-substring (line-beginning-position) (line-end-position))))))
-
(provide 'emacsql) ; end of generic function declarations
;; Automatic connection cleanup:
@@ -265,495 +267,6 @@ A statement can be a list, containing a statement with
its arguments."
else
collect (append (list 'emacsql 'emacsql--conn) statement))))
-;; Escaping:
-
-(defun emacsql-quote (string)
- "Quote STRING for use in a SQL expression."
- (format "'%s'" (replace-regexp-in-string "'" "''" string)))
-
-(defun emacsql-escape-identifier (identifier)
- "Escape an identifier, always with quotes when FORCE is non-nil."
- (let ((string (cl-typecase identifier
- (string identifier)
- (keyword (substring (symbol-name identifier) 1))
- (otherwise (format "%S" identifier))))
- (forbidden "[]-\000-\040!\"#%&'()*+,./;<=>?@[\\^`{|}~\177]"))
- (when (or (string-match-p forbidden string)
- (string-match-p "^[0-9$]" string))
- (emacsql-error "Invalid Emacsql identifier: %S" identifier))
- (if (string-match-p ":" string)
- (replace-regexp-in-string ":" "." string)
- string)))
-
-(defun emacsql-escape-value (value)
- "Escape VALUE for sending to SQLite."
- (let ((print-escape-newlines t))
- (cond ((null value) "NULL")
- ((numberp value) (prin1-to-string value))
- ((emacsql-quote (prin1-to-string value))))))
-
-(defun emacsql-escape-vector (vector)
- "Encode VECTOR into a SQL vector scalar."
- (cl-typecase vector
- (list (mapconcat #'emacsql-escape-vector vector ", "))
- (vector (concat "(" (mapconcat #'emacsql-escape-value vector ", ") ")"))
- (otherwise (emacsql-error "Invalid vector %S" vector))))
-
-;; S-expression SQL compilation:
-
-(defvar emacsql-expanders ()
- "Alist of all expansion functions.")
-
-(defvar emacsql-expander-cache (make-hash-table :test 'equal)
- "Cache used to memoize `emacsql-expand'.")
-
-(defvar emacsql-type-map
- '((integer "INTEGER")
- (float "REAL")
- (object "TEXT")
- (nil "NONE"))
- "An alist mapping Emacsql types to SQL types.")
-
-(defun emacsql-add-expander (keyword arity function)
- "Register FUNCTION for KEYWORD as a SQL expander.
-FUNCTION should accept the keyword's arguments and should return
-a list of (<string> [arg-pos] ...)."
- (prog1 keyword
- (when emacsql-expander-cache (clrhash emacsql-expander-cache))
- (push (list keyword arity function) emacsql-expanders)))
-
-(defmacro emacsql-defexpander (keyword args &rest body)
- "Define an expander for KEYWORD."
- (declare (indent 2))
- `(emacsql-add-expander ,keyword ,(length args) (lambda ,args ,@body)))
-
-(defun emacsql-sql-p (thing)
- "Return non-nil if THING looks like a :select."
- (and (sequencep thing)
- (or (not (null (assoc (elt thing 0) emacsql-expanders)))
- (emacsql-sql-p (elt thing 0)))))
-
-(defun emacsql-get-expander (keyword)
- "Return the expander with arity for KEYWORD."
- (if (emacsql-sql-p keyword)
- (list 0 (lambda () (emacsql-expand keyword :subsql-p)))
- (cdr (assoc keyword emacsql-expanders))))
-
-(defun emacsql-expand (sql &optional subsql-p)
- "Expand SQL into a SQL-consumable string, with variables."
- (let* ((cache emacsql-expander-cache)
- (key (cons emacsql-type-map sql))
- (cached (and cache (gethash key cache))))
- (or cached
- (cl-loop with items = (cl-coerce sql 'list)
- while (not (null items))
- for keyword = (pop items)
- for (arity expander) = (emacsql-get-expander keyword)
- when expander
- collect (apply expander (cl-subseq items 0 arity)) into parts
- else do (emacsql-error "Unrecognized keyword %s" keyword)
- do (setf items (cl-subseq items arity))
- finally
- (let ((string (concat (if subsql-p "(" "")
- (mapconcat #'car parts " ")
- (if subsql-p ")" ";")))
- (vars (apply #'nconc (mapcar #'cdr parts))))
- (cl-return (if cache
- (setf (gethash key cache) (cons string vars))
- (cons string vars))))))))
-
-(defun emacsql-format (expansion &rest args)
- "Fill in the variables EXPANSION with ARGS."
- (cl-destructuring-bind (format . vars) expansion
- (unless (= (length args) (length vars))
- (emacsql-error "Wrong number of arguments for SQL template."))
- (apply #'format format
- (cl-loop for (i . kind) in vars collect
- (let ((thing (nth i args)))
- (cl-case kind
- (:identifier (emacsql-escape-identifier thing))
- (:value (emacsql-escape-value thing))
- (:vector (emacsql-escape-vector thing))
- (:schema (car (emacsql--schema-to-string thing)))
- (:auto (if (symbolp thing)
- (emacsql-escape-identifier thing)
- (emacsql-escape-value thing)))
- (otherwise
- (emacsql-error "Invalid var type %S" kind))))))))
-
-(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)))
- (apply #'emacsql-format (emacsql-expand sql) args)))
-
-(defun emacsql-var (var)
- "Return the index number of VAR, or nil if VAR is not a variable.
-A variable is a symbol that looks like $1, $2, $3, etc. A $ means
-$1. These are escaped with a double $$, in which case the proper
-symbol is returned."
- (when (symbolp var)
- (let ((name (symbol-name var)))
- (cond
- ((string-match-p "^\\$[0-9]+" name) (1- (read (substring name 1))))
- ((string-match-p "^\\$$" name) 0)
- ((string-match-p "^\\$\\$[0-9]+" name) (intern (substring name 1)))))))
-
-(defun emacsql-escape-format (thing &optional kind)
- "Escape THING for use as a `format' spec, pre-escaping for KIND.
-KIND should be :value or :identifier."
- (replace-regexp-in-string
- "%" "%%" (cl-case kind
- (:value (emacsql-escape-value thing))
- (:identifier (emacsql-escape-identifier thing))
- (:vector (emacsql-escape-vector thing))
- (otherwise thing))))
-
-(defvar emacsql--vars ()
- "For use with `emacsql-with-vars'.")
-
-(defun emacsql--vars-var (thing kind)
- "Only use within `emacsql-with-vars'!"
- (let ((var (emacsql-var thing)))
- (when (and var (symbolp var)) (setf thing var))
- (if (numberp var)
- (prog1 "%s" (push (cons var kind) emacsql--vars))
- (cl-case kind
- ((:identifier :value :vector) (emacsql-escape-format thing kind))
- (:auto (emacsql-escape-format
- thing (if (symbolp thing) :identifier :value)))
- (otherwise (emacsql-error "Invalid var type: %S" kind))))))
-
-(defun emacsql--vars-combine (expanded)
- "Only use within `emacsql-with-vars'!"
- (cl-destructuring-bind (string . vars) expanded
- (setf emacsql--vars (nconc emacsql--vars vars))
- string))
-
-(defmacro emacsql-with-vars (prefix &rest body)
- "Evaluate BODY, collecting variables with `var', `combine', `expr', `idents'.
-BODY should return a string, which will be combined with variable
-definitions for return from a `emacsql-defexpander'."
- (declare (indent 1))
- `(let ((emacsql--vars ()))
- (cl-flet* ((var (thing kind) (emacsql--vars-var thing kind))
- (combine (expanded) (emacsql--vars-combine expanded))
- (expr (thing) (combine (emacsql--expr thing)))
- (idents (thing) (combine (emacsql--idents thing)))
- (subsql (thing) (combine (emacsql-expand thing t))))
- (cons (concat ,prefix (progn ,@body)) emacsql--vars))))
-
-(defun emacsql--column-to-string (column)
- "Convert COLUMN schema into a SQL string."
- (emacsql-with-vars ""
- (when (symbolp column)
- (setf column (list column)))
- (let ((name (var (pop column) :identifier))
- (output ())
- (type (cadr (assoc nil emacsql-type-map))))
- (while column
- (let ((next (pop column)))
- (cl-case next
- (:primary (push "PRIMARY KEY" output))
- (:autoincrement (push "AUTOINCREMENT" output))
- (:non-nil (push "NOT NULL" output))
- (:unique (push "UNIQUE" output))
- (:default (push "DEFAULT" output)
- (push (var (pop column) :value) output))
- (:check (push "CHECK" output)
- (push (format "(%s)" (expr (pop column))) output))
- ((integer float object)
- (setf type (cadr (assoc next emacsql-type-map))))
- (otherwise
- (if (keywordp next)
- (emacsql-error "Unknown schema contraint %s" next)
- (emacsql-error "Invalid type %s: %s" next
- "must be 'integer', 'float', or 'object'"))))))
- (setf output (nreverse output))
- (when type (push type output))
- (push name output)
- (mapconcat #'identity output " "))))
-
-(defun emacsql--columns-to-string (columns)
- "Convert COLUMNS into a SQL-consumable string."
- (emacsql-with-vars ""
- (cl-loop for column across columns
- collect (combine (emacsql--column-to-string column)) into parts
- finally (cl-return (mapconcat #'identity parts ", ")))))
-
-(defun emacsql--foreign-key (spec)
- (emacsql-with-vars "FOREIGN KEY "
- (cl-destructuring-bind (child table parent . actions) (cl-coerce spec
'list)
- (mapconcat
- #'identity
- (cons
- (format "(%s) REFERENCES %s (%s)" (idents child) (var table
:identifier)
- (idents parent))
- (cl-loop for (key value) on actions by #'cddr collect
- (cl-case key
- (:on-update "ON UPDATE")
- (:on-delete "ON DELETE")
- (otherwise (emacsql-error "Invalid case: %S" key)))
- collect
- (cl-case value
- (:restrict "RESTRICT")
- (:set-nil "SET NULL")
- (:set-default "SET DEFAULT")
- (:cascade "CASCADE")
- (otherwise (emacsql-error "Invalid action: %S" key)))))
- " "))))
-
-(defun emacsql--schema-to-string (schema)
- (cl-typecase schema
- (vector (emacsql--columns-to-string schema))
- (list
- (emacsql-with-vars ""
- (mapconcat
- #'identity
- (cons
- (combine (emacsql--columns-to-string (pop schema)))
- (cl-loop for (key value) on schema by #'cddr collect
- (cl-case key
- (:primary (format "PRIMARY KEY (%s)" (idents value)))
- (:unique (format "UNIQUE (%s)" (idents value)))
- (:check (format "CHECK (%s)" (expr value)))
- (:foreign (combine (emacsql--foreign-key value)))
- (otherwise
- (emacsql-error "Invalid table constraint: %S" key)))))
- ", ")))
- (otherwise (emacsql-error "Invalid schema: %S" schema))))
-
-(defun emacsql--vector (vector)
- "Expand VECTOR, making variables as needed."
- (emacsql-with-vars ""
- (cl-typecase vector
- (symbol
- (var vector :vector))
- (list
- (mapconcat (lambda (v) (combine (emacsql--vector v))) vector ", "))
- (vector
- (format "(%s)" (mapconcat (lambda (x) (var x :value)) vector ", ")))
- (otherwise (emacsql-error "Invalid vector: %S" vector)))))
-
-(defun emacsql--expr (expr)
- "Expand EXPR recursively."
- (emacsql-with-vars ""
- (cond
- ((emacsql-sql-p expr) (subsql expr))
- ((atom expr) (var expr :auto))
- ((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
- ;; Trinary/binary
- ((<= >=)
- (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))))
- ;; Binary
- ((< > = != like glob is * / % << >> + & | as)
- (if (= 2 (length args))
- (format "%s %s %s"
- (recur 0)
- (if (eq op '%) '%% (upcase (symbol-name op)))
- (recur 1))
- (nops op)))
- ;; Unary
- ((not)
- (if (= 1 (length args))
- (format "%s %s" (upcase (symbol-name op)) (recur 0))
- (nops op)))
- ;; Unary/Binary
- ((-)
- (cl-case (length args)
- (1 (format "-(%s)" (recur 0)))
- (2 (format "%s - %s" (recur 0) (recur 1)))
- (otherwise (nops op))))
- ;; Variadic
- ((and or)
- (cl-case (length args)
- (0 (if (eq op 'and) "1" "0"))
- (1 (recur 0))
- (otherwise
- (mapconcat
- #'recur (cl-loop for i from 0 below (length args) collect i)
- (format " %s " (upcase (symbol-name op)))))))
- ;; quote special case
- ((quote)
- (cl-case (length args)
- (1 (var (nth 0 args) :value))
- (otherwise (nops op))))
- ;; IN special case
- ((in)
- (cl-case (length args)
- (1 (emacsql-error "Wrong number of operands for %s" op))
- (2 (format "%s IN %s" (recur 0) (var (nth 1 args) :vector)))
- (otherwise
- (format "%s IN %s" (recur 0) (subsql (cdr args))))))
- (otherwise (emacsql-error "Unknown operator: %S" op)))))))))
-
-(defun emacsql--idents (idents)
- "Read in a vector of IDENTS identifiers, or just an single identifier."
- (emacsql-with-vars ""
- (cl-typecase idents
- (symbol (var idents :identifier))
- (list (expr idents))
- (vector (mapconcat (lambda (e) (expr e)) idents ", "))
- (otherwise (emacsql-error "Invalid syntax: %S" idents)))))
-
-(defun emacsql-init-font-lock ()
- "Add font-lock highlighting for `emacsql-defexpander'."
- (font-lock-add-keywords
- 'emacs-lisp-mode
- '(("(\\(emacsql-defexpander\\)\\_>"
- (1 'font-lock-keyword-face)))))
-
-;; SQL Expansion Functions:
-
-(emacsql-defexpander :select (arg)
- "Expands to the SELECT keyword."
- (emacsql-with-vars "SELECT "
- (if (eq '* arg)
- "*"
- (idents arg))))
-
-(emacsql-defexpander :from (sources)
- "Expands to the FROM keyword."
- (emacsql-with-vars "FROM "
- (idents sources)))
-
-(emacsql-defexpander :replace ()
- (list "REPLACE"))
-
-(emacsql-defexpander :insert ()
- (list "INSERT"))
-
-(emacsql-defexpander :into (table)
- "Expands to the INTO keywords."
- (emacsql-with-vars "INTO "
- (cl-typecase table
- (symbol (var table :identifier))
- (list (cl-destructuring-bind (name columns) table
- (format "%s (%s)" (var name :identifier)
- (idents columns)))))))
-
-(emacsql-defexpander :where (expr)
- (emacsql-with-vars "WHERE "
- (expr expr)))
-
-(emacsql-defexpander :having (expr)
- (emacsql-with-vars "HAVING "
- (expr expr)))
-
-(emacsql-defexpander :group-by (expr)
- (emacsql-with-vars "GROUP BY "
- (expr expr)))
-
-(emacsql-defexpander :order-by (columns)
- (emacsql-with-vars "ORDER BY "
- (cl-flet ((order (k) (cl-case k
- (:asc " ASC")
- (:desc " DESC")
- (otherwise (emacsql-error "Invalid order: %S" k)))))
- (if (not (vectorp columns))
- (expr columns)
- (cl-loop for column across columns collect
- (cl-typecase column
- (list (let ((kpos (cl-position-if #'keywordp column)))
- (if kpos
- (concat (expr (nth (- 1 kpos) column))
- (order (nth kpos column)))
- (expr column))))
- (symbol (var column :identifier))
- (otherwise (emacsql-error "Invalid order spec: %S" column)))
- into parts
- finally (cl-return (mapconcat #'identity parts ", ")))))))
-
-(emacsql-defexpander :limit (limits)
- (emacsql-with-vars "LIMIT "
- (if (vectorp limits)
- (mapconcat #'expr limits ", ")
- (expr limits))))
-
-(emacsql-defexpander :create-table (table schema)
- (emacsql-with-vars "CREATE "
- (let (temporary if-not-exists name)
- (dolist (item (if (listp table) table (list table)))
- (cl-case item
- (:if-not-exists (setf if-not-exists "IF NOT EXISTS"))
- (:temporary (setf temporary "TEMPORARY"))
- (otherwise (setf name (var item :identifier)))))
- (let* ((items (list temporary "TABLE" if-not-exists name))
- (spec (cl-remove-if-not #'identity items)))
- (format "%s %s" (mapconcat #'identity spec " ")
- (cond ((symbolp schema)
- (format "(%s)" (var schema :schema)))
- ((eq :select (elt schema 0))
- (concat "AS " (subsql schema)))
- ((let ((compiled (emacsql--schema-to-string schema)))
- (format "(%s)" (combine compiled))))))))))
-
-(emacsql-defexpander :drop-table (table)
- (emacsql-with-vars "DROP TABLE "
- (var table :identifier)))
-
-(emacsql-defexpander :delete ()
- (list "DELETE"))
-
-(emacsql-defexpander :values (values)
- (emacsql-with-vars "VALUES "
- (combine (emacsql--vector values))))
-
-(emacsql-defexpander :update (table)
- (emacsql-with-vars "UPDATE "
- (var table :identifier)))
-
-(emacsql-defexpander :set (set)
- (emacsql-with-vars "SET "
- (cl-typecase set
- (vector (idents set))
- (list (expr set))
- (otherwise (emacsql-error "Invalid SET expression: %S" set)))))
-
-(emacsql-defexpander :union ()
- (list "UNION"))
-
-(emacsql-defexpander :union-all ()
- (list "UNION ALL"))
-
-(emacsql-defexpander :intersect ()
- (list "INTERSECT"))
-
-(emacsql-defexpander :except ()
- (list "EXCEPT"))
-
-(emacsql-defexpander :pragma (expr)
- (emacsql-with-vars "PRAGMA "
- (expr expr)))
-
-(emacsql-defexpander :begin (kind)
- (emacsql-with-vars "BEGIN "
- (cl-case kind
- (:transaction "TRANSACTION")
- (:deferred "DEFERRED")
- (:immediate "IMMEDIATE")
- (:exclusive "EXCLUSIVE")
- (otherwise (emacsql-error "Unknown transaction type: %S" kind)))))
-
-(emacsql-defexpander :commit ()
- (list "COMMIT"))
-
-(emacsql-defexpander :rollback ()
- (list "ROLLBACK"))
-
-(emacsql-defexpander :vacuum ()
- (list "VACUUM"))
-
;; User interaction functions:
(defvar emacsql-show-buffer-name "*emacsql-show*"
