From a1386fa6a7698c04902354cd5fefb39056b0a901 Mon Sep 17 00:00:00 2001 From: "Michael R. Mauger" Date: Wed, 24 Apr 2019 20:59:25 -0400 Subject: [PATCH] * lisp/progmodes/sql.el (sql-is-sqli-buffer-p): New function. (sql-generate-unique-sqli-buffer-name): Refactor and use it. (sql-product-interactive): Simplify name logic. * test/lisp/progmodes/sql-tests.el (sql-tests-placeholder-filter-harness): New macro. (sql-tests-placeholder-filter-simple) (sql-tests-placeholder-filter-ampersand) (sql-tests-placeholder-filter-period): Refactored tests and use macro. (sql-tests-buffer-naming-harness): New macro. (sql-tests-buffer-naming-default) (sql-tests-buffer-naming-multiple) (sql-tests-buffer-naming-explicit) (sql-tests-buffer-naming-universal-argument) (sql-tests-buffer-naming-existing): New tests. --- lisp/progmodes/sql.el | 46 ++++++--- test/lisp/progmodes/sql-tests.el | 167 +++++++++++++++++++++++++------ 2 files changed, 166 insertions(+), 47 deletions(-) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 28261ef74b2..2d33b3130cd 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -1423,6 +1423,15 @@ specified, it's `sql-product' or `sql-connection' must match." (and (stringp connection) (string= connection sql-connection)))))))) +(defun sql-is-sqli-buffer-p (buffer) + "Return non-nil if buffer is a SQLi buffer." + (when buffer + (setq buffer (get-buffer buffer)) + (and buffer + (buffer-live-p buffer) + (with-current-buffer buffer + (derived-mode-p 'sql-interactive-mode))))) + ;; Keymap for sql-interactive-mode. (defvar sql-interactive-mode-map @@ -3550,24 +3559,29 @@ server/database name." "Generate a new, unique buffer name for a SQLi buffer. Append a sequence number until a unique name is found." - (let ((base-name (when (stringp base) - (substring-no-properties - (or base - (sql-get-product-feature product :name) + (let ((base-name (substring-no-properties + (if base + (if (stringp base) + base + (format "%S" base)) + (or (sql-get-product-feature product :name) (symbol-name product))))) - buf-fmt-1st buf-fmt-rest) + buf-fmt-1st + buf-fmt-rest) ;; Calculate buffer format - (if base-name - (setq buf-fmt-1st (format "*SQL: %s*" base-name) - buf-fmt-rest (format "*SQL: %s-%%d*" base-name)) - (setq buf-fmt-1st "*SQL*" - buf-fmt-rest "*SQL-%d*")) + (if (string-blank-p base-name) + (setq buf-fmt-1st "*SQL*" + buf-fmt-rest "*SQL-%d*") + (setq buf-fmt-1st (format "*SQL: %s*" base-name) + buf-fmt-rest (format "*SQL: %s-%%d*" base-name))) ;; See if we can find an unused buffer (let ((buf-name buf-fmt-1st) (i 1)) - (while (sql-buffer-live-p buf-name) + (while (if (sql-is-sqli-buffer-p buf-name) + (comint-check-proc buf-name) + (buffer-live-p (get-buffer buf-name))) ;; Check a sequence number on the BASE (setq buf-name (format buf-fmt-rest i) i (1+ i))) @@ -4670,13 +4684,13 @@ the call to \\[sql-product-interactive] with (read-string "Buffer name (\"*SQL: XXX*\"; enter `XXX'): " (sql-make-alternate-buffer-name product)))) - ((or (string-prefix-p " " new-name) - (string-match-p "\\`[*].*[*]\\'" new-name)) - new-name) ((stringp new-name) - (sql-generate-unique-sqli-buffer-name product new-name)) + (if (or (string-prefix-p " " new-name) + (string-match-p "\\`[*].*[*]\\'" new-name)) + new-name + (sql-generate-unique-sqli-buffer-name product new-name))) (t - (sql-generate-unique-sqli-buffer-name product nil))))) + (sql-generate-unique-sqli-buffer-name product new-name))))) ;; Set SQLi mode. (let ((sql-interactive-product product)) diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 5ac34907c2d..ad1f7976526 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -271,37 +271,142 @@ Perform ACTION and validate results" (should-not (sql-get-product-feature 'd :Z)))) ;;; SQL Oracle SCAN/DEFINE -(ert-deftest sql-tests-placeholder-filter () - "Test that placeholder relacement is as expected." - (let ((syntab (syntax-table)) - (sql-oracle-scan-on t) - (placeholder-value "")) - (set-syntax-table sql-mode-syntax-table) - - (cl-letf - (((symbol-function 'read-from-minibuffer) - (lambda (&rest _) placeholder-value))) - - (setq placeholder-value "XX") - (should (equal - (sql-placeholders-filter "select '&x' from dual;") - "select 'XX' from dual;")) - - (setq placeholder-value "&Y") - (should (equal - (sql-placeholders-filter "select '&x' from dual;") - "select '&Y' from dual;")) - (should (equal - (sql-placeholders-filter "select '&x' from dual;") - "select '&Y' from dual;")) - (should (equal - (sql-placeholders-filter "select '&x.' from dual;") - "select '&Y' from dual;")) - (should (equal - (sql-placeholders-filter "select '&x.y' from dual;") - "select '&Yy' from dual;"))) - - (set-syntax-table syntab))) +(defmacro sql-tests-placeholder-filter-harness (orig repl outp) + "Set-up and tear-down of testing of placeholder filter. + +The placeholder in ORIG will be replaced by REPL which should +yield OUTP." + + (declare (indent 0)) + `(let ((syntab (syntax-table)) + (sql-oracle-scan-on t)) + (set-syntax-table sql-mode-syntax-table) + + (cl-letf + (((symbol-function 'read-from-minibuffer) + (lambda (&rest _) ,repl))) + + (should (equal (sql-placeholders-filter ,orig) ,outp))) + + (set-syntax-table syntab))) + +(ert-deftest sql-tests-placeholder-filter-simple () + "Test that placeholder relacement of simple replacement text." + (sql-tests-placeholder-filter-harness + "select '&x' from dual;" "XX" + "select 'XX' from dual;")) + +(ert-deftest sql-tests-placeholder-filter-ampersand () + "Test that placeholder relacement of replacement text with ampersand." + (sql-tests-placeholder-filter-harness + "select '&x' from dual;" "&Y" + "select '&Y' from dual;") + + (sql-tests-placeholder-filter-harness + "select '&x' from dual;" "Y&" + "select 'Y&' from dual;") + + (sql-tests-placeholder-filter-harness + "select '&x' from dual;" "Y&Y" + "select 'Y&Y' from dual;")) + +(ert-deftest sql-tests-placeholder-filter-period () + "Test that placeholder relacement of token terminated by a period." + (sql-tests-placeholder-filter-harness + "select '&x.' from dual;" "&Y" + "select '&Y' from dual;") + + (sql-tests-placeholder-filter-harness + "select '&x.y' from dual;" "&Y" + "select '&Yy' from dual;") + + (sql-tests-placeholder-filter-harness + "select '&x..y' from dual;" "&Y" + "select '&Y.y' from dual;")) + +;; Buffer naming +(defmacro sql-tests-buffer-naming-harness (product &rest action) + "Set-up and tear-down of test of buffer naming. + +The ACTION will be tested after set-up of PRODUCT." + + (declare (indent 1)) + `(let (new-bufs) + (cl-letf + (((symbol-function 'make-comint-in-buffer) + (lambda (_name buffer _program &optional _startfile &rest _switches) + (let ((b (get-buffer-create buffer))) + (message ">>make-comint-in-buffer %S" b) + (cl-pushnew b new-bufs) ;; Keep track of what we create + b)))) + + (let (,(intern (format "sql-%s-login-params" product))) + ,@action) + + (let (kill-buffer-query-functions) ;; Kill what we create + (mapc #'kill-buffer new-bufs))))) + +(ert-deftest sql-tests-buffer-naming-default () + "Test buffer naming." + (sql-tests-buffer-naming-harness sqlite + (sql-sqlite) + (message ">> %S" (current-buffer)) + (should (equal (buffer-name) "*SQL: SQLite*")))) + +(ert-deftest sql-tests-buffer-naming-multiple () + "Test buffer naming of multiple buffers." + (sql-tests-buffer-naming-harness sqlite + (sql-sqlite) + (should (equal (buffer-name) "*SQL: SQLite*")) + + (switch-to-buffer "*scratch*") + + (sql-sqlite) + (should (equal (buffer-name) "*SQL: SQLite*")))) + +(ert-deftest sql-tests-buffer-naming-explicit () + "Test buffer naming with explicit name." + (sql-tests-buffer-naming-harness sqlite + (sql-sqlite "A") + (should (equal (buffer-name) "*SQL: A*")) + + (switch-to-buffer "*scratch*") + + (sql-sqlite "A") + (should (equal (buffer-name) "*SQL: A*")))) + +(ert-deftest sql-tests-buffer-naming-universal-argument () + "Test buffer naming with explicit name." + (sql-tests-buffer-naming-harness sqlite + (cl-letf + (((symbol-function 'read-string) + (lambda (_prompt &optional _initial-input _history _default-value _inherit-input-method) + "1"))) + (sql-sqlite '(4)) + (should (equal (buffer-name) "*SQL: 1*"))) + + (switch-to-buffer "*scratch*") + + (cl-letf + (((symbol-function 'read-string) + (lambda (_prompt &optional _initial-input _history _default-value _inherit-input-method) + "2"))) + (sql-sqlite '(16)) + (should (equal (buffer-name) "*SQL: 2*"))))) + +(ert-deftest sql-tests-buffer-naming-existing () + "Test buffer naming with an existing non-SQLi buffer." + (sql-tests-buffer-naming-harness sqlite + (get-buffer-create "*SQL: exist*") + + (cl-letf + (((symbol-function 'read-string) + (lambda (_prompt &optional _initial-input _history _default-value _inherit-input-method) + "exist"))) + (sql-sqlite '(4)) + (should (equal (buffer-name) "*SQL: exist-1*"))) + + (kill-buffer "*SQL: exist*"))) (provide 'sql-tests) -- 2.39.2