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

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
parent 4d91e646
Pipeline #829 failed with stage
in 50 minutes and 59 seconds
......@@ -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
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