emacs/test/lisp/progmodes/sql-tests.el

;;; sql-tests.el --- Tests for sql.el  -*- lexical-binding: t; -*-

;; Copyright (C) 2016-2024 Free Software Foundation, Inc.

;; Author: Simen Heggestøyl <simenheg@gmail.com>
;; Keywords:

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;

;;; Code:

(require 'cl-lib)
(require 'ert)
(require 'ert-x)
(require 'sql)

(ert-deftest sql-tests-postgres-list-databases ()
  "Test that output from `psql -ltX' is parsed correctly."
  (cl-letf
      (((symbol-function 'executable-find)
        (lambda (_command) t))
       ((symbol-function 'process-lines)
        (lambda (_program &rest _args)
          '(" db-name-1 | foo-user | UTF8     | en_US.UTF-8 | en_US.UTF-8 | "
            " db_name_2 | foo-user | UTF8     | en_US.UTF-8 | en_US.UTF-8 | "
            ""))))
    (should (equal (sql-postgres-list-databases)
                   '("db-name-1" "db_name_2")))))

(ert-deftest sql-tests-postgres-list-databases-error ()
  "Test that nil is returned when `psql -ltX' fails."
  (cl-letf
      (((symbol-function 'executable-find)
        (lambda (_command) t))
       ((symbol-function 'process-lines)
        (lambda (_program &rest _args)
          (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.

Identify tests by ID.  Set :sql-login dialect attribute to
LOGIN-PARAMS.  Provide the CONNECTION parameters and the EXPECTED
string of values passed to the comint function for validation."
  (declare (indent 2))
  `(ert-with-temp-file tempfile
     :suffix "sql-test-netrc"
     :text (concat
            "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")
     (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 tempfile)))
       (let* ((connection ,(format "test-%s" id))
              (buffername (format "*SQL: ERT TEST <%s>*" connection)))
         (when (get-buffer buffername)
           (kill-buffer buffername))
         (sql-connect connection buffername)
         (should (get-buffer buffername))
         (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected))
         (when (get-buffer buffername)
           (kill-buffer buffername))))))

(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"))
    "(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"))
    "(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"))
    "(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"))
    "(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"))
    "(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")))

  (sql-test-product-feature-harness
      (sql-add-product 'stu "StuDb" :X 1 :Y "2")

      (should (equal (pp-to-string (assoc 'stu sql-product-alist))
                     "(stu :name \"StuDb\" :X 1 :Y \"2\")\n"))))

(ert-deftest sql-test-add-existing-product ()
  "Add a product that already exists."

  (sql-test-product-feature-harness
      (should-error (sql-add-product '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))))

;;; SQL Oracle SCAN/DEFINE
(defmacro sql-tests-placeholder-filter-harness (orig repl outp)
  "Set-up and tear-down of testing of placeholder filter.

The placeholder in ORIG will be replaced by REPL which should
yield OUTP."

  (declare (indent 0))
  `(let ((syntab (syntax-table))
         (sql-oracle-scan-on t))
     (set-syntax-table sql-mode-syntax-table)

     (cl-letf
         (((symbol-function 'read-from-minibuffer)
           (lambda (&rest _) ,repl)))

       (should (equal (sql-placeholders-filter ,orig) ,outp)))

     (set-syntax-table syntab)))

(ert-deftest sql-tests-placeholder-filter-simple ()
  "Test that placeholder relacement of simple replacement text."
  (sql-tests-placeholder-filter-harness
    "select '&x' from dual;" "XX"
    "select 'XX' from dual;"))

(ert-deftest sql-tests-placeholder-filter-ampersand ()
  "Test that placeholder relacement of replacement text with ampersand."
  (sql-tests-placeholder-filter-harness
    "select '&x' from dual;" "&Y"
    "select '&Y' from dual;")

  (sql-tests-placeholder-filter-harness
    "select '&x' from dual;" "Y&"
    "select 'Y&' from dual;")

  (sql-tests-placeholder-filter-harness
    "select '&x' from dual;" "Y&Y"
    "select 'Y&Y' from dual;"))

(ert-deftest sql-tests-placeholder-filter-period ()
  "Test that placeholder relacement of token terminated by a period."
  (sql-tests-placeholder-filter-harness
    "select '&x.' from dual;" "&Y"
    "select '&Y' from dual;")

  (sql-tests-placeholder-filter-harness
    "select '&x.y' from dual;" "&Y"
    "select '&Yy' from dual;")

  (sql-tests-placeholder-filter-harness
    "select '&x..y' from dual;" "&Y"
    "select '&Y.y' from dual;"))

;; Buffer naming
(defmacro sql-tests-buffer-naming-harness (product &rest action)
  "Set-up and tear-down of test of buffer naming.

The ACTION will be tested after set-up of PRODUCT."

  (declare (indent 1))
  `(progn
     (ert--skip-unless (executable-find sql-sqlite-program))
     (let (new-bufs)
       (cl-letf
           (((symbol-function 'make-comint-in-buffer)
             (lambda (_name buffer _program &optional _startfile &rest _switches)
               (let ((b (get-buffer-create buffer)))
                 (message ">>make-comint-in-buffer %S" b)
                 (cl-pushnew b new-bufs) ;; Keep track of what we create
                 b))))

         (let (,(intern (format "sql-%s-login-params" product)))
           ,@action)

         (let (kill-buffer-query-functions) ;; Kill what we create
           (mapc #'kill-buffer new-bufs))))))

(ert-deftest sql-tests-buffer-naming-default ()
  "Test buffer naming."
  (sql-tests-buffer-naming-harness sqlite
    (sql-sqlite)
    (message ">> %S" (current-buffer))
    (should (equal (buffer-name) "*SQL: SQLite*"))))

(ert-deftest sql-tests-buffer-naming-multiple ()
  "Test buffer naming of multiple buffers."
  (sql-tests-buffer-naming-harness sqlite
    (sql-sqlite)
    (should (equal (buffer-name) "*SQL: SQLite*"))

    (switch-to-buffer "*scratch*")

    (sql-sqlite)
    (should (equal (buffer-name) "*SQL: SQLite*"))))

(ert-deftest sql-tests-buffer-naming-explicit ()
  "Test buffer naming with explicit name."
  (sql-tests-buffer-naming-harness sqlite
    (sql-sqlite "A")
    (should (equal (buffer-name) "*SQL: A*"))

    (switch-to-buffer "*scratch*")

    (sql-sqlite "A")
    (should (equal (buffer-name) "*SQL: A*"))))

(ert-deftest sql-tests-buffer-naming-universal-argument ()
  "Test buffer naming with explicit name."
  (sql-tests-buffer-naming-harness sqlite
    (cl-letf
        (((symbol-function 'read-string)
          (lambda (_prompt &optional _initial-input _history _default-value _inherit-input-method)
            "1")))
      (sql-sqlite '(4))
      (should (equal (buffer-name) "*SQL: 1*")))

    (switch-to-buffer "*scratch*")

    (cl-letf
        (((symbol-function 'read-string)
          (lambda (_prompt &optional _initial-input _history _default-value _inherit-input-method)
            "2")))
      (sql-sqlite '(16))
      (should (equal (buffer-name) "*SQL: 2*")))))

(ert-deftest sql-tests-buffer-naming-existing ()
  "Test buffer naming with an existing non-SQLi buffer."
  (sql-tests-buffer-naming-harness sqlite
    (get-buffer-create "*SQL: exist*")

    (cl-letf
        (((symbol-function 'read-string)
          (lambda (_prompt &optional _initial-input _history _default-value _inherit-input-method)
            "exist")))
      (sql-sqlite '(4))
      (should (equal (buffer-name) "*SQL: exist-1*")))

    (kill-buffer "*SQL: exist*")))

(ert-deftest sql-tests-comint-automatic-password ()
  (let ((sql-password nil))
    (should-not (sql-comint-automatic-password "Password: ")))
  (let ((sql-password ""))
    (should-not (sql-comint-automatic-password "Password: ")))
  (let ((sql-password "password"))
    (should (equal "password" (sql-comint-automatic-password "Password: "))))
  ;; Also, we shouldn't care what the password is - we rely on comint for that.
  (let ((sql-password "password"))
    (should (equal "password" (sql-comint-automatic-password "")))))



;; Tests for sql-interactive-remove-continuation-prompt

(defmacro sql-tests-remove-cont-prompts-harness (&rest body)
  "Set-up and tear-down for tests of
`sql-interactive-remove-continuation-prompt'."
  (declare (indent 0))
  `(let ((comint-prompt-regexp "^ +\\.\\{3\\} ")
         (sql-output-newline-count nil)
         (sql-preoutput-hold nil))
     ,@body
     (should (null sql-output-newline-count))
     (should (null sql-preoutput-hold))))

(ert-deftest sql-tests-remove-cont-prompts-pass-through ()
  "Test that `sql-interactive-remove-continuation-prompt' just
passes the output line through when it doesn't expect prompts."
  (sql-tests-remove-cont-prompts-harness
   (should
    (equal " ... "
           (sql-interactive-remove-continuation-prompt
            " ... ")))))

(ert-deftest sql-tests-remove-cont-prompts-anchored-successive ()
  "Test that `sql-interactive-remove-continuation-prompt' is able
to delete multiple prompts (anchored to bol) even if they appear
in a single line, but not more than `sql-output-newline-count'."
  (sql-tests-remove-cont-prompts-harness
   (setq sql-output-newline-count 2)
   (should
    (equal
     ;; 2 of 3 prompts are deleted
     "some output ... more output...\n\
 ... \n\
output after prompt"
     (sql-interactive-remove-continuation-prompt
      "some output ... more output...\n\
 ...  ...  ... \n\
output after prompt")))))

(ert-deftest sql-tests-remove-cont-prompts-collect-chunked-output ()
  "Test that `sql-interactive-remove-continuation-prompt' properly
collects output when output arrives in chunks, with prompts
intermixed."
  (sql-tests-remove-cont-prompts-harness
   (setq sql-output-newline-count 2)

   ;; Part of first prompt gets held.  Complete line is passed
   ;; through.
   (should (equal "line1\n"
                  (sql-interactive-remove-continuation-prompt
                   "line1\n ..")))
   (should (equal " .." sql-preoutput-hold))
   (should (equal 2 sql-output-newline-count))

   ;; First prompt is complete - remove it.  Hold part of line2.
   (should (equal ""
                  (sql-interactive-remove-continuation-prompt ". li")))
   (should (equal "li" sql-preoutput-hold))
   (should (equal 1 sql-output-newline-count))

   ;; Remove second prompt.  Flush output & don't hold / process any
   ;; output further on.
   (should (equal "line2\nli"
                  (sql-interactive-remove-continuation-prompt "ne2\n ... li")))
   (should (null sql-preoutput-hold))
   (should (null sql-output-newline-count))
   (should (equal "line3\n ... "
                  (sql-interactive-remove-continuation-prompt "line3\n ... ")))))

(ert-deftest sql-tests-remove-cont-prompts-flush-held ()
  "Test that when we don't wait for prompts,
 `sql-interactive-remove-continuation-prompt' just 'flushes' held
 output, with no prompt processing."
  (sql-tests-remove-cont-prompts-harness
   (setq sql-preoutput-hold "line1\n ..")
   (should (equal "line1\n ... line2 .."
                  (sql-interactive-remove-continuation-prompt ". line2 ..")))))

(provide 'sql-tests)
;;; sql-tests.el ends here