mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
Correct implementation of `sql-set-product-feature' (Bug#30494).
* lisp.progmodes/sql.el (sql-add-product): Correct argument spec. (sql-set-product-feature): Handle all cases as intended. (sql-get-product-feature): Fetch varaiable value by `eval'. * test/lisp/progmodes/sql-tests.el (sql-test-feature-value-[a-d]): New test variables. (sql-test-product-feature-harness): New test macro. (sql-test-add-product, sql-test-add-existing-product) (sql-test-set-feature, sql-test-set-indirect-feature) (sql-test-set-existing-feature) (sql-test-set-existing-indirect-feature) (sql-test-set-missing-product, sql-test-get-feature) (sql-test-get-indirect-feature, sql-test-get-missing-product) (sql-test-get-missing-feature) (sql-test-get-missing-indirect-feature): New ERT tests
This commit is contained in:
Michael R. Mauger
parent
4d91e64698
commit
c124d5323c
2 changed files with 206 additions and 71 deletions
|
|
@ -2725,7 +2725,7 @@ highlighting rules in SQL mode.")
|
|||
nil 'require-match
|
||||
init 'sql-product-history init))))
|
||||
|
||||
(defun sql-add-product (product display &rest plist)
|
||||
(defun sql-add-product (product display &optional plist)
|
||||
"Add support for a database product in `sql-mode'.
|
||||
|
||||
Add PRODUCT to `sql-product-alist' which enables `sql-mode' to
|
||||
|
|
@ -2782,19 +2782,38 @@ list. See `sql-add-product' to add new products. The FEATURE
|
|||
argument must be a plist keyword accepted by
|
||||
`sql-product-alist'."
|
||||
|
||||
(let* ((p (assoc product sql-product-alist))
|
||||
(v (plist-get (cdr p) feature)))
|
||||
(if (and p v)
|
||||
(if (and
|
||||
(member feature sql-indirect-features)
|
||||
(symbolp v))
|
||||
(set v newvalue)
|
||||
(setcdr p (plist-put (cdr p) feature newvalue)))
|
||||
(progn
|
||||
(when (null p)
|
||||
(error "`%s' is not a known product; use `sql-add-product' to add it first." product))
|
||||
(when (null v)
|
||||
(error "`%s' is not a known feature for `%s'; use `sql-add-product' to add it first." feature product))))))
|
||||
(let* ((p (assoc product sql-product-alist)) ;; (PRODUCT :f v ...)
|
||||
(v (plist-member (cdr p) feature))) ;; (:FEATURE value ...) or null
|
||||
|
||||
(if p
|
||||
(if (member feature sql-indirect-features) ; is indirect
|
||||
(if v
|
||||
(if (car (cdr v))
|
||||
(if (symbolp (car (cdr v)))
|
||||
;; Indirect reference
|
||||
(set (car (cdr v)) newvalue)
|
||||
;; indirect is not a symbol
|
||||
(error "The value of `%s' for `%s' is not a symbol" feature product))
|
||||
;; keyword present, set the indirect variable name
|
||||
(if (symbolp newvalue)
|
||||
(if (cdr v)
|
||||
(setf (car (cdr v)) newvalue)
|
||||
(setf (cdr v) (list newvalue)))
|
||||
(error "The indirect variable of `%s' for `%s' must be a symbol" feature product)))
|
||||
;; not present; insert list
|
||||
(setq v (list feature newvalue))
|
||||
(setf (cdr (cdr v)) (cdr p))
|
||||
(setf (cdr p) v))
|
||||
;; Not an indirect feature
|
||||
(if v
|
||||
(if (cdr v)
|
||||
(setf (car (cdr v)) newvalue)
|
||||
(setf (cdr v) (list newvalue)))
|
||||
;; no value; insert into the list
|
||||
(setq v (list feature newvalue))
|
||||
(setf (cdr (cdr v)) (cdr p))
|
||||
(setf (cdr p) v)))
|
||||
(error "`%s' is not a known product; use `sql-add-product' to add it first" product))))
|
||||
|
||||
(defun sql-get-product-feature (product feature &optional fallback not-indirect)
|
||||
"Lookup FEATURE associated with a SQL PRODUCT.
|
||||
|
|
@ -2822,7 +2841,7 @@ See `sql-product-alist' for a list of products and supported features."
|
|||
(member feature sql-indirect-features)
|
||||
(not not-indirect)
|
||||
(symbolp v))
|
||||
(symbol-value v)
|
||||
(eval v)
|
||||
v))
|
||||
(error "`%s' is not a known product; use `sql-add-product' to add it first." product)
|
||||
nil)))
|
||||
|
|
|
|||
|
|
@ -53,6 +53,8 @@
|
|||
(error "some error"))))
|
||||
(should-not (sql-postgres-list-databases))))
|
||||
|
||||
;;; Check Connection Password Handling/Wallet
|
||||
|
||||
(defvar sql-test-login-params nil)
|
||||
(defmacro with-sql-test-connect-harness (id login-params connection expected)
|
||||
"Set-up and tear-down SQL connect related test.
|
||||
|
|
@ -62,40 +64,40 @@ LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED
|
|||
string of values passed to the comint function for validation."
|
||||
(declare (indent 2))
|
||||
`(cl-letf
|
||||
((sql-test-login-params ' ,login-params)
|
||||
((symbol-function 'sql-comint-test)
|
||||
(lambda (product options &optional buf-name)
|
||||
(with-current-buffer (get-buffer-create buf-name)
|
||||
(insert (pp-to-string (list product options sql-user sql-password sql-server sql-database))))))
|
||||
((symbol-function 'sql-run-test)
|
||||
(lambda (&optional buffer)
|
||||
(interactive "P")
|
||||
(sql-product-interactive 'sqltest buffer)))
|
||||
(sql-user nil)
|
||||
(sql-server nil)
|
||||
(sql-database nil)
|
||||
(sql-product-alist
|
||||
'((ansi)
|
||||
(sqltest
|
||||
:name "SqlTest"
|
||||
:sqli-login sql-test-login-params
|
||||
:sqli-comint-func sql-comint-test)))
|
||||
(sql-connection-alist
|
||||
'((,(format "test-%s" id)
|
||||
,@connection)))
|
||||
(sql-password-wallet
|
||||
(list
|
||||
(make-temp-file
|
||||
"sql-test-netrc" nil nil
|
||||
(mapconcat #'identity
|
||||
'("machine aMachine user aUserName password \"netrc-A aPassword\""
|
||||
"machine aServer user aUserName password \"netrc-B aPassword\""
|
||||
"machine aMachine server aServer user aUserName password \"netrc-C aPassword\""
|
||||
"machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\""
|
||||
"machine aDatabase user aUserName password \"netrc-E aPassword\""
|
||||
"machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\""
|
||||
"machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\""
|
||||
) "\n")))))
|
||||
((sql-test-login-params ' ,login-params)
|
||||
((symbol-function 'sql-comint-test)
|
||||
(lambda (product options &optional buf-name)
|
||||
(with-current-buffer (get-buffer-create buf-name)
|
||||
(insert (pp-to-string (list product options sql-user sql-password sql-server sql-database))))))
|
||||
((symbol-function 'sql-run-test)
|
||||
(lambda (&optional buffer)
|
||||
(interactive "P")
|
||||
(sql-product-interactive 'sqltest buffer)))
|
||||
(sql-user nil)
|
||||
(sql-server nil)
|
||||
(sql-database nil)
|
||||
(sql-product-alist
|
||||
'((ansi)
|
||||
(sqltest
|
||||
:name "SqlTest"
|
||||
:sqli-login sql-test-login-params
|
||||
:sqli-comint-func sql-comint-test)))
|
||||
(sql-connection-alist
|
||||
'((,(format "test-%s" id)
|
||||
,@connection)))
|
||||
(sql-password-wallet
|
||||
(list
|
||||
(make-temp-file
|
||||
"sql-test-netrc" nil nil
|
||||
(mapconcat #'identity
|
||||
'("machine aMachine user aUserName password \"netrc-A aPassword\""
|
||||
"machine aServer user aUserName password \"netrc-B aPassword\""
|
||||
"machine aMachine server aServer user aUserName password \"netrc-C aPassword\""
|
||||
"machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\""
|
||||
"machine aDatabase user aUserName password \"netrc-E aPassword\""
|
||||
"machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\""
|
||||
"machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\""
|
||||
) "\n")))))
|
||||
|
||||
(let* ((connection ,(format "test-%s" id))
|
||||
(buffername (format "*SQL: ERT TEST <%s>*" connection)))
|
||||
|
|
@ -106,53 +108,167 @@ string of values passed to the comint function for validation."
|
|||
(should (string-equal (with-current-buffer buffername (buffer-string)) ,expected))
|
||||
(when (get-buffer buffername)
|
||||
(kill-buffer buffername))
|
||||
(delete-file (car sql-password-wallet)))))
|
||||
(delete-file (car sql-password-wallet)))))
|
||||
|
||||
(ert-deftest sql-test-connect ()
|
||||
"Test of basic `sql-connect'."
|
||||
(with-sql-test-connect-harness 1 (user password server database)
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-password "test-1 aPassword")
|
||||
(sql-server "aServer")
|
||||
(sql-database "aDatabase"))
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-password "test-1 aPassword")
|
||||
(sql-server "aServer")
|
||||
(sql-database "aDatabase"))
|
||||
"(sqltest nil \"aUserName\" \"test-1 aPassword\" \"aServer\" \"aDatabase\")\n"))
|
||||
|
||||
(ert-deftest sql-test-connect-password-func ()
|
||||
"Test of password function."
|
||||
(with-sql-test-connect-harness 2 (user password server database)
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s
|
||||
?a ?P ?a ?s ?s ?w ?o ?r ?d])))
|
||||
(sql-server "aServer")
|
||||
(sql-database "aDatabase"))
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s
|
||||
?a ?P ?a ?s ?s ?w ?o ?r ?d])))
|
||||
(sql-server "aServer")
|
||||
(sql-database "aDatabase"))
|
||||
"(sqltest nil \"aUserName\" \"test-2 aPassword\" \"aServer\" \"aDatabase\")\n"))
|
||||
|
||||
(ert-deftest sql-test-connect-wallet-server-database ()
|
||||
"Test of password function."
|
||||
(with-sql-test-connect-harness 3 (user password server database)
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-server "aServer")
|
||||
(sql-database "aDatabase"))
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-server "aServer")
|
||||
(sql-database "aDatabase"))
|
||||
"(sqltest nil \"aUserName\" \"netrc-G aPassword\" \"aServer\" \"aDatabase\")\n"))
|
||||
|
||||
(ert-deftest sql-test-connect-wallet-database ()
|
||||
"Test of password function."
|
||||
(with-sql-test-connect-harness 4 (user password database)
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-database "aDatabase"))
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-database "aDatabase"))
|
||||
"(sqltest nil \"aUserName\" \"netrc-E aPassword\" nil \"aDatabase\")\n"))
|
||||
|
||||
(ert-deftest sql-test-connect-wallet-server ()
|
||||
"Test of password function."
|
||||
(with-sql-test-connect-harness 5 (user password server)
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-server "aServer"))
|
||||
((sql-product 'sqltest)
|
||||
(sql-user "aUserName")
|
||||
(sql-server "aServer"))
|
||||
"(sqltest nil \"aUserName\" \"netrc-B aPassword\" \"aServer\" nil)\n"))
|
||||
|
||||
;;; Set/Get Product Features
|
||||
|
||||
(defvar sql-test-feature-value-a nil "Indirect value A.")
|
||||
(defvar sql-test-feature-value-b nil "Indirect value B.")
|
||||
(defvar sql-test-feature-value-c nil "Indirect value C.")
|
||||
(defvar sql-test-feature-value-d nil "Indirect value D.")
|
||||
(defmacro sql-test-product-feature-harness (&rest action)
|
||||
"Set-up and tear-down of testing product/feature API.
|
||||
|
||||
Perform ACTION and validate results"
|
||||
(declare (indent 2))
|
||||
`(cl-letf
|
||||
((sql-product-alist
|
||||
(list (list 'a :X 1 :Y 2 :Z 'sql-test-feature-value-a)
|
||||
(list 'b :X 3 :Z 'sql-test-feature-value-b)
|
||||
(list 'c :Y 6 :Z 'sql-test-feature-value-c)
|
||||
(list 'd :X 7 :Y 8 )))
|
||||
(sql-indirect-features '(:Z :W))
|
||||
(sql-test-feature-value-a "original A")
|
||||
(sql-test-feature-value-b "original B")
|
||||
(sql-test-feature-value-c "original C")
|
||||
(sql-test-feature-value-d "original D"))
|
||||
,@action))
|
||||
|
||||
(ert-deftest sql-test-add-product ()
|
||||
"Add a product"
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(sql-add-product 'xyz "XyzDb")
|
||||
|
||||
(should (equal (pp-to-string (assoc 'xyz sql-product-alist))
|
||||
"(xyz :name \"XyzDb\")\n"))))
|
||||
|
||||
(ert-deftest sql-test-add-existing-product ()
|
||||
"Add a product that already exists."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should-error (sql-add-feature 'a "Aaa"))
|
||||
(should (equal (pp-to-string (assoc 'a sql-product-alist))
|
||||
"(a :X 1 :Y 2 :Z sql-test-feature-value-a)\n"))))
|
||||
|
||||
(ert-deftest sql-test-set-feature ()
|
||||
"Add a feature"
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(sql-set-product-feature 'b :Y 4)
|
||||
(should (equal (pp-to-string (assoc 'b sql-product-alist))
|
||||
"(b :Y 4 :X 3 :Z sql-test-feature-value-b)\n"))))
|
||||
|
||||
(ert-deftest sql-test-set-indirect-feature ()
|
||||
"Set a new indirect feature"
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(sql-set-product-feature 'd :Z 'sql-test-feature-value-d)
|
||||
(should (equal (pp-to-string (assoc 'd sql-product-alist))
|
||||
"(d :Z sql-test-feature-value-d :X 7 :Y 8)\n"))))
|
||||
|
||||
(ert-deftest sql-test-set-existing-feature ()
|
||||
"Set an existing feature."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(sql-set-product-feature 'b :X 33)
|
||||
(should (equal (pp-to-string (assoc 'b sql-product-alist))
|
||||
"(b :X 33 :Z sql-test-feature-value-b)\n"))))
|
||||
|
||||
(ert-deftest sql-test-set-existing-indirect-feature ()
|
||||
"Set an existing indirect feature."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should (equal sql-test-feature-value-b "original B"))
|
||||
(sql-set-product-feature 'b :Z "Hurray!")
|
||||
(should (equal (pp-to-string (assoc 'b sql-product-alist))
|
||||
"(b :X 3 :Z sql-test-feature-value-b)\n")) ;; unchanged
|
||||
(should (equal sql-test-feature-value-b "Hurray!"))))
|
||||
|
||||
(ert-deftest sql-test-set-missing-product ()
|
||||
"Add a feature to a missing product."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should-error (sql-set-product-feature 'x :Y 4))
|
||||
(should-not (assoc 'x sql-product-alist))))
|
||||
|
||||
(ert-deftest sql-test-get-feature ()
|
||||
"Get a feature value."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should (equal (sql-get-product-feature 'c :Y) 6))))
|
||||
|
||||
(ert-deftest sql-test-get-indirect-feature ()
|
||||
"Get a feature indirect value."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should (equal (sql-get-product-feature 'c :Z nil t) 'sql-test-feature-value-c))
|
||||
(should (equal sql-test-feature-value-c "original C"))
|
||||
(should (equal (sql-get-product-feature 'c :Z) "original C"))))
|
||||
|
||||
(ert-deftest sql-test-get-missing-product ()
|
||||
"Get a feature value from a missing product."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should-error (sql-get-product-feature 'x :Y))))
|
||||
|
||||
(ert-deftest sql-test-get-missing-feature ()
|
||||
"Get a missing feature value."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should-not (sql-get-product-feature 'c :X))))
|
||||
|
||||
(ert-deftest sql-test-get-missing-indirect-feature ()
|
||||
"Get a missing indirect feature value."
|
||||
|
||||
(sql-test-product-feature-harness
|
||||
(should-not (sql-get-product-feature 'd :Z))))
|
||||
|
||||
(provide 'sql-tests)
|
||||
;;; sql-tests.el ends here
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue