branch: elpa/emacsql
commit 79fb8cb223030aa41688ddedf4bb412dc8c42d26
Author: Christopher Wellons <well...@nullprogram.com>
Commit: Christopher Wellons <well...@nullprogram.com>
Heavy compiler rework.
---
emacsql-compiler.el | 751 +++++++++++++++++-----------------------------------
emacsql-tests.el | 67 +++--
emacsql.el | 21 +-
3 files changed, 288 insertions(+), 551 deletions(-)
diff --git a/emacsql-compiler.el b/emacsql-compiler.el
index 34d3498300..18d979348a 100644
--- a/emacsql-compiler.el
+++ b/emacsql-compiler.el
@@ -32,31 +32,37 @@
;; Escaping functions:
-(defun emacsql-quote (string)
- "Quote STRING for use in a SQL expression."
+(defun emacsql-quote-scalar (string)
+ "Single-quote (scalar) STRING for use in a SQL expression."
(format "'%s'" (replace-regexp-in-string "'" "''" 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, 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 (null identifier)
- (string-match-p forbidden string)
- (string-match-p "^[0-9$]" string))
- (emacsql-error "Invalid Emacsql identifier: %S" identifier))
- (setf string (replace-regexp-in-string ":" "." string))
- (setf string (replace-regexp-in-string "-" "_" string))
- string))
+ "Escape an identifier, if needed, for SQL."
+ (when (or (null identifier)
+ (keywordp identifier)
+ (not (symbolp identifier)))
+ (emacsql-error "Invalid identifier: %S" identifier))
+ (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-quote-identifier print)
+ name)))))
(defun emacsql-escape-scalar (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))))))
+ ((emacsql-quote-scalar (prin1-to-string value))))))
(defun emacsql-escape-vector (vector)
"Encode VECTOR into a SQL vector scalar."
@@ -66,100 +72,6 @@
(vector (concat "(" (mapconcat #'emacsql-escape-scalar vector ", ") ")"))
(otherwise (emacsql-error "Invalid vector %S" vector))))
-;; Statement compilers:
-
-(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))
- (:scalar (emacsql-escape-scalar thing))
- (:vector (emacsql-escape-vector thing))
- (:schema (car (emacsql--schema-to-string thing)))
- (:auto (if (and thing (symbolp thing))
- (emacsql-escape-identifier thing)
- (emacsql-escape-scalar thing)))
- (otherwise
- (emacsql-error "Invalid var type %S" kind))))))))
-
-(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 :scalar or :identifier."
@@ -170,420 +82,241 @@ KIND should be :scalar or :identifier."
(:vector (emacsql-escape-vector thing))
(otherwise 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
+ (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 ()
"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"
- (setf emacsql--vars (nconc emacsql--vars (list (cons var kind)))))
- (cl-case kind
- ((:identifier :scalar :vector) (emacsql-escape-format thing kind))
- (:auto (emacsql-escape-format
- thing (if (and thing (symbolp thing)) :identifier :scalar)))
- (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'."
+(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), schema (S)."
+ (when (symbolp thing)
+ (let ((name (symbol-name thing)))
+ (when (string-match-p "^\\$[isvS][0-9]+$" name)
+ (cons (1- (read (substring name 2)))
+ (cl-ecase (aref name 1)
+ (?i :identifier)
+ (?s :scalar)
+ (?v :vector)
+ (?S :schema)))))))
+
+(defmacro emacsql-with-params (prefix &rest body)
+ "Evaluate BODY, collecting patameters.
+Provided local functions: `param', `identifier', `scalar',
+`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* ((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))))
+ (cl-flet* ((combine (prepared) (emacsql--*combine prepared))
+ (param (thing) (emacsql--!param thing))
+ (identifier (thing) (emacsql--!param thing :identifier))
+ (scalar (thing) (emacsql--!param thing :scalar))
+ (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--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) :scalar) output))
- (:check (push "CHECK" output)
- (push (format "(%s)" (expr (pop column))) output))
- (:references
- (push (combine (emacsql--references (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--references (spec)
- (emacsql-with-vars "REFERENCES "
- (cl-destructuring-bind (table parent . actions) (cl-coerce spec 'list)
- (mapconcat
- #'identity
- (cons
- (format "%s (%s)" (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--foreign-key (spec)
- (emacsql-with-vars "FOREIGN KEY "
- (cl-destructuring-bind (child . references) (cl-coerce spec 'list)
- (format "(%s) %s" (idents child)
- (combine (emacsql--references references))))))
-
-(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)))
- (:references (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 ""
+(defun emacsql--!param (thing &optional kind)
+ "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))
+ (:schema (emacsql-prepare-schema thing)))
+ (if (symbolp thing)
+ (emacsql-escape-identifier thing)
+ (emacsql-escape-scalar thing))))
+ (prog1 "%s"
+ (check param)
+ (setf emacsql--vars (nconc emacsql--vars (list param))))))))
+
+(defun emacsql--*vector (vector)
+ "Prepare VECTOR."
+ (emacsql-with-params ""
(cl-typecase vector
- (symbol
- (var vector :vector))
- (list
- (mapconcat (lambda (v) (combine (emacsql--vector v))) vector ", "))
- (vector
- (format "(%s)" (mapconcat (lambda (x) (var x :scalar)) vector ", ")))
+ (symbol (param vector :vector))
+ (list (mapconcat #'svector vector ", "))
+ (vector (format "(%s)" (mapconcat #'scalar vector ", ")))
(otherwise (emacsql-error "Invalid vector: %S" vector)))))
-(defun emacsql--expr (expr)
+(defun emacsql--*expr (expr)
"Expand EXPR recursively."
- (emacsql-with-vars ""
+ (emacsql-with-params ""
(cond
((emacsql-sql-p expr) (subsql expr))
- ((atom expr) (var expr :auto))
+ ((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
- ;; 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) :scalar))
- (otherwise (nops op))))
- ;; funcall special case
- ((funcall)
- (cl-case (length args)
- (2 (format "%s(%s)" (var (nth 0 args) :identifier) (recur 1)))
- (otherwise
- (emacsql-error "Wrong number of operands for %s" 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)
+ (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))))
+ ;; Special case quote
+ ((quote) (scalar (nth 0 args)))
+ ;; 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-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 "
- (cond ((eq '* arg)
- "*")
- ((listp arg)
- (cl-case (length arg)
- (1 (idents (car arg)))
- (2 (cl-case (car arg)
- (:distinct (concat "DISTINCT " (idents (cadr arg))))
- (:all (concat "ALL " (idents (cadr arg))))
- (otherwise (emacsql-error "Invalid SELECT: %S" (car arg)))))
- (otherwise (emacsql-error "Invalid SELECT idents: %S" arg))))
- ((idents arg)))))
-
-(emacsql-defexpander :from (sources)
- "Expands to the FROM keyword."
- (emacsql-with-vars "FROM "
- (idents sources)))
-
-(emacsql-defexpander :join (source)
- (emacsql-with-vars "JOIN "
- (idents source)))
-
-(emacsql-defexpander :natural ()
- (list "NATURAL"))
-
-(emacsql-defexpander :outer ()
- (list "OUTER"))
-
-(emacsql-defexpander :inner ()
- (list "INNER"))
-
-(emacsql-defexpander :cross ()
- (list "CROSS"))
-
-(emacsql-defexpander :left ()
- (list "LEFT"))
-
-(emacsql-defexpander :right ()
- (list "RIGHT"))
-
-(emacsql-defexpander :full ()
- (list "FULL"))
-
-(emacsql-defexpander :on (expr)
- (emacsql-with-vars "ON "
- (expr expr)))
-
-(emacsql-defexpander :using (columns)
- (emacsql-with-vars "USING "
- (format "(%s)" (idents columns))))
-
-(emacsql-defexpander :insert ()
- (list "INSERT"))
-
-(emacsql-defexpander :replace ()
- (list "REPLACE"))
-
-(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 :alter-table (table)
- (emacsql-with-vars "ALTER TABLE "
- (var table :identifier)))
-
-(emacsql-defexpander :add-column (column)
- (emacsql-with-vars "ADD COLUMN "
- (cl-typecase column
- (symbol (var column :identifier))
- (list (combine (emacsql--column-to-string column)))
- (otherwise (emacsql-error "Only one column allowed here: %S" column)))))
-
-(emacsql-defexpander :rename-to (new-name)
- (emacsql-with-vars "RENAME TO "
- (var new-name :identifier)))
-
-(emacsql-defexpander :vacuum ()
- (list "VACUUM"))
+ (emacsql-with-params ""
+ (mapconcat #'expr idents ", ")))
+
+(defun emacsql--*combine (prepared)
+ "Only use within `emacsql-with-vars'!"
+ (cl-destructuring-bind (string . vars) prepared
+ (setf emacsql--vars (nconc emacsql--vars vars))
+ string))
+
+(defun emacsql-prepare (sql)
+ "Expand SQL into a SQL-consumable string, with parameters."
+ (let* ((cache emacsql-prepare-cache)
+ (key (cons emacsql-type-map sql)))
+ (or (gethash key cache)
+ (setf (gethash key cache)
+ (emacsql-with-params ""
+ (cl-loop with items = (cl-coerce sql '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)))
+ (symbolp (if (eq item '*)
+ "*"
+ (identifier 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)))))
+ into parts
+ do (setf last item)
+ finally (cl-return
+ (mapconcat #'identity parts " "))))))))
+
+(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))
+ (:scalar (emacsql-escape-scalar thing))
+ (:vector (emacsql-escape-vector thing))
+ (:schema (car (emacsql--schema-to-string thing)))
+ (otherwise
+ (emacsql-error "Invalid var type %S" kind))))))))
(provide 'emacsql-compiler)
diff --git a/emacsql-tests.el b/emacsql-tests.el
index 282bfe25af..f8fd98e1af 100644
--- a/emacsql-tests.el
+++ b/emacsql-tests.el
@@ -26,18 +26,18 @@
(mapcar #'car emacsql-tests-connection-factories)))
(ert-deftest emacsql-escape-identifier ()
- (should (string= (emacsql-escape-identifier "foo") "foo"))
+ (should-error (string= (emacsql-escape-identifier "foo")))
(should (string= (emacsql-escape-identifier 'foo) "foo"))
- (should (string= (emacsql-escape-identifier :foo) "foo"))
- (should-error (emacsql-escape-identifier "a b"))
- (should-error (emacsql-escape-identifier '$foo))
+ (should-error (string= (emacsql-escape-identifier :foo)))
+ (should (string= (emacsql-escape-identifier 'a\ b) "\"a\\ b\""))
+ (should (string= (emacsql-escape-identifier '$foo) "\"$foo\""))
(should-error (emacsql-escape-identifier 10))
(should-error (emacsql-escape-identifier nil))
(should (string= (emacsql-escape-identifier 'person-id) "person_id"))
(should (string= (emacsql-escape-identifier
'people:person-id) "people.person_id"))
(should (string= (emacsql-escape-identifier 'foo$) "foo$"))
- (should (string= (emacsql-escape-identifier "foo:bar") "foo.bar")))
+ (should (string= (emacsql-escape-identifier 'foo:bar) "foo.bar")))
(ert-deftest emacsql-escape-scalar ()
(should (string= (emacsql-escape-scalar 'foo) "'foo'"))
@@ -54,34 +54,33 @@
"(1, 2, 3), (4, 5, 6)")))
(ert-deftest emacsql-schema ()
- (should (string= (car (emacsql--schema-to-string [a]))
- "a NONE"))
- (should (string= (car (emacsql--schema-to-string [a b c]))
- "a NONE, b NONE, c NONE"))
- (should (string= (car (emacsql--schema-to-string [a (b)]))
- "a NONE, b NONE"))
- (should (string= (car (emacsql--schema-to-string [a (b float)]))
- "a NONE, b REAL"))
- (should (string= (car (emacsql--schema-to-string
- [a (b float :primary :unique)]))
- "a NONE, b REAL PRIMARY KEY UNIQUE"))
- (should (string= (car (emacsql--schema-to-string [(a integer) (b float)]))
- "a INTEGER, b REAL")))
+ (should (string= (emacsql-prepare-schema [a]) "a &NONE"))
+ (should (string= (emacsql-prepare-schema [a b c])
+ "a &NONE, b &NONE, c &NONE"))
+ (should (string= (emacsql-prepare-schema [a (b)])
+ "a &NONE, b &NONE"))
+ (should (string= (emacsql-prepare-schema [a (b float)])
+ "a &NONE, b &REAL"))
+ (should (string= (emacsql-prepare-schema
+ [a (b float :primary-key :unique)])
+ "a &NONE, b &REAL PRIMARY KEY UNIQUE"))
+ (should (string= (emacsql-prepare-schema [(a integer) (b float)])
+ "a &INTEGER, b &REAL")))
-(ert-deftest emacsql-var ()
- (should (eq (emacsql-var 'a) nil))
- (should (eq (emacsql-var 0) nil))
- (should (eq (emacsql-var "") nil))
- (should (eq (emacsql-var '$) 0))
- (should (eq (emacsql-var '$1) 0))
- (should (eq (emacsql-var '$5) 4))
- (should (eq (emacsql-var '$10) 9))
- (should (eq (emacsql-var '$a) nil))
- (should (eq (emacsql-var '$$10) '$10)))
+(ert-deftest emacsql-param ()
+ (should (equal (emacsql-param 'a) nil))
+ (should (equal (emacsql-param 0) nil))
+ (should (equal (emacsql-param "") nil))
+ (should (equal (emacsql-param '$) nil))
+ (should (equal (emacsql-param '$1) nil))
+ (should (equal (emacsql-param '$s5) '(4 . :scalar)))
+ (should (equal (emacsql-param '$v10) '(9 . :vector)))
+ (should (equal (emacsql-param '$a) nil))
+ (should (equal (emacsql-param '$i10) '(9 . :identifier))))
(defun emacsql-tests-query (query args result)
"Check that QUERY outputs RESULT for ARGS."
- (should (string= (apply #'emacsql-format (emacsql-expand query) args)
+ (should (string= (apply #'emacsql-compile nil (emacsql-expand query) args)
result)))
(defmacro emacsql-tests-with-queries (&rest queries)
@@ -91,20 +90,20 @@
(ert-deftest emacsql-select ()
(emacsql-tests-with-queries
- ([:select [$1 name] :from $2] '(id people)
+ ([:select [$i1 name] :from $i2] '(id people)
"SELECT id, name FROM people;")
([:select * :from employees] '()
"SELECT * FROM employees;")
([:select * :from employees :where (< salary 50000)] '()
"SELECT * FROM employees WHERE salary < 50000;")
- ([:select * :from people :where (in name $1)] '([FOO BAR])
+ ([:select * :from people :where (in name $v1)] '([FOO BAR])
"SELECT * FROM people WHERE name IN ('FOO', 'BAR');")
;; Sub queries
- ([:select name :from (:select * :from $1)] '(people)
+ ([:select name :from [:select * :from $i1]] '(people)
"SELECT name FROM (SELECT * FROM people);")
([:select name :from [people (as accounts a)]] '()
"SELECT name FROM people, accounts AS a;")
- ([:select p:name :from [(as (:select * :from people) p)]] '()
+ ([:select p:name :from [(as [:select * :from people] p)]] '()
"SELECT p.name FROM (SELECT * FROM people) AS p;")))
(ert-deftest emacsql-create-table ()
@@ -119,7 +118,7 @@
"CREATE TABLE foo (a NONE PRIMARY KEY NOT NULL, b NONE);")
([:create-table foo [a (b :check (< b 10))]] '()
"CREATE TABLE foo (a NONE, b NONE CHECK (b < 10));")
- ([:create-table foo $1] '([a b (c :primary)])
+ ([:create-table foo $S1] '([a b (c :primary)])
"CREATE TABLE foo (a NONE, b NONE, c NONE PRIMARY KEY);")
([:create-table foo [a b (c :default $1)]] '("FOO")
"CREATE TABLE foo (a NONE, b NONE, c NONE DEFAULT '\"FOO\"');")
diff --git a/emacsql.el b/emacsql.el
index 39212614ff..a48bc5f0f6 100644
--- a/emacsql.el
+++ b/emacsql.el
@@ -139,7 +139,7 @@ MESSAGE should not have a newline on the end."
"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)))
+ (concat (apply #'emacsql-format (emacsql-prepare sql) args) ";")))
(defmethod emacsql ((connection emacsql-connection) sql &rest args)
"Send SQL s-expression to CONNECTION and return the results."
@@ -316,18 +316,23 @@ Each column must be a plain symbol, no expressions
allowed here."
(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))))))
+ (cl-destructuring-bind (string . vars) (emacsql-prepare sql)
+ (concat
+ (apply #'format string (cl-loop for i from 1 to (length vars)
+ collect (intern (format "$%d" 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 ((sql (emacsql-flatten-sql (preceding-sexp))))
- (if prefix
- (insert sql)
- (emacsql-show-sql sql))))
+ (let ((sexp (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))))
;;; emacsql.el ends here
