;;; 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