510 lines
18 KiB
EmacsLisp
510 lines
18 KiB
EmacsLisp
;;; 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
|