[Emacs-diffs] master c124d53: Correct implementation of `sql-set-product-feature' (Bug#30494).

[Michael Mauger]

branch: master
commit c124d5323c05a4010db9b2d330575d029936ade1
Author: Michael R. Mauger <address@hidden>
Commit: Michael R. Mauger <address@hidden>

    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 9bae3d8..2a42e7f 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 a68f931..7a11f76 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