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.") ...@@ -2725,7 +2725,7 @@ highlighting rules in SQL mode.")
nil 'require-match nil 'require-match
init 'sql-product-history init)))) 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 support for a database product in `sql-mode'.
Add PRODUCT to `sql-product-alist' which enables `sql-mode' to 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 ...@@ -2782,19 +2782,38 @@ list. See `sql-add-product' to add new products. The FEATURE
argument must be a plist keyword accepted by argument must be a plist keyword accepted by
`sql-product-alist'." `sql-product-alist'."
(let* ((p (assoc product sql-product-alist)) (let* ((p (assoc product sql-product-alist)) ;; (PRODUCT :f v ...)
(v (plist-get (cdr p) feature))) (v (plist-member (cdr p) feature))) ;; (:FEATURE value ...) or null
(if (and p v)
(if (and (if p
(member feature sql-indirect-features) (if (member feature sql-indirect-features) ; is indirect
(symbolp v)) (if v
(set v newvalue) (if (car (cdr v))
(setcdr p (plist-put (cdr p) feature newvalue))) (if (symbolp (car (cdr v)))
(progn ;; Indirect reference
(when (null p) (set (car (cdr v)) newvalue)
(error "`%s' is not a known product; use `sql-add-product' to add it first." product)) ;; indirect is not a symbol
(when (null v) (error "The value of `%s' for `%s' is not a symbol" feature product))
(error "`%s' is not a known feature for `%s'; use `sql-add-product' to add it first." 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) (defun sql-get-product-feature (product feature &optional fallback not-indirect)
"Lookup FEATURE associated with a SQL PRODUCT. "Lookup FEATURE associated with a SQL PRODUCT.
...@@ -2822,7 +2841,7 @@ See `sql-product-alist' for a list of products and supported features." ...@@ -2822,7 +2841,7 @@ See `sql-product-alist' for a list of products and supported features."
(member feature sql-indirect-features) (member feature sql-indirect-features)
(not not-indirect) (not not-indirect)
(symbolp v)) (symbolp v))
(symbol-value v) (eval v)
v)) v))
(error "`%s' is not a known product; use `sql-add-product' to add it first." product) (error "`%s' is not a known product; use `sql-add-product' to add it first." product)
nil))) nil)))
......
...@@ -53,6 +53,8 @@ ...@@ -53,6 +53,8 @@
(error "some error")))) (error "some error"))))
(should-not (sql-postgres-list-databases)))) (should-not (sql-postgres-list-databases))))
;;; Check Connection Password Handling/Wallet
(defvar sql-test-login-params nil) (defvar sql-test-login-params nil)
(defmacro with-sql-test-connect-harness (id login-params connection expected) (defmacro with-sql-test-connect-harness (id login-params connection expected)
"Set-up and tear-down SQL connect related test. "Set-up and tear-down SQL connect related test.
...@@ -62,40 +64,40 @@ LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED ...@@ -62,40 +64,40 @@ LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED
string of values passed to the comint function for validation." string of values passed to the comint function for validation."
(declare (indent 2)) (declare (indent 2))
`(cl-letf `(cl-letf
((sql-test-login-params ' ,login-params) ((sql-test-login-params ' ,login-params)
((symbol-function 'sql-comint-test) ((symbol-function 'sql-comint-test)
(lambda (product options &optional buf-name) (lambda (product options &optional buf-name)
(with-current-buffer (get-buffer-create 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)))))) (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database))))))
((symbol-function 'sql-run-test) ((symbol-function 'sql-run-test)
(lambda (&optional buffer) (lambda (&optional buffer)
(interactive "P") (interactive "P")
(sql-product-interactive 'sqltest buffer))) (sql-product-interactive 'sqltest buffer)))
(sql-user nil) (sql-user nil)
(sql-server nil) (sql-server nil)
(sql-database nil) (sql-database nil)
(sql-product-alist (sql-product-alist
'((ansi) '((ansi)
(sqltest (sqltest
:name "SqlTest" :name "SqlTest"
:sqli-login sql-test-login-params :sqli-login sql-test-login-params
:sqli-comint-func sql-comint-test))) :sqli-comint-func sql-comint-test)))
(sql-connection-alist (sql-connection-alist
'((,(format "test-%s" id) '((,(format "test-%s" id)
,@connection))) ,@connection)))
(sql-password-wallet (sql-password-wallet
(list (list
(make-temp-file (make-temp-file
"sql-test-netrc" nil nil "sql-test-netrc" nil nil
(mapconcat #'identity (mapconcat #'identity
'("machine aMachine user aUserName password \"netrc-A aPassword\"" '("machine aMachine user aUserName password \"netrc-A aPassword\""
"machine aServer user aUserName password \"netrc-B aPassword\"" "machine aServer user aUserName password \"netrc-B aPassword\""
"machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" "machine aMachine server aServer user aUserName password \"netrc-C aPassword\""
"machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\""
"machine aDatabase user aUserName password \"netrc-E aPassword\"" "machine aDatabase user aUserName password \"netrc-E aPassword\""
"machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\""
"machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\""
) "\n"))))) ) "\n")))))
(let* ((connection ,(format "test-%s" id)) (let* ((connection ,(format "test-%s" id))
(buffername (format "*SQL: ERT TEST <%s>*" connection))) (buffername (format "*SQL: ERT TEST <%s>*" connection)))
...@@ -106,53 +108,167 @@ string of values passed to the comint function for validation." ...@@ -106,53 +108,167 @@ string of values passed to the comint function for validation."
(should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected))
(when (get-buffer buffername) (when (get-buffer buffername)
(kill-buffer buffername)) (kill-buffer buffername))
(delete-file (car sql-password-wallet))))) (delete-file (car sql-password-wallet)))))
(ert-deftest sql-test-connect () (ert-deftest sql-test-connect ()
"Test of basic `sql-connect'." "Test of basic `sql-connect'."
(with-sql-test-connect-harness 1 (user password server database) (with-sql-test-connect-harness 1 (user password server database)
((sql-product 'sqltest) ((sql-product 'sqltest)
(sql-user "aUserName") (sql-user "aUserName")
(sql-password "test-1 aPassword") (sql-password "test-1 aPassword")
(sql-server "aServer") (sql-server "aServer")
(sql-database "aDatabase")) (sql-database "aDatabase"))
"(sqltest nil \"aUserName\" \"test-1 aPassword\" \"aServer\" \"aDatabase\")\n")) "(sqltest nil \"aUserName\" \"test-1 aPassword\" \"aServer\" \"aDatabase\")\n"))
(ert-deftest sql-test-connect-password-func () (ert-deftest sql-test-connect-password-func ()
"Test of password function." "Test of password function."
(with-sql-test-connect-harness 2 (user password server database) (with-sql-test-connect-harness 2 (user password server database)
((sql-product 'sqltest) ((sql-product 'sqltest)
(sql-user "aUserName") (sql-user "aUserName")
(sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s (sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s
?a ?P ?a ?s ?s ?w ?o ?r ?d]))) ?a ?P ?a ?s ?s ?w ?o ?r ?d])))
(sql-server "aServer") (sql-server "aServer")
(sql-database "aDatabase")) (sql-database "aDatabase"))
"(sqltest nil \"aUserName\" \"test-2 aPassword\" \"aServer\" \"aDatabase\")\n")) "(sqltest nil \"aUserName\" \"test-2 aPassword\" \"aServer\" \"aDatabase\")\n"))
(ert-deftest sql-test-connect-wallet-server-database () (ert-deftest sql-test-connect-wallet-server-database ()
"Test of password function." "Test of password function."
(with-sql-test-connect-harness 3 (user password server database) (with-sql-test-connect-harness 3 (user password server database)
((sql-product 'sqltest) ((sql-product 'sqltest)
(sql-user "aUserName") (sql-user "aUserName")
(sql-server "aServer") (sql-server "aServer")
(sql-database "aDatabase")) (sql-database "aDatabase"))
"(sqltest nil \"aUserName\" \"netrc-G aPassword\" \"aServer\" \"aDatabase\")\n")) "(sqltest nil \"aUserName\" \"netrc-G aPassword\" \"aServer\" \"aDatabase\")\n"))
(ert-deftest sql-test-connect-wallet-database () (ert-deftest sql-test-connect-wallet-database ()
"Test of password function." "Test of password function."
(with-sql-test-connect-harness 4 (user password database) (with-sql-test-connect-harness 4 (user password database)
((sql-product 'sqltest) ((sql-product 'sqltest)
(sql-user "aUserName") (sql-user "aUserName")
(sql-database "aDatabase")) (sql-database "aDatabase"))
"(sqltest nil \"aUserName\" \"netrc-E aPassword\" nil \"aDatabase\")\n")) "(sqltest nil \"aUserName\" \"netrc-E aPassword\" nil \"aDatabase\")\n"))
(ert-deftest sql-test-connect-wallet-server () (ert-deftest sql-test-connect-wallet-server ()
"Test of password function." "Test of password function."
(with-sql-test-connect-harness 5 (user password server) (with-sql-test-connect-harness 5 (user password server)
((sql-product 'sqltest) ((sql-product 'sqltest)
(sql-user "aUserName") (sql-user "aUserName")
(sql-server "aServer")) (sql-server "aServer"))
"(sqltest nil \"aUserName\" \"netrc-B aPassword\" \"aServer\" nil)\n")) "(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) (provide 'sql-tests)
;;; sql-tests.el ends here ;;; 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