547 lines
22 KiB
EmacsLisp
547 lines
22 KiB
EmacsLisp
;;; emacsql-compiler.el --- S-expression SQL compiler -*- lexical-binding:t -*-
|
|
|
|
;; This is free and unencumbered software released into the public domain.
|
|
|
|
;; Author: Christopher Wellons <wellons@nullprogram.com>
|
|
;; Maintainer: Jonas Bernoulli <emacs.emacsql@jonas.bernoulli.dev>
|
|
|
|
;; SPDX-License-Identifier: Unlicense
|
|
|
|
;;; Commentary:
|
|
|
|
;; This library provides support for compiling S-expressions to SQL.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
|
|
(eval-when-compile (require 'subr-x))
|
|
|
|
;;; Error symbols
|
|
|
|
(defmacro emacsql-deferror (symbol parents message)
|
|
"Defines a new error symbol for EmacSQL."
|
|
(declare (indent 2))
|
|
(let ((conditions (cl-remove-duplicates
|
|
(append parents (list symbol 'emacsql-error 'error)))))
|
|
`(prog1 ',symbol
|
|
(put ',symbol 'error-conditions ',conditions)
|
|
(put ',symbol 'error-message ,message))))
|
|
|
|
(emacsql-deferror emacsql-error () ;; parent condition for all others
|
|
"EmacSQL had an unhandled condition")
|
|
|
|
(emacsql-deferror emacsql-syntax () "Invalid SQL statement")
|
|
(emacsql-deferror emacsql-internal () "Internal error")
|
|
(emacsql-deferror emacsql-locked () "Database locked")
|
|
(emacsql-deferror emacsql-fatal () "Fatal error")
|
|
(emacsql-deferror emacsql-memory () "Out of memory")
|
|
(emacsql-deferror emacsql-corruption () "Database corrupted")
|
|
(emacsql-deferror emacsql-access () "Database access error")
|
|
(emacsql-deferror emacsql-timeout () "Query timeout error")
|
|
(emacsql-deferror emacsql-warning () "Warning message")
|
|
|
|
(defun emacsql-error (format &rest args)
|
|
"Like `error', but signal an emacsql-syntax condition."
|
|
(signal 'emacsql-syntax (list (apply #'format format args))))
|
|
|
|
;;; Escaping functions
|
|
|
|
(defvar emacsql-reserved (make-hash-table :test 'equal)
|
|
"Collection of all known reserved words, used for escaping.")
|
|
|
|
(defun emacsql-register-reserved (seq)
|
|
"Register sequence of keywords as reserved words, returning SEQ."
|
|
(cl-loop for word being the elements of seq
|
|
do (setf (gethash (upcase (format "%s" word)) emacsql-reserved) t)
|
|
finally (cl-return seq)))
|
|
|
|
(defun emacsql-reserved-p (name)
|
|
"Returns non-nil if string NAME is a SQL keyword."
|
|
(gethash (upcase name) emacsql-reserved))
|
|
|
|
(defun emacsql-quote-scalar (string)
|
|
"Single-quote (scalar) STRING for use in a SQL expression."
|
|
(with-temp-buffer
|
|
(insert string)
|
|
(goto-char (point-min))
|
|
(while (re-search-forward "'" nil t)
|
|
(replace-match "''"))
|
|
(goto-char (point-min))
|
|
(insert "'")
|
|
(goto-char (point-max))
|
|
(insert "'")
|
|
(buffer-string)))
|
|
|
|
(defun emacsql-quote-character (c)
|
|
"Single-quote character C for use in a SQL expression."
|
|
(if (char-equal c ?')
|
|
"''''"
|
|
(format "'%c'" c)))
|
|
|
|
(defun emacsql-quote-identifier (string)
|
|
"Double-quote (identifier) STRING for use in a SQL expression."
|
|
(format "\"%s\"" (replace-regexp-in-string "\"" "\"\"" string)))
|
|
|
|
(defun emacsql-escape-identifier (identifier)
|
|
"Escape an identifier, if needed, for SQL."
|
|
(when (or (null identifier)
|
|
(keywordp identifier)
|
|
(not (or (symbolp identifier)
|
|
(vectorp identifier))))
|
|
(emacsql-error "Invalid identifier: %S" identifier))
|
|
(cond
|
|
((vectorp identifier)
|
|
(mapconcat #'emacsql-escape-identifier identifier ", "))
|
|
((eq identifier '*) "*")
|
|
(t
|
|
(let ((name (symbol-name identifier)))
|
|
(if (string-match-p ":" name)
|
|
(mapconcat #'emacsql-escape-identifier
|
|
(mapcar #'intern (split-string name ":")) ".")
|
|
(let ((print (replace-regexp-in-string "-" "_" (format "%S" identifier)))
|
|
(special "[]-\000-\040!\"#%&'()*+,./:;<=>?@[\\^`{|}~\177]"))
|
|
(if (or (string-match-p special print)
|
|
(string-match-p "^[0-9$]" print)
|
|
(emacsql-reserved-p print))
|
|
(emacsql-quote-identifier print)
|
|
print)))))))
|
|
|
|
(defvar print-escape-control-characters)
|
|
|
|
(defun emacsql-escape-scalar (value)
|
|
"Escape VALUE for sending to SQLite."
|
|
(let ((print-escape-newlines t)
|
|
(print-escape-control-characters t))
|
|
(cond ((null value) "NULL")
|
|
((numberp value) (prin1-to-string value))
|
|
((emacsql-quote-scalar (prin1-to-string value))))))
|
|
|
|
(defun emacsql-escape-raw (value)
|
|
"Escape VALUE for sending to SQLite."
|
|
(cond ((null value) "NULL")
|
|
((stringp value) (emacsql-quote-scalar value))
|
|
((error "Expected string or nil"))))
|
|
|
|
(defun emacsql-escape-vector (vector)
|
|
"Encode VECTOR into a SQL vector scalar."
|
|
(cl-typecase vector
|
|
(null (emacsql-error "Empty SQL vector expression"))
|
|
(list (mapconcat #'emacsql-escape-vector vector ", "))
|
|
(vector (concat "(" (mapconcat #'emacsql-escape-scalar vector ", ") ")"))
|
|
(otherwise (emacsql-error "Invalid vector %S" vector))))
|
|
|
|
(defun emacsql-escape-format (thing)
|
|
"Escape THING for use as a `format' spec."
|
|
(replace-regexp-in-string "%" "%%" thing))
|
|
|
|
;;; Schema compiler
|
|
|
|
(defvar emacsql-type-map
|
|
'((integer "&INTEGER")
|
|
(float "&REAL")
|
|
(object "&TEXT")
|
|
(nil "&NONE"))
|
|
"An alist mapping EmacSQL types to SQL types.")
|
|
|
|
(defun emacsql--from-keyword (keyword)
|
|
"Convert KEYWORD into SQL."
|
|
(let ((name (substring (symbol-name keyword) 1)))
|
|
(upcase (replace-regexp-in-string "-" " " name))))
|
|
|
|
(defun emacsql--prepare-constraints (constraints)
|
|
"Compile CONSTRAINTS into a partial SQL expression."
|
|
(mapconcat
|
|
#'identity
|
|
(cl-loop for constraint in constraints collect
|
|
(cl-typecase constraint
|
|
(null "NULL")
|
|
(keyword (emacsql--from-keyword constraint))
|
|
(symbol (emacsql-escape-identifier constraint))
|
|
(vector (format "(%s)"
|
|
(mapconcat
|
|
#'emacsql-escape-identifier
|
|
constraint
|
|
", ")))
|
|
(list (format "(%s)"
|
|
(car (emacsql--*expr constraint))))
|
|
(otherwise
|
|
(emacsql-escape-scalar constraint))))
|
|
" "))
|
|
|
|
(defun emacsql--prepare-column (column)
|
|
"Convert COLUMN into a partial SQL string."
|
|
(mapconcat
|
|
#'identity
|
|
(cl-etypecase column
|
|
(symbol (list (emacsql-escape-identifier column)
|
|
(cadr (assoc nil emacsql-type-map))))
|
|
(list (cl-destructuring-bind (name . constraints) column
|
|
(cl-delete-if
|
|
(lambda (s) (zerop (length s)))
|
|
(list (emacsql-escape-identifier name)
|
|
(if (member (car constraints) '(integer float object))
|
|
(cadr (assoc (pop constraints) emacsql-type-map))
|
|
(cadr (assoc nil emacsql-type-map)))
|
|
(emacsql--prepare-constraints constraints))))))
|
|
" "))
|
|
|
|
(defun emacsql-prepare-schema (schema)
|
|
"Compile SCHEMA into a SQL string."
|
|
(if (vectorp schema)
|
|
(emacsql-prepare-schema (list schema))
|
|
(cl-destructuring-bind (columns . constraints) schema
|
|
(mapconcat
|
|
#'identity
|
|
(nconc
|
|
(mapcar #'emacsql--prepare-column columns)
|
|
(mapcar #'emacsql--prepare-constraints constraints))
|
|
", "))))
|
|
|
|
;;; Statement compilation
|
|
|
|
(defvar emacsql-prepare-cache (make-hash-table :test 'equal :weakness 'key)
|
|
"Cache used to memoize `emacsql-prepare'.")
|
|
|
|
(defvar emacsql--vars ()
|
|
"Used within `emacsql-with-params' to collect parameters.")
|
|
|
|
(defun emacsql-sql-p (thing)
|
|
"Return non-nil if THING looks like a prepared statement."
|
|
(and (vectorp thing) (> (length thing) 0) (keywordp (aref thing 0))))
|
|
|
|
(defun emacsql-param (thing)
|
|
"Return the index and type of THING, or nil if THING is not a parameter.
|
|
A parameter is a symbol that looks like $i1, $s2, $v3, etc. The
|
|
letter refers to the type: identifier (i), scalar (s),
|
|
vector (v), raw string (r), schema (S)."
|
|
(and (symbolp thing)
|
|
(let ((name (symbol-name thing)))
|
|
(and (string-match-p "^\\$[isvrS][0-9]+$" name)
|
|
(cons (1- (read (substring name 2)))
|
|
(cl-ecase (aref name 1)
|
|
(?i :identifier)
|
|
(?s :scalar)
|
|
(?v :vector)
|
|
(?r :raw)
|
|
(?S :schema)))))))
|
|
|
|
(defmacro emacsql-with-params (prefix &rest body)
|
|
"Evaluate BODY, collecting parameters.
|
|
Provided local functions: `param', `identifier', `scalar', `raw',
|
|
`svector', `expr', `subsql', and `combine'. BODY should return a
|
|
string, which will be combined with variable definitions."
|
|
(declare (indent 1))
|
|
`(let ((emacsql--vars ()))
|
|
(cl-flet* ((combine (prepared) (emacsql--*combine prepared))
|
|
(param (thing) (emacsql--!param thing))
|
|
(identifier (thing) (emacsql--!param thing :identifier))
|
|
(scalar (thing) (emacsql--!param thing :scalar))
|
|
(raw (thing) (emacsql--!param thing :raw))
|
|
(svector (thing) (combine (emacsql--*vector thing)))
|
|
(expr (thing) (combine (emacsql--*expr thing)))
|
|
(subsql (thing)
|
|
(format "(%s)" (combine (emacsql-prepare thing)))))
|
|
(cons (concat ,prefix (progn ,@body)) emacsql--vars))))
|
|
|
|
(defun emacsql--!param (thing &optional kind)
|
|
"Parse, escape, and store THING.
|
|
If optional KIND is not specified, then try to guess it.
|
|
Only use within `emacsql-with-params'!"
|
|
(cl-flet ((check (param)
|
|
(when (and kind (not (eq kind (cdr param))))
|
|
(emacsql-error
|
|
"Invalid parameter type %s, expecting %s" thing kind))))
|
|
(let ((param (emacsql-param thing)))
|
|
(if (null param)
|
|
(emacsql-escape-format
|
|
(if kind
|
|
(cl-case kind
|
|
(:identifier (emacsql-escape-identifier thing))
|
|
(:scalar (emacsql-escape-scalar thing))
|
|
(:vector (emacsql-escape-vector thing))
|
|
(:raw (emacsql-escape-raw thing))
|
|
(:schema (emacsql-prepare-schema thing)))
|
|
(if (and (not (null thing))
|
|
(not (keywordp thing))
|
|
(symbolp thing))
|
|
(emacsql-escape-identifier thing)
|
|
(emacsql-escape-scalar thing))))
|
|
(prog1 (if (eq (cdr param) :schema) "(%s)" "%s")
|
|
(check param)
|
|
(setq emacsql--vars (nconc emacsql--vars (list param))))))))
|
|
|
|
(defun emacsql--*vector (vector)
|
|
"Prepare VECTOR."
|
|
(emacsql-with-params ""
|
|
(cl-typecase vector
|
|
(symbol (emacsql--!param vector :vector))
|
|
(list (mapconcat #'svector vector ", "))
|
|
(vector (format "(%s)" (mapconcat #'scalar vector ", ")))
|
|
(otherwise (emacsql-error "Invalid vector: %S" vector)))))
|
|
|
|
(defmacro emacsql--generate-op-lookup-defun (name operator-precedence-groups)
|
|
"Generate function to look up predefined SQL operator metadata.
|
|
|
|
The generated function is bound to NAME and accepts two
|
|
arguments, OPERATOR-NAME and OPERATOR-ARGUMENT-COUNT.
|
|
OPERATOR-PRECEDENCE-GROUPS should be a number of lists containing
|
|
operators grouped by operator precedence (in order of precedence
|
|
from highest to lowest). A single operator is represented by a
|
|
list of at least two elements: operator name (symbol) and
|
|
operator arity (:unary or :binary). Optionally a custom
|
|
expression can be included, which defines how the operator is
|
|
expanded into an SQL expression (there are two defaults, one for
|
|
:unary and one for :binary operators).
|
|
|
|
An example for OPERATOR-PRECEDENCE-GROUPS:
|
|
\(((+ :unary (\"+\" :operand)) (- :unary (\"-\" :operand)))
|
|
((+ :binary) (- :binary)))"
|
|
`(defun ,name (operator-name operator-argument-count)
|
|
"Look up predefined SQL operator metadata.
|
|
See `emacsql--generate-op-lookup-defun' for details."
|
|
(cond
|
|
,@(cl-loop
|
|
for precedence-value from 1
|
|
for precedence-group in (reverse operator-precedence-groups)
|
|
append (cl-loop
|
|
for (op-name arity custom-expr) in precedence-group
|
|
for sql-name = (upcase (symbol-name op-name))
|
|
for sql-expr =
|
|
(or custom-expr
|
|
(pcase arity
|
|
(:unary `(,sql-name " " :operand))
|
|
(:binary `(:operand " " ,sql-name " " :operand))))
|
|
|
|
collect (list `(and (eq operator-name
|
|
(quote ,op-name))
|
|
,(if (eq arity :unary)
|
|
`(eql operator-argument-count 1)
|
|
`(>= operator-argument-count 2)))
|
|
`(list ',sql-expr ,arity ,precedence-value))))
|
|
(t (list nil nil nil)))))
|
|
|
|
(emacsql--generate-op-lookup-defun
|
|
emacsql--get-op
|
|
(((~ :unary ("~" :operand)))
|
|
((collate :binary))
|
|
((|| :binary))
|
|
((* :binary) (/ :binary) (% :binary))
|
|
((+ :unary ("+" :operand)) (- :unary ("-" :operand)))
|
|
((+ :binary) (- :binary))
|
|
((& :binary) (| :binary) (<< :binary) (>> :binary))
|
|
((escape :binary (:operand " ESCAPE " :operand)))
|
|
((< :binary) (<= :binary) (> :binary) (>= :binary))
|
|
|
|
(;;TODO? (between :binary) (not-between :binary)
|
|
(is :binary) (is-not :binary (:operand " IS NOT " :operand))
|
|
(match :binary) (not-match :binary (:operand " NOT MATCH " :operand))
|
|
(like :binary) (not-like :binary (:operand " NOT LIKE " :operand))
|
|
(in :binary) (not-in :binary (:operand " NOT IN " :operand))
|
|
(isnull :unary (:operand " ISNULL"))
|
|
(notnull :unary (:operand " NOTNULL"))
|
|
(= :binary) (== :binary)
|
|
(!= :binary) (<> :binary)
|
|
(glob :binary) (not-glob :binary (:operand " NOT GLOB " :operand))
|
|
(regexp :binary) (not-regexp :binary (:operand " NOT REGEXP " :operand)))
|
|
|
|
((not :unary))
|
|
((and :binary))
|
|
((or :binary))))
|
|
|
|
(defun emacsql--expand-format-string (op expr arity argument-count)
|
|
"Create format-string for an SQL operator.
|
|
The format-string returned is intended to be used with `format'
|
|
to create an SQL expression."
|
|
(and expr
|
|
(cl-labels ((replace-operand (x) (if (eq x :operand) "%s" x))
|
|
(to-format-string (e) (mapconcat #'replace-operand e "")))
|
|
(cond
|
|
((and (eq arity :unary) (eql argument-count 1))
|
|
(to-format-string expr))
|
|
((and (eq arity :binary) (>= argument-count 2))
|
|
(let ((result (reverse expr)))
|
|
(dotimes (_ (- argument-count 2))
|
|
(setq result (nconc (reverse expr) (cdr result))))
|
|
(to-format-string (nreverse result))))
|
|
(t (emacsql-error "Wrong number of operands for %s" op))))))
|
|
|
|
(defun emacsql--get-op-info (op argument-count parent-precedence-value)
|
|
"Lookup SQL operator information for generating an SQL expression.
|
|
Returns the following multiple values when an operator can be
|
|
identified: a format string (see `emacsql--expand-format-string')
|
|
and a precedence value. If PARENT-PRECEDENCE-VALUE is greater or
|
|
equal to the identified operator's precedence, then the format
|
|
string returned is wrapped with parentheses."
|
|
(cl-destructuring-bind (format-string arity precedence-value)
|
|
(emacsql--get-op op argument-count)
|
|
(let ((expanded-format-string
|
|
(emacsql--expand-format-string
|
|
op
|
|
format-string
|
|
arity
|
|
argument-count)))
|
|
(cl-values (cond
|
|
((null format-string) nil)
|
|
((>= parent-precedence-value
|
|
precedence-value)
|
|
(format "(%s)" expanded-format-string))
|
|
(t expanded-format-string))
|
|
precedence-value))))
|
|
|
|
(defun emacsql--*expr (expr &optional parent-precedence-value)
|
|
"Expand EXPR recursively."
|
|
(emacsql-with-params ""
|
|
(cond
|
|
((emacsql-sql-p expr) (subsql expr))
|
|
((vectorp expr) (svector expr))
|
|
((atom expr) (param expr))
|
|
((cl-destructuring-bind (op . args) expr
|
|
(cl-multiple-value-bind (format-string precedence-value)
|
|
(emacsql--get-op-info op
|
|
(length args)
|
|
(or parent-precedence-value 0))
|
|
(cl-flet ((recur (n)
|
|
(combine (emacsql--*expr (nth n args)
|
|
(or precedence-value 0))))
|
|
(nops (op)
|
|
(emacsql-error "Wrong number of operands for %s" op)))
|
|
(cl-case op
|
|
;; Special cases <= >=
|
|
((<= >=)
|
|
(cl-case (length args)
|
|
(2 (format format-string (recur 0) (recur 1)))
|
|
(3 (format (if (>= (or parent-precedence-value 0)
|
|
precedence-value)
|
|
"(%s BETWEEN %s AND %s)"
|
|
"%s BETWEEN %s AND %s")
|
|
(recur 1)
|
|
(recur (if (eq op '>=) 2 0))
|
|
(recur (if (eq op '>=) 0 2))))
|
|
(otherwise (nops op))))
|
|
;; enforce second argument to be a character
|
|
((escape)
|
|
(let ((second-arg (cadr args)))
|
|
(cond
|
|
((not (= 2 (length args))) (nops op))
|
|
((not (characterp second-arg))
|
|
(emacsql-error
|
|
"Second operand of escape has to be a character, got %s"
|
|
second-arg))
|
|
(t (format format-string
|
|
(recur 0)
|
|
(emacsql-quote-character second-arg))))))
|
|
;; Ordering
|
|
((asc desc)
|
|
(format "%s %s" (recur 0) (upcase (symbol-name op))))
|
|
;; Special case quote
|
|
((quote) (let ((arg (nth 0 args)))
|
|
(if (stringp arg)
|
|
(raw arg)
|
|
(scalar arg))))
|
|
;; Special case funcall
|
|
((funcall)
|
|
(format "%s(%s)" (recur 0)
|
|
(cond
|
|
((and (= 2 (length args))
|
|
(eq '* (nth 1 args)))
|
|
"*")
|
|
((and (= 3 (length args))
|
|
(eq :distinct (nth 1 args))
|
|
(format "DISTINCT %s" (recur 2))))
|
|
((mapconcat
|
|
#'recur (cl-loop for i from 1 below (length args)
|
|
collect i)
|
|
", ")))))
|
|
;; Guess
|
|
(otherwise
|
|
(let ((arg-indices (cl-loop for i from 0 below (length args) collect i)))
|
|
(if format-string
|
|
(apply #'format format-string (mapcar #'recur arg-indices))
|
|
(mapconcat
|
|
#'recur (cl-loop for i from 0 below (length args) collect i)
|
|
(format " %s " (upcase (symbol-name op)))))))))))))))
|
|
|
|
(defun emacsql--*idents (idents)
|
|
"Read in a vector of IDENTS identifiers, or just an single identifier."
|
|
(emacsql-with-params ""
|
|
(mapconcat #'expr idents ", ")))
|
|
|
|
(defun emacsql--*combine (prepared)
|
|
"Append parameters from PREPARED to `emacsql--vars', return the string.
|
|
Only use within `emacsql-with-params'!"
|
|
(cl-destructuring-bind (string . vars) prepared
|
|
(setq emacsql--vars (nconc emacsql--vars vars))
|
|
string))
|
|
|
|
(defun emacsql-prepare--string (string)
|
|
"Create a prepared statement from STRING."
|
|
(emacsql-with-params ""
|
|
(replace-regexp-in-string
|
|
"\\$[isv][0-9]+" (lambda (v) (param (intern v))) string)))
|
|
|
|
(defun emacsql-prepare--sexp (sexp)
|
|
"Create a prepared statement from SEXP."
|
|
(emacsql-with-params ""
|
|
(cl-loop with items = (cl-coerce sexp 'list)
|
|
and last = nil
|
|
while (not (null items))
|
|
for item = (pop items)
|
|
collect
|
|
(cl-typecase item
|
|
(keyword (if (eq :values item)
|
|
(concat "VALUES " (svector (pop items)))
|
|
(emacsql--from-keyword item)))
|
|
(symbol (if (eq item '*)
|
|
"*"
|
|
(param item)))
|
|
(vector (if (emacsql-sql-p item)
|
|
(subsql item)
|
|
(let ((idents (combine
|
|
(emacsql--*idents item))))
|
|
(if (keywordp last)
|
|
idents
|
|
(format "(%s)" idents)))))
|
|
(list (if (vectorp (car item))
|
|
(emacsql-escape-format
|
|
(format "(%s)"
|
|
(emacsql-prepare-schema item)))
|
|
(combine (emacsql--*expr item))))
|
|
(otherwise
|
|
(emacsql-escape-format
|
|
(emacsql-escape-scalar item))))
|
|
into parts
|
|
do (setq last item)
|
|
finally (cl-return (string-join parts " ")))))
|
|
|
|
(defun emacsql-prepare (sql)
|
|
"Expand SQL (string or sexp) into a prepared statement."
|
|
(let* ((cache emacsql-prepare-cache)
|
|
(key (cons emacsql-type-map sql)))
|
|
(or (gethash key cache)
|
|
(setf (gethash key cache)
|
|
(if (stringp sql)
|
|
(emacsql-prepare--string sql)
|
|
(emacsql-prepare--sexp sql))))))
|
|
|
|
(defun emacsql-format (expansion &rest args)
|
|
"Fill in the variables EXPANSION with ARGS."
|
|
(cl-destructuring-bind (format . vars) expansion
|
|
(let ((print-level nil)
|
|
(print-length nil))
|
|
(apply #'format format
|
|
(cl-loop for (i . kind) in vars collect
|
|
(let ((thing (nth i args)))
|
|
(cl-case kind
|
|
(:identifier (emacsql-escape-identifier thing))
|
|
(:scalar (emacsql-escape-scalar thing))
|
|
(:vector (emacsql-escape-vector thing))
|
|
(:raw (emacsql-escape-raw thing))
|
|
(:schema (emacsql-prepare-schema thing))
|
|
(otherwise
|
|
(emacsql-error "Invalid var type %S" kind)))))))))
|
|
|
|
(provide 'emacsql-compiler)
|
|
|
|
;;; emacsql-compiler.el ends here
|