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.
......@@ -154,5 +156,119 @@ string of values passed to the comint function for validation."
(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