Commit a1386fa6 authored by Michael R. Mauger's avatar Michael R. Mauger

* 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.
parent 2bf95739
Pipeline #1452 failed with stage
in 61 minutes and 22 seconds
......@@ -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))
......
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment