658 lines
30 KiB
EmacsLisp
658 lines
30 KiB
EmacsLisp
;;; xmtn-tests.el --- Automated regression tests for xmtn
|
|
|
|
;; Copyright (C) 2006, 2007 Christian M. Ohler
|
|
|
|
;; Author: Christian M. Ohler
|
|
|
|
;; This file 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 2 of the License, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This file 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 this file; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
|
|
;; Boston, MA 02110-1301 USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Automated regression tests for xmtn.
|
|
|
|
;;; Code:
|
|
|
|
;;; There are some notes on the design of xmtn in
|
|
;;; docs/xmtn-readme.txt.
|
|
|
|
;; These tests require elunit.el from
|
|
;; http://dev.technomancy.us/phil/wiki/ElUnit .
|
|
|
|
(eval-and-compile
|
|
(require 'cl)
|
|
(require 'elunit)
|
|
(require 'elp) ;; elp-elapsed-time is a 'defsubst', so we require elp at load time, not run time.
|
|
(require 'xmtn-match)
|
|
(require 'xmtn-dvc)
|
|
(require 'dvc-tests-utils "tests/dvc-tests-utils.el"))
|
|
|
|
(defun xmtn-tests--keypair-string ()
|
|
"[keypair xmtn-test]
|
|
MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDFE8/sRvdvN5+F5aFVpXeJpz0eKAzhYdWB
|
|
uW3L0C1tWnLk+HzYV13ewKMtFzwkoTeITTX5q372zH2XSIcUR2jBCArQf8Ru40886nLwG7zU
|
|
G1cI3B86akQknDUn3t9C1jEHXlBJiPLwaWrcmMFhoA+PnE49gopudw4q6Yhg1YCOqwIDAQAB#
|
|
MIICyTBDBgkqhkiG9w0BBQ0wNjAeBgkqhkiG9w0BBQwwEQQIccoCNMR2fIYCAggAAgEYMBQG
|
|
CCqGSIb3DQMHBAgjnJz0whELeQSCAoDEzuBbQf7hf43ULUZR7gFBrXilg+KBgItlA0Mz6jmI
|
|
0+LzoHhJiU3rnyR1MsXkf7uCBFje5Uqj53vUrnrBbxgGBFHwOw1Kic+lbDtvAKlNLPPPl9h8
|
|
W9QrQYhEg9VsmYBUvxZnyw5Kmafpmh1wC/fRSchDmWyhUeJHtkZhnUgcG9OFi6z8JT64/VGw
|
|
ZhB46Q2dGLrygjHRArA8FIOX5dlGzyRNfa0w5dVWZED7IcQVCoBLwLiEb9woK+fyEuK12fM+
|
|
23U8/sAO74MMOoyvs+OoloPtgniHuRdc/1RV9CS9k64mnzJdOnhR/GxQIL36LZcNrHvnM9Nn
|
|
xrK2yDkuk39JcLDJlFPZok7vluEn1GCKKGce3Z2LP6VPTJAqBHgt1fTMBAT5bc7rbVQxzVEU
|
|
56anNOMR1T9MRnbX5u5Hpj5mNIqbWX+g3YCIgKIJXbtD57GixPP4s/mP2EcAAeZvWiGeTF6Z
|
|
GyNq8USmlEjXpMrIWqLk+f6OzDyvk05sTQByRlKwOGzgbyNnWsetKC97wFfsBExNKhKeFFTV
|
|
6HOehUEPHIrikNaLed52czpqaKcQ67uVfdWXs3drwS7V0RRtTdcAzy0u95bERPrRpCY3tq/a
|
|
CGp3K4RF00eJQLBa94D9LYIEMBk4evfKCijcId0b4kzIQS1SI1sytnt+P1zPQaV5yAetOOD/
|
|
fuHfnYU27Mqis5V23xo1ibjDS1fa3/E6XK2P+Y3rHuyjQ/QbFlcBwj0vjv8yqwRWOe5y6Msd
|
|
f6S7jhNd76i/o3K/DmnpnI1N8RODAd77uejpe8K0xthzk2q02VtrBXA7jpY7oSaIaKJPov6v
|
|
YPFoLxe1V5oOyoe3ap0H
|
|
[end]")
|
|
|
|
(defun xmtn-tests--default-rc-file ()
|
|
;; Monotone versions up to and including 0.33 don't allow empty
|
|
;; passphrases.
|
|
"function get_passphrase(keypair_id) return \"a\" end")
|
|
|
|
;;; This is preferable over seperate set-up and tear-down functions
|
|
;;; since it allows us to make use of `unwind-protect' and dynamic
|
|
;;; bindings.
|
|
|
|
(defun xmtn-tests--call-with-test-environment (xmtn--body)
|
|
(lexical-let ((body xmtn--body))
|
|
(lexical-let ((temp-dir nil))
|
|
(unwind-protect
|
|
(progn
|
|
(setq temp-dir (file-name-as-directory
|
|
(xmtn--make-temp-file "xmtn-tests-" t)))
|
|
(lexical-let ((key-dir (concat temp-dir "keys/"))
|
|
(rc-file (concat temp-dir "rc")))
|
|
(let* ((default-directory temp-dir)
|
|
(dvc-test-mode t)
|
|
(xmtn-additional-arguments
|
|
`("--db" ,(concat temp-dir "a.mtn")
|
|
"--keydir" ,key-dir
|
|
"--norc"
|
|
"--rcfile" ,rc-file)))
|
|
(make-directory key-dir)
|
|
(with-temp-file (concat key-dir "xmtn-tests")
|
|
(insert (xmtn-tests--keypair-string) ?\n))
|
|
(with-temp-file rc-file
|
|
(insert (xmtn-tests--default-rc-file) ?\n))
|
|
(xmtn--run-command-sync nil '("db" "init"))
|
|
(xmtn--run-command-sync nil '("setup"
|
|
"--branch" "invalid.xmtn-tests"
|
|
"workspace"))
|
|
(let ((default-directory (concat temp-dir "workspace/")))
|
|
(funcall body
|
|
:root default-directory)))))
|
|
(when temp-dir
|
|
(dired-delete-file temp-dir 'always))))))
|
|
|
|
(defun xmtn-tests--call-with-test-history (xmtn--body)
|
|
(lexical-let ((body xmtn--body))
|
|
(xmtn-tests--call-with-test-environment
|
|
(function*
|
|
(lambda (&key ((:root xmtn--root)))
|
|
(lexical-let ((root xmtn--root)
|
|
(file-name "file-1")
|
|
revision-1
|
|
revision-2)
|
|
(with-temp-file file-name (insert "a\n"))
|
|
(xmtn--add-files root (list file-name))
|
|
(xmtn--run-command-sync root `("commit" "--message=commit 1"))
|
|
(setq revision-1 (xmtn--get-base-revision-hash-id root))
|
|
(with-temp-file file-name (insert "b\n"))
|
|
(xmtn--run-command-sync root `("commit" "--message=commit 2"))
|
|
(setq revision-2 (xmtn--get-base-revision-hash-id root))
|
|
(funcall body
|
|
:root root
|
|
:file-name file-name
|
|
:revision-1 revision-1
|
|
:revision-2 revision-2)))))))
|
|
|
|
(defmacro* xmtn-tests--with-test-environment ((&rest keys) &body body)
|
|
(declare (indent 1) (debug (sexp body)))
|
|
`(xmtn-tests--call-with-test-environment (function* (lambda (,@keys) ,@body))))
|
|
|
|
(defmacro* xmtn-tests--with-test-history ((&rest keys) &body body)
|
|
(declare (indent 1) (debug (sexp body)))
|
|
`(xmtn-tests--call-with-test-history (function* (lambda (,@keys) ,@body))))
|
|
|
|
|
|
(defsuite xmtn
|
|
(xmtn--match
|
|
(progn
|
|
(assert (xmtn-match--match-variable-p '$x ?$))
|
|
(assert (xmtn-match--match-variable-p '@x ?@))
|
|
(assert (not (xmtn-match--match-variable-p "$x" ?$)))
|
|
(assert (not (xmtn-match--match-variable-p 'x ?$)))
|
|
(assert (xmtn-match--contains-match-variable-p '$x ?$))
|
|
(assert (xmtn-match--contains-match-variable-p '(a b $x c) ?$))
|
|
(assert (xmtn-match--contains-match-variable-p '[a $y $z c] ?$))
|
|
(assert (xmtn-match--contains-match-variable-p '(nil . $y) ?$))
|
|
(assert (xmtn-match--contains-match-variable-p '((() $a)) ?$))
|
|
(assert (not (xmtn-match--contains-match-variable-p 'x ?$)))
|
|
(assert (not (xmtn-match--contains-match-variable-p '(a . b) ?$)))
|
|
(assert (not (xmtn-match--contains-match-variable-p nil ?$)))
|
|
(assert (not (xmtn-match--contains-match-variable-p '((() ())) ?$)))
|
|
(assert (not (xmtn-match--contains-match-variable-p nil ?$)))
|
|
(assert (equal (xmtn-match '(a b)
|
|
(($y $y) nil)
|
|
($z z))
|
|
'(a b)))
|
|
(assert (equal (xmtn-match '(a a)
|
|
(($y $y) y))
|
|
'a))
|
|
(assert (equal (xmtn-match '(a b)
|
|
($z z)
|
|
($z nil))
|
|
'(a b)))
|
|
(assert (xmtn-match nil ([t $y] y) ($z t)))
|
|
(assert (xmtn-match [foo bar] ([foo $y] y)))
|
|
(assert (xmtn-match [foo bar] ((a . b) nil) ([foo bar] t)))
|
|
(assert (xmtn-match nil (nil t)))))
|
|
(xmtn--version-case
|
|
(flet ((xmtn--latest-mtn-release () ;flet has dynamic scope in Emacs Lisp
|
|
'(2 5 "y")))
|
|
(let* ((xmtn-executable 'xmtn-dummy)
|
|
(xmtn--*command-version-cached-for-executable* xmtn-executable))
|
|
(let ((xmtn--*cached-command-version* '(2 5 "x")))
|
|
(assert
|
|
(xmtn--version-case
|
|
((and (= 2 5) (>= 2 5) (or (= 2 4) (<= 3 0))
|
|
(<= 2 6) (/= 1 5) (not (/= 2 5))
|
|
(not (>= 2 6))
|
|
(not (<= 2 4))
|
|
(not (< 2 5))
|
|
(not (< 2 4))) t)
|
|
(t nil)))
|
|
(assert
|
|
(not (ignore-errors
|
|
(xmtn--version-case
|
|
(nil t)))))
|
|
(assert (xmtn--version-case ((mainline> 2 4) t) (t nil)))
|
|
(assert (xmtn--version-case ((mainline> 2 5) t) (t nil)))
|
|
(assert (xmtn--version-case ((mainline> 2 6) nil) (t t))))
|
|
(let ((xmtn--*cached-command-version* '(2 5 "y")))
|
|
(assert (xmtn--version-case ((mainline> 2 4) t) (t nil)))
|
|
(assert (xmtn--version-case ((mainline> 2 5) nil) (t t)))
|
|
(assert (xmtn--version-case ((mainline> 2 6) nil) (t t))))
|
|
(let ((xmtn--*cached-command-version* '(1 5 "w")))
|
|
(assert (xmtn--version-case ((mainline> 2 4) nil) (t t)))
|
|
(assert (xmtn--version-case ((mainline> 2 5) nil) (t t)))
|
|
(assert (xmtn--version-case ((mainline> 1 4) t) (t nil)))
|
|
(assert (xmtn--version-case ((mainline> 1 5) nil) (t t))))
|
|
(let ((xmtn--*cached-command-version* '(2 6 "z")))
|
|
(assert (xmtn--version-case ((mainline> 2 4) t) (t nil)))
|
|
(assert (xmtn--version-case ((mainline> 2 5) t) (t nil)))
|
|
(assert (xmtn--version-case ((mainline> 2 6) nil) (t t)))))))
|
|
(log
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-history (&key &allow-other-keys)
|
|
;; The test is simply that this doesn't crash.
|
|
(dvc-log)
|
|
(dvc-revlist-show-item))))
|
|
(file-diff
|
|
;; The test is simply that this doesn't crash.
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-history (&key file-name &allow-other-keys)
|
|
(find-file file-name)
|
|
(unwind-protect
|
|
(progn
|
|
(insert "x")
|
|
(save-excursion
|
|
(call-interactively #'dvc-file-diff)))
|
|
(revert-buffer t t)))))
|
|
(diff
|
|
;; The test is simply that this doesn't crash.
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-history (&key file-name &allow-other-keys)
|
|
(find-file file-name)
|
|
(let ((buffer (current-buffer)))
|
|
(unwind-protect
|
|
(progn
|
|
(insert "x")
|
|
(write-region (point-min) (point-max)
|
|
file-name nil 'no-message nil nil)
|
|
(set-buffer-modified-p nil)
|
|
(call-interactively #'dvc-diff))
|
|
(dvc-tests-wait-async)
|
|
(with-current-buffer buffer
|
|
(set-buffer-modified-p nil)
|
|
(kill-buffer buffer)))))))
|
|
(automate-buffer-numbering
|
|
(xmtn-tests--with-test-history (&key root &allow-other-keys)
|
|
(xmtn-automate-with-session (session root)
|
|
(xmtn-automate-with-command (handle-1 session '("graph") :may-kill-p t)
|
|
(sleep-for 0.5)
|
|
(xmtn-automate-terminate-processes-in-root root)
|
|
(xmtn-automate-with-command (handle-2 session '("graph")
|
|
:may-kill-p nil)
|
|
(assert (not (equal (xmtn-automate-command-buffer handle-1)
|
|
(xmtn-automate-command-buffer handle-2))))
|
|
(xmtn-automate-command-wait-until-finished handle-2))))))
|
|
(automate-several-commands
|
|
(xmtn-tests--with-test-history (&key root &allow-other-keys)
|
|
;; The test is simply that this doesn't crash.
|
|
(xmtn-automate-with-session (session root)
|
|
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
|
|
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
|
|
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
|
|
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p nil))
|
|
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p t))
|
|
(xmtn-automate-with-command (cmd session '("graph") :may-kill-p t)
|
|
;;(xmtn-automate-command-wait-until-finished cmd)
|
|
))
|
|
;; Try to delay deletion of our temp workspace until process has
|
|
;; terminated.
|
|
(sleep-for 1)))
|
|
(non-ascii-file-name
|
|
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
|
|
(xmtn-tests--with-test-environment (&key root)
|
|
(let ((file-name umlaut))
|
|
(let ((file-name-coding-system 'utf-8)) ; not sure about this...
|
|
(with-temp-file file-name ; create empty file
|
|
(progn)))
|
|
(xmtn--add-files root (list file-name))
|
|
(let ((manifest (xmtn--get-manifest root `(local-tree ,root))))
|
|
(xmtn-match manifest
|
|
(((dir "") (file $file-name-here $hash-id $attributes))
|
|
(assert (equal file-name-here file-name) t)
|
|
(assert (endp attributes)))))
|
|
;; Check whether xmtn-automate encodes the file name
|
|
;; correctly when passing it to monotone. The actual command
|
|
;; doesn't matter as much as the fact that monotone receives
|
|
;; it correctly.
|
|
(xmtn--with-automate-command-output-basic-io-parser
|
|
(next-stanza root (xmtn--version-case
|
|
((mainline> 0 35) `("get_attributes" ,file-name))
|
|
(t `("attributes" ,file-name))))
|
|
(xmtn-match (funcall next-stanza)
|
|
((("format_version" (string "1")))))
|
|
(assert (null (funcall next-stanza)) t))))))
|
|
(non-ascii-file-contents
|
|
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
|
|
(xmtn-tests--with-test-environment (&key root)
|
|
(let ((file-name "foo")
|
|
(contents (concat umlaut "\n"))
|
|
(coding-system 'iso-8859-1-unix))
|
|
(with-temp-file file-name
|
|
(setq buffer-file-coding-system coding-system)
|
|
(insert contents))
|
|
(xmtn--add-files root (list file-name))
|
|
(xmtn--run-command-sync root (list "commit" "--message=commit foo"))
|
|
(let ((content-id "77785e6fd883a5e27a62bc6f26365e1b37e1900f"))
|
|
(assert (equal (xmtn--file-contents-as-string root content-id)
|
|
(encode-coding-string contents coding-system))
|
|
t))))))
|
|
(non-ascii-cert-value
|
|
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
|
|
(xmtn-tests--with-test-history (&key root revision-2 &allow-other-keys)
|
|
(let ((cert-name "test-cert")
|
|
(cert-value umlaut))
|
|
(xmtn--run-command-sync root `("cert" "--"
|
|
,revision-2
|
|
,cert-name ,cert-value))
|
|
(let ((certs (xmtn--list-parsed-certs root revision-2)))
|
|
(let ((matching-certs (remove* cert-name certs
|
|
:key #'third
|
|
:test-not #'equal)))
|
|
(xmtn-match matching-certs
|
|
((($email ok $cert-name-here $cert-value-here t))
|
|
(assert (equal cert-name-here cert-name) t)
|
|
(assert (equal cert-value-here cert-value) t)))))))))
|
|
(dvc-file-diff-with-non-ascii-contents
|
|
(save-window-excursion
|
|
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
|
|
(xmtn-tests--with-test-environment (&key root)
|
|
(let ((file-name "foo")
|
|
(contents (concat umlaut "\n"))
|
|
(coding-system 'utf-8-unix))
|
|
(with-temp-file file-name
|
|
(setq buffer-file-coding-system coding-system)
|
|
(insert contents))
|
|
(xmtn--add-files root (list file-name))
|
|
(xmtn--run-command-sync root (list "commit" "--message=commit foo"))
|
|
(with-temp-buffer
|
|
(let ((coding-system-for-read coding-system))
|
|
(insert-file-contents file-name t))
|
|
(dvc-file-diff file-name)
|
|
(assert (eql (point-min) (point-max)))))))))
|
|
(buffer-file-coding-system-in-dvc-dvc-file-diff
|
|
(save-window-excursion
|
|
(let ((umlaut (string (make-char 'latin-iso8859-1 #xe4)))) ; umlaut a
|
|
(xmtn-tests--with-test-environment (&key root)
|
|
(let ((file-name "foo")
|
|
(contents (concat umlaut "\n"))
|
|
(coding-system-1 'utf-8-unix)
|
|
(coding-system-2 'iso-8859-1-unix))
|
|
(with-temp-file file-name
|
|
(setq buffer-file-coding-system coding-system-1)
|
|
(insert contents))
|
|
(xmtn--add-files root (list file-name))
|
|
(xmtn--run-command-sync root (list "commit" "--message=commit foo"))
|
|
(with-temp-buffer
|
|
(insert-file-contents file-name t)
|
|
(setq buffer-file-coding-system coding-system-2)
|
|
(let ((coding-system-for-read coding-system-1))
|
|
(dvc-file-diff file-name))
|
|
(assert (not (eql (point-min) (point-max))))))))))
|
|
(file-diff-after-rename
|
|
(xmtn-tests--with-test-history (&key root ((:file-name file-name-1))
|
|
revision-2
|
|
&allow-other-keys)
|
|
(let ((file-name-2 "bar"))
|
|
(xmtn--run-command-sync root
|
|
(xmtn--version-case
|
|
((>= 0 34)
|
|
`("mv" "--" ,file-name-1 ,file-name-2))
|
|
(t
|
|
`("mv" "-e" "--" ,file-name-1 ,file-name-2))))
|
|
(with-temp-buffer
|
|
(xmtn--revision-get-file-helper file-name-2 revision-2)
|
|
(assert (equal (buffer-substring (point-min) (point-max))
|
|
"b\n")
|
|
t)))))
|
|
(diff-from-revlog
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-history (&key &allow-other-keys)
|
|
(unwind-protect
|
|
(progn
|
|
(dvc-changelog)
|
|
(dvc-revision-next)
|
|
(dvc-revlist-diff))
|
|
(dvc-tests-wait-async)))))
|
|
(stdio-command-options
|
|
(xmtn--version-case
|
|
((>= 0 31)
|
|
(xmtn-tests--with-test-history (&key root file-name
|
|
revision-1 revision-2
|
|
&allow-other-keys)
|
|
(let ((root default-directory))
|
|
(assert
|
|
(equal
|
|
(xmtn-automate-simple-command-output-lines
|
|
root `(("revision" ,revision-1
|
|
"revision" ,revision-2)
|
|
"content_diff" ,file-name))
|
|
'("============================================================"
|
|
"--- file-1 3f786850e387550fdab836ed7e6dc881de23001b"
|
|
"+++ file-1 89e6c98d92887913cadf06b2adb97f26cde4849b"
|
|
"@@ -1 +1 @@"
|
|
"-a"
|
|
"+b"))
|
|
t))))
|
|
(t
|
|
(xmtn-tests--with-test-history (&key root file-name
|
|
revision-1 revision-2)
|
|
(assert (not (ignore-errors
|
|
(message "%S" (xmtn-automate-simple-command-output-lines
|
|
root `(("revision" ,revision-1
|
|
"revision" ,revision-2)
|
|
"content_diff" ,file-name)))
|
|
t)))))))
|
|
(xmtn-dvc-command-version
|
|
;; Should not error.
|
|
(xmtn-dvc-command-version))
|
|
(dvc-file-diff-write-file-hooks
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-history (&key file-name &allow-other-keys)
|
|
(find-file file-name)
|
|
(unwind-protect
|
|
(progn
|
|
(let ((write-file-hooks (list (lambda ()
|
|
(assert nil)))))
|
|
(insert "x")
|
|
(save-excursion
|
|
(call-interactively #'dvc-file-diff))))
|
|
(revert-buffer t t)))))
|
|
(get-content-changed-closure
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-history (&key root file-name revision-1 revision-2
|
|
&allow-other-keys)
|
|
(let ((other-file-name (concat file-name "2"))
|
|
(renamed-file-name (concat file-name "x"))
|
|
revision-3 revision-4 revision-5)
|
|
(progn
|
|
(with-temp-file other-file-name (insert "a\n"))
|
|
(xmtn--add-files root (list other-file-name))
|
|
(xmtn--run-command-sync root `("commit" "--message=commit"))
|
|
(setq revision-3 (xmtn--get-base-revision-hash-id root)))
|
|
(progn
|
|
(xmtn--run-command-sync root
|
|
(xmtn--version-case
|
|
((>= 0 34)
|
|
`("mv" "--" ,file-name ,renamed-file-name))
|
|
(t
|
|
`("mv" "-e" "--" ,file-name
|
|
,renamed-file-name))))
|
|
(xmtn--run-command-sync root `("commit" "--message=commit"))
|
|
(setq revision-4 (xmtn--get-base-revision-hash-id root)))
|
|
(progn
|
|
(with-temp-file renamed-file-name (insert "c\n"))
|
|
(xmtn--run-command-sync root `("commit" "--message=commit"))
|
|
(setq revision-5 (xmtn--get-base-revision-hash-id root)))
|
|
(flet ((check (file start-rev expected-results)
|
|
(let ((actual (xmtn--get-content-changed-closure
|
|
root `(revision ,start-rev) file)))
|
|
(unless (null (set-exclusive-or expected-results
|
|
actual
|
|
:test #'equal))
|
|
(error "file=%S start-rev=%s expected=%S actual=%S; revisions=%S"
|
|
file start-rev expected-results actual
|
|
(list revision-1 revision-2 revision-3 revision-4
|
|
revision-5))))))
|
|
(check file-name revision-1 `((,revision-1 ,file-name)))
|
|
;; Some of these checks fail with mtn 0.30; not
|
|
;; investigated further.
|
|
;;
|
|
;; 0.30 reports ((1 file))
|
|
(check file-name revision-2 `((,revision-1 ,file-name)
|
|
(,revision-2 ,file-name)))
|
|
|
|
;; 0.30 reports ((1 file))
|
|
(check file-name revision-3 `((,revision-1 ,file-name)
|
|
(,revision-2 ,file-name)))
|
|
;; 0.30 reports ((1 file) (4 renamed))
|
|
(check renamed-file-name revision-4 `((,revision-1 ,file-name)
|
|
(,revision-2 ,file-name)))
|
|
;; 0.30 reports ((1 file) (4 renamed))
|
|
(check renamed-file-name revision-5 `((,revision-1 ,file-name)
|
|
(,revision-2 ,file-name)
|
|
(,revision-5
|
|
,renamed-file-name)))
|
|
(check other-file-name revision-3 `((,revision-3 ,other-file-name)))
|
|
(check other-file-name revision-4 `((,revision-3 ,other-file-name)))
|
|
(check other-file-name revision-5 `((,revision-3 ,other-file-name)))
|
|
)))))
|
|
(locale
|
|
;; The test is simply that this doesn't crash.
|
|
(let ((process-environment (list* "LC_MESSAGES=de_DE" process-environment))
|
|
(xmtn--*cached-command-version* nil))
|
|
;; Unfortunately, in my configuration, I don't seem to be able to
|
|
;; get monotone to print non-English messages at all. So, for
|
|
;; me, this doesn't actually fail even without the appropriate
|
|
;; changes to `xmtn--call-with-environment-for-subprocess'.
|
|
(xmtn-check-command-version)))
|
|
|
|
(xmtn--file-registered-p
|
|
(xmtn-tests--with-test-history (&key root file-name &allow-other-keys)
|
|
(assert (xmtn--file-registered-p root file-name))
|
|
(assert (not (xmtn--file-registered-p root "nonexistent-file")))))
|
|
|
|
(dvc-status-add
|
|
(save-window-excursion
|
|
(xmtn-tests--with-test-environment
|
|
(&key &allow-other-keys)
|
|
;; add and commit an unknown file, using dvc-status keystrokes
|
|
(with-temp-file "unknown" (insert "unknown - to be added\n"))
|
|
(with-temp-file "unknown-marked" (insert "unknown, marked\n"))
|
|
(dvc-status)
|
|
(dvc-tests-wait-async)
|
|
(assert (looking-at " unknown unknown"))
|
|
(execute-kbd-macro (vector dvc-key-add))
|
|
(dvc-tests-wait-async)
|
|
(assert (looking-at " added unknown"))
|
|
(forward-line)
|
|
(assert (looking-at " unknown unknown-marked"))
|
|
(execute-kbd-macro (vector dvc-key-mark dvc-key-add))
|
|
;; FIXME: checking for the mark doesn't work; something about the fontification of the line.
|
|
(dvc-tests-wait-async)
|
|
(execute-kbd-macro (vector dvc-key-unmark))
|
|
(assert (looking-at " added unknown-marked"))
|
|
;; FIXME: commit hangs when run from this test, in xmtn--insert-log-edit-hints, which runs stuff asynchronously
|
|
;; (execute-kbd-macro (vector dvc-key-commit))
|
|
;; (dvc-tests-wait-async)
|
|
;; (debug)
|
|
;; (execute-kbd-macro (vector "C-c" "C-c"))
|
|
;; this works
|
|
(dvc-log-edit)
|
|
(dvc-tests-wait-async)
|
|
(dvc-log-edit-done)
|
|
(dvc-tests-wait-async)
|
|
|
|
;; currently need dvc-status-refresh to see results of the
|
|
;; commit; eventually dvc-status will edit the ewoc directly
|
|
(dvc-status-refresh)
|
|
(dvc-tests-wait-async)
|
|
(assert (looking-at "$"))
|
|
)))
|
|
)
|
|
|
|
(defvar xmtn-tests--profile-history (list))
|
|
|
|
(defun xmtn-tests--profile ()
|
|
(interactive)
|
|
(unless (not xmtn--*enable-assertions*)
|
|
(unless (y-or-n-p "Assertions appear to be enabled. Continue anyway? ")
|
|
(error "Aborted")))
|
|
(let ((command
|
|
(read-from-minibuffer "Profile xmtn command: "
|
|
nil read-expression-map t
|
|
'xmtn-tests--profile-history))
|
|
(reps 20))
|
|
(elp-instrument-package "xmtn-")
|
|
(elp-instrument-package "dvc-")
|
|
(elp-instrument-package "process-")
|
|
(elp-instrument-package "ewoc-")
|
|
(elp-instrument-function 'accept-process-output)
|
|
(elp-instrument-function 'buffer-substring-no-properties)
|
|
(elp-reset-all)
|
|
(setq elp-reset-after-results nil)
|
|
;; FIXME: Maybe use benchmark.el.
|
|
(let ((gc-cons-threshold (max gc-cons-threshold 100000000))
|
|
(run-time 0)
|
|
(gc-time 0))
|
|
(assert (garbage-collect))
|
|
(loop for rep from 1
|
|
repeat reps
|
|
do
|
|
(with-temp-message (format "Profiling, repetition %s of %s..."
|
|
rep reps)
|
|
(save-excursion
|
|
(save-window-excursion
|
|
(let ((start-time (current-time)))
|
|
(eval command)
|
|
(let ((end-time (current-time)))
|
|
(incf run-time (elp-elapsed-time start-time
|
|
end-time))))))
|
|
(assert (let ((start-time (current-time)))
|
|
(prog1
|
|
(garbage-collect)
|
|
(let ((end-time (current-time)))
|
|
(incf gc-time (elp-elapsed-time start-time
|
|
end-time))))))))
|
|
(elp-results)
|
|
(setq truncate-lines t)
|
|
(goto-char (point-min))
|
|
(insert (format "Command: %S\n" command))
|
|
(insert (format "Repetitions: %s\n" reps))
|
|
(insert "\n")
|
|
(insert (format "Wall time (excluding gc): %s\n" run-time))
|
|
(insert (format "GC time (bogus): %s\n" gc-time))
|
|
(insert "\n"))
|
|
(elp-restore-all))
|
|
(message "Profiling finished"))
|
|
|
|
(defun xmtn-tests--time ()
|
|
(interactive)
|
|
(unless (not xmtn--*enable-assertions*)
|
|
(unless (y-or-n-p "Assertions appear to be enabled. Continue anyway? ")
|
|
(error "Aborted")))
|
|
(let ((command
|
|
(read-from-minibuffer "Time xmtn command: "
|
|
nil read-expression-map t
|
|
'xmtn-tests--profile-history))
|
|
(reps 10)) ;; FIXME: dies on rep 30 on Windows MinGW
|
|
;; Run command once before starting timing to get everything in cache
|
|
(eval command)
|
|
(let ((run-time 0))
|
|
(assert (garbage-collect))
|
|
(loop for rep from 1
|
|
repeat reps
|
|
do
|
|
(with-temp-message (format "Timing, repetition %s of %s..."
|
|
rep reps)
|
|
(save-excursion
|
|
(save-window-excursion
|
|
(let ((start-time (current-time)))
|
|
(eval command)
|
|
(let ((end-time (current-time)))
|
|
(incf run-time (elp-elapsed-time start-time
|
|
end-time))))))))
|
|
(switch-to-buffer-other-window (get-buffer-create
|
|
"*xmtn timing results*"))
|
|
(erase-buffer)
|
|
(setq truncate-lines t)
|
|
(goto-char (point-min))
|
|
(insert (format "Command: %S\n" command))
|
|
(insert (format "Repetitions: %s\n" reps))
|
|
(insert "\n")
|
|
(insert (format "Wall time (including gc): %s\n" run-time))
|
|
(insert "\n")))
|
|
(message "Timing finished"))
|
|
|
|
(defun xmtn-tests--parse-basic-io-inventory-benchmark (mtn-executable tree)
|
|
(let ((default-directory tree)
|
|
(xmtn-executable mtn-executable)
|
|
(xmtn--*cached-command-version* nil))
|
|
(xmtn-automate-with-session (session (dvc-tree-root))
|
|
(xmtn-automate-with-command (handle session '("inventory"))
|
|
(xmtn-automate-command-wait-until-finished handle)
|
|
(xmtn-automate-command-check-for-and-report-error handle)
|
|
(xmtn-basic-io-with-stanza-parser (parser (xmtn-automate-command-buffer
|
|
handle))
|
|
(let ((changed 0)
|
|
(total 0)
|
|
(unknown 0)
|
|
(ignored 0))
|
|
(loop for stanza = (funcall parser)
|
|
while stanza
|
|
do (incf total)
|
|
do (let ((status (second (assoc "status" stanza))))
|
|
(xmtn-match status
|
|
((string "known"))
|
|
((string "missing"))
|
|
((string "unknown") (incf unknown))
|
|
((string "ignored") (incf ignored)))
|
|
(let ((changes (second (assoc "changes" stanza))))
|
|
(unless (null changes)
|
|
(incf changed)))))
|
|
(message "total=%s changed=%s ignored=%s unknown=%s"
|
|
total changed ignored unknown)))))))
|
|
|
|
(provide 'xmtn-tests)
|
|
;;; xmtn-tests.el ends here
|