emacsql-compiler.el (15796B)
1 ;;; emacsql-compile.el --- s-expression SQL compiler -*- lexical-binding: t; -*- 2 3 ;;; Code: 4 5 (require 'cl-lib) 6 7 ;;; Error symbols 8 9 (defmacro emacsql-deferror (symbol parents message) 10 "Defines a new error symbol for EmacSQL." 11 (declare (indent 2)) 12 (let ((conditions (cl-remove-duplicates 13 (append parents (list symbol 'emacsql-error 'error))))) 14 `(prog1 ',symbol 15 (setf (get ',symbol 'error-conditions) ',conditions 16 (get ',symbol 'error-message) ,message)))) 17 18 (emacsql-deferror emacsql-error () ;; parent condition for all others 19 "EmacSQL had an unhandled condition") 20 21 (emacsql-deferror emacsql-syntax () "Invalid SQL statement") 22 (emacsql-deferror emacsql-internal () "Internal error") 23 (emacsql-deferror emacsql-locked () "Database locked") 24 (emacsql-deferror emacsql-fatal () "Fatal error") 25 (emacsql-deferror emacsql-memory () "Out of memory") 26 (emacsql-deferror emacsql-corruption () "Database corrupted") 27 (emacsql-deferror emacsql-access () "Database access error") 28 (emacsql-deferror emacsql-timeout () "Query timeout error") 29 (emacsql-deferror emacsql-warning () "Warning message") 30 31 (defun emacsql-error (format &rest args) 32 "Like `error', but signal an emacsql-syntax condition." 33 (signal 'emacsql-syntax (list (apply #'format format args)))) 34 35 ;;; Escaping functions 36 37 (defvar emacsql-reserved (make-hash-table :test 'equal) 38 "Collection of all known reserved words, used for escaping.") 39 40 (defun emacsql-register-reserved (seq) 41 "Register sequence of keywords as reserved words, returning SEQ." 42 (cl-loop for word being the elements of seq 43 do (setf (gethash (upcase (format "%s" word)) emacsql-reserved) t) 44 finally (cl-return seq))) 45 46 (defun emacsql-reserved-p (name) 47 "Returns non-nil if string NAME is a SQL keyword." 48 (gethash (upcase name) emacsql-reserved)) 49 50 (defun emacsql-quote-scalar (string) 51 "Single-quote (scalar) STRING for use in a SQL expression." 52 (with-temp-buffer 53 (insert string) 54 (setf (point) (point-min)) 55 (while (re-search-forward "'" nil t) 56 (replace-match "''")) 57 (setf (point) (point-min)) 58 (insert "'") 59 (setf (point) (point-max)) 60 (insert "'") 61 (buffer-string))) 62 63 (defun emacsql-quote-identifier (string) 64 "Double-quote (identifier) STRING for use in a SQL expression." 65 (format "\"%s\"" (replace-regexp-in-string "\"" "\"\"" string))) 66 67 (defun emacsql-escape-identifier (identifier) 68 "Escape an identifier, if needed, for SQL." 69 (when (or (null identifier) 70 (keywordp identifier) 71 (not (or (symbolp identifier) 72 (vectorp identifier)))) 73 (emacsql-error "Invalid identifier: %S" identifier)) 74 (cond 75 ((vectorp identifier) 76 (mapconcat #'emacsql-escape-identifier identifier ", ")) 77 ((eq identifier '*) "*") 78 (t 79 (let ((name (symbol-name identifier))) 80 (if (string-match-p ":" name) 81 (mapconcat #'emacsql-escape-identifier 82 (mapcar #'intern (split-string name ":")) ".") 83 (let ((print (replace-regexp-in-string "-" "_" (format "%S" identifier))) 84 (special "[]-\000-\040!\"#%&'()*+,./:;<=>?@[\\^`{|}~\177]")) 85 (if (or (string-match-p special print) 86 (string-match-p "^[0-9$]" print) 87 (emacsql-reserved-p print)) 88 (emacsql-quote-identifier print) 89 print))))))) 90 91 (defun emacsql-escape-scalar (value) 92 "Escape VALUE for sending to SQLite." 93 (let ((print-escape-newlines t) 94 (print-escape-control-characters t)) 95 (cond ((null value) "NULL") 96 ((numberp value) (prin1-to-string value)) 97 ((emacsql-quote-scalar (prin1-to-string value)))))) 98 99 (defun emacsql-escape-raw (value) 100 "Escape VALUE for sending to SQLite." 101 (cond ((null value) "NULL") 102 ((stringp value) (emacsql-quote-scalar value)) 103 ((error "Expected string or nil")))) 104 105 (defun emacsql-escape-vector (vector) 106 "Encode VECTOR into a SQL vector scalar." 107 (cl-typecase vector 108 (null (emacsql-error "Empty SQL vector expression.")) 109 (list (mapconcat #'emacsql-escape-vector vector ", ")) 110 (vector (concat "(" (mapconcat #'emacsql-escape-scalar vector ", ") ")")) 111 (otherwise (emacsql-error "Invalid vector %S" vector)))) 112 113 (defun emacsql-escape-format (thing) 114 "Escape THING for use as a `format' spec." 115 (replace-regexp-in-string "%" "%%" thing)) 116 117 ;;; Schema compiler 118 119 (defvar emacsql-type-map 120 '((integer "&INTEGER") 121 (float "&REAL") 122 (object "&TEXT") 123 (nil "&NONE")) 124 "An alist mapping EmacSQL types to SQL types.") 125 126 (defun emacsql--from-keyword (keyword) 127 "Convert KEYWORD into SQL." 128 (let ((name (substring (symbol-name keyword) 1))) 129 (upcase (replace-regexp-in-string "-" " " name)))) 130 131 (defun emacsql--prepare-constraints (constraints) 132 "Compile CONSTRAINTS into a partial SQL expresson." 133 (mapconcat 134 #'identity 135 (cl-loop for constraint in constraints collect 136 (cl-typecase constraint 137 (null "NULL") 138 (keyword (emacsql--from-keyword constraint)) 139 (symbol (emacsql-escape-identifier constraint)) 140 (vector (format "(%s)" 141 (mapconcat 142 #'emacsql-escape-identifier 143 constraint 144 ", "))) 145 (list (format "(%s)" 146 (car (emacsql--*expr constraint)))) 147 (otherwise 148 (emacsql-escape-scalar constraint)))) 149 " ")) 150 151 (defun emacsql--prepare-column (column) 152 "Convert COLUMN into a partial SQL string." 153 (mapconcat 154 #'identity 155 (cl-etypecase column 156 (symbol (list (emacsql-escape-identifier column) 157 (cadr (assoc nil emacsql-type-map)))) 158 (list (cl-destructuring-bind (name . constraints) column 159 (cl-delete-if 160 (lambda (s) (zerop (length s))) 161 (list (emacsql-escape-identifier name) 162 (if (member (car constraints) '(integer float object)) 163 (cadr (assoc (pop constraints) emacsql-type-map)) 164 (cadr (assoc nil emacsql-type-map))) 165 (emacsql--prepare-constraints constraints)))))) 166 " ")) 167 168 (defun emacsql-prepare-schema (schema) 169 "Compile SCHEMA into a SQL string." 170 (if (vectorp schema) 171 (emacsql-prepare-schema (list schema)) 172 (cl-destructuring-bind (columns . constraints) schema 173 (mapconcat 174 #'identity 175 (nconc 176 (mapcar #'emacsql--prepare-column columns) 177 (mapcar #'emacsql--prepare-constraints constraints)) 178 ", ")))) 179 180 ;;; Statement compilation 181 182 (defvar emacsql-prepare-cache (make-hash-table :test 'equal :weakness 'key) 183 "Cache used to memoize `emacsql-prepare'.") 184 185 (defvar emacsql--vars () 186 "Used within `emacsql-with-params' to collect parameters.") 187 188 (defun emacsql-sql-p (thing) 189 "Return non-nil if THING looks like a prepared statement." 190 (and (vectorp thing) (> (length thing) 0) (keywordp (aref thing 0)))) 191 192 (defun emacsql-param (thing) 193 "Return the index and type of THING, or nil if THING is not a parameter. 194 A parameter is a symbol that looks like $i1, $s2, $v3, etc. The 195 letter refers to the type: identifier (i), scalar (s), 196 vector (v), raw string (r), schema (S)." 197 (when (symbolp thing) 198 (let ((name (symbol-name thing))) 199 (when (string-match-p "^\\$[isvrS][0-9]+$" name) 200 (cons (1- (read (substring name 2))) 201 (cl-ecase (aref name 1) 202 (?i :identifier) 203 (?s :scalar) 204 (?v :vector) 205 (?r :raw) 206 (?S :schema))))))) 207 208 (defmacro emacsql-with-params (prefix &rest body) 209 "Evaluate BODY, collecting parameters. 210 Provided local functions: `param', `identifier', `scalar', `raw', 211 `svector', `expr', `subsql', and `combine'. BODY should return a 212 string, which will be combined with variable definitions." 213 (declare (indent 1)) 214 `(let ((emacsql--vars ())) 215 (cl-flet* ((combine (prepared) (emacsql--*combine prepared)) 216 (param (thing) (emacsql--!param thing)) 217 (identifier (thing) (emacsql--!param thing :identifier)) 218 (scalar (thing) (emacsql--!param thing :scalar)) 219 (raw (thing) (emacsql--!param thing :raw)) 220 (svector (thing) (combine (emacsql--*vector thing))) 221 (expr (thing) (combine (emacsql--*expr thing))) 222 (subsql (thing) 223 (format "(%s)" (combine (emacsql-prepare thing))))) 224 (cons (concat ,prefix (progn ,@body)) emacsql--vars)))) 225 226 (defun emacsql--!param (thing &optional kind) 227 "Parse, escape, and store THING. 228 If optional KIND is not specified, then try to guess it. 229 Only use within `emacsql-with-params'!" 230 (cl-flet ((check (param) 231 (when (and kind (not (eq kind (cdr param)))) 232 (emacsql-error 233 "Invalid parameter type %s, expecting %s" thing kind)))) 234 (let ((param (emacsql-param thing))) 235 (if (null param) 236 (emacsql-escape-format 237 (if kind 238 (cl-case kind 239 (:identifier (emacsql-escape-identifier thing)) 240 (:scalar (emacsql-escape-scalar thing)) 241 (:vector (emacsql-escape-vector thing)) 242 (:raw (emacsql-escape-raw thing)) 243 (:schema (emacsql-prepare-schema thing))) 244 (if (and (not (null thing)) 245 (not (keywordp thing)) 246 (symbolp thing)) 247 (emacsql-escape-identifier thing) 248 (emacsql-escape-scalar thing)))) 249 (prog1 (if (eq (cdr param) :schema) "(%s)" "%s") 250 (check param) 251 (setf emacsql--vars (nconc emacsql--vars (list param)))))))) 252 253 (defun emacsql--*vector (vector) 254 "Prepare VECTOR." 255 (emacsql-with-params "" 256 (cl-typecase vector 257 (symbol (emacsql--!param vector :vector)) 258 (list (mapconcat #'svector vector ", ")) 259 (vector (format "(%s)" (mapconcat #'scalar vector ", "))) 260 (otherwise (emacsql-error "Invalid vector: %S" vector))))) 261 262 (defun emacsql--*expr (expr) 263 "Expand EXPR recursively." 264 (emacsql-with-params "" 265 (cond 266 ((emacsql-sql-p expr) (subsql expr)) 267 ((vectorp expr) (svector expr)) 268 ((atom expr) (param expr)) 269 ((cl-destructuring-bind (op . args) expr 270 (cl-flet ((recur (n) (combine (emacsql--*expr (nth n args)))) 271 (nops (op) 272 (emacsql-error "Wrong number of operands for %s" op))) 273 (cl-case op 274 ;; Special cases <= >= 275 ((<= >=) 276 (cl-case (length args) 277 (2 (format "%s %s %s" (recur 0) op (recur 1))) 278 (3 (format "%s BETWEEN %s AND %s" 279 (recur 1) 280 (recur (if (eq op '>=) 2 0)) 281 (recur (if (eq op '>=) 0 2)))) 282 (otherwise (nops op)))) 283 ;; Special case - 284 ((-) 285 (cl-case (length args) 286 (1 (format "-(%s)" (recur 0))) 287 (2 (format "%s - %s" (recur 0) (recur 1))) 288 (otherwise (nops op)))) 289 ;; Unary 290 ((not) 291 (format "NOT %s" (recur 0))) 292 ((notnull) 293 (format "%s NOTNULL" (recur 0))) 294 ((isnull) 295 (format "%s ISNULL" (recur 0))) 296 ;; Ordering 297 ((asc desc) 298 (format "%s %s" (recur 0) (upcase (symbol-name op)))) 299 ;; Special case quote 300 ((quote) (let ((arg (nth 0 args))) 301 (if (stringp arg) 302 (raw arg) 303 (scalar arg)))) 304 ;; Special case funcall 305 ((funcall) 306 (format "%s(%s)" (recur 0) 307 (cond 308 ((and (= 2 (length args)) 309 (eq '* (nth 1 args))) 310 "*") 311 ((and (= 3 (length args)) 312 (eq :distinct (nth 1 args)) 313 (format "DISTINCT %s" (recur 2)))) 314 ((mapconcat 315 #'recur (cl-loop for i from 1 below (length args) 316 collect i) 317 ", "))))) 318 ;; Guess 319 (otherwise 320 (mapconcat 321 #'recur (cl-loop for i from 0 below (length args) collect i) 322 (format " %s " (upcase (symbol-name op)))))))))))) 323 324 (defun emacsql--*idents (idents) 325 "Read in a vector of IDENTS identifiers, or just an single identifier." 326 (emacsql-with-params "" 327 (mapconcat #'expr idents ", "))) 328 329 (defun emacsql--*combine (prepared) 330 "Append parameters from PREPARED to `emacsql--vars', return the string. 331 Only use within `emacsql-with-params'!" 332 (cl-destructuring-bind (string . vars) prepared 333 (setf emacsql--vars (nconc emacsql--vars vars)) 334 string)) 335 336 (defun emacsql-prepare--string (string) 337 "Create a prepared statement from STRING." 338 (emacsql-with-params "" 339 (replace-regexp-in-string 340 "\\$[isv][0-9]+" (lambda (v) (param (intern v))) string))) 341 342 (defun emacsql-prepare--sexp (sexp) 343 "Create a prepared statement from SEXP." 344 (emacsql-with-params "" 345 (cl-loop with items = (cl-coerce sexp 'list) 346 and last = nil 347 while (not (null items)) 348 for item = (pop items) 349 collect 350 (cl-typecase item 351 (keyword (if (eq :values item) 352 (concat "VALUES " (svector (pop items))) 353 (emacsql--from-keyword item))) 354 (symbol (if (eq item '*) 355 "*" 356 (param item))) 357 (vector (if (emacsql-sql-p item) 358 (subsql item) 359 (let ((idents (combine 360 (emacsql--*idents item)))) 361 (if (keywordp last) 362 idents 363 (format "(%s)" idents))))) 364 (list (if (vectorp (car item)) 365 (emacsql-escape-format 366 (format "(%s)" 367 (emacsql-prepare-schema item))) 368 (combine (emacsql--*expr item)))) 369 (otherwise 370 (emacsql-escape-format 371 (emacsql-escape-scalar item)))) 372 into parts 373 do (setf last item) 374 finally (cl-return 375 (mapconcat #'identity parts " "))))) 376 377 (defun emacsql-prepare (sql) 378 "Expand SQL (string or sexp) into a prepared statement." 379 (let* ((cache emacsql-prepare-cache) 380 (key (cons emacsql-type-map sql))) 381 (or (gethash key cache) 382 (setf (gethash key cache) 383 (if (stringp sql) 384 (emacsql-prepare--string sql) 385 (emacsql-prepare--sexp sql)))))) 386 387 (defun emacsql-format (expansion &rest args) 388 "Fill in the variables EXPANSION with ARGS." 389 (cl-destructuring-bind (format . vars) expansion 390 (apply #'format format 391 (cl-loop for (i . kind) in vars collect 392 (let ((thing (nth i args))) 393 (cl-case kind 394 (:identifier (emacsql-escape-identifier thing)) 395 (:scalar (emacsql-escape-scalar thing)) 396 (:vector (emacsql-escape-vector thing)) 397 (:raw (emacsql-escape-raw thing)) 398 (:schema (emacsql-prepare-schema thing)) 399 (otherwise 400 (emacsql-error "Invalid var type %S" kind)))))))) 401 402 (provide 'emacsql-compiler) 403 404 ;;; emacsql-compile.el ends here