* 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.

diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 28261ef74b2b42979ba494ace68b51effb3cf4b9..2d33b3130cd34720824f21f75f7ff19797a1feef 100644 (file)
--- 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 5ac34907c2d02b47a0fe1a68f7a1d95eb320fc5e..ad1f797652630f338233f6d78821f2b704f59420 100644 (file)
--- 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)