emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[nongnu] elpa/emacsql 3229cd41af 180/427: Change the requirements for fr


From: ELPA Syncer
Subject: [nongnu] elpa/emacsql 3229cd41af 180/427: Change the requirements for front-end implementations.
Date: Tue, 13 Dec 2022 02:59:40 -0500 (EST)

branch: elpa/emacsql
commit 3229cd41afd28d276326919b067900b2473c02ec
Author: Christopher Wellons <wellons@nullprogram.com>
Commit: Christopher Wellons <wellons@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 <wellons@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*"



reply via email to

[Prev in Thread] Current Thread [Next in Thread]