From c124d5323c05a4010db9b2d330575d029936ade1 Mon Sep 17 00:00:00 2001 From: "Michael R. Mauger" Date: Wed, 20 Feb 2019 22:13:51 -0500 Subject: [PATCH] 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 --- lisp/progmodes/sql.el | 49 +++++-- test/lisp/progmodes/sql-tests.el | 228 +++++++++++++++++++++++-------- 2 files changed, 206 insertions(+), 71 deletions(-) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 9bae3d86640..2a42e7f4515 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -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))) diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index a68f9319c2f..7a11f762eb0 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -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 -- 2.39.2