Commit 01a04880 authored by Michael Albinus's avatar Michael Albinus

Add traces in shadowfile

* lisp/shadowfile.el (shadow-add-to-todo)
(shadow-remove-from-todo, shadow-save-todo-file):
* test/lisp/shadowfile-tests.el (shadow-test08-shadow-todo):
Add traces.
parent 52f83af1
Pipeline #3072 failed with stage
in 77 minutes and 26 seconds
...@@ -634,6 +634,10 @@ Consider them as regular expressions if third arg REGEXP is true." ...@@ -634,6 +634,10 @@ Consider them as regular expressions if third arg REGEXP is true."
(let ((shadows (shadow-shadows-of (let ((shadows (shadow-shadows-of
(shadow-expand-file-name (shadow-expand-file-name
(buffer-file-name (current-buffer)))))) (buffer-file-name (current-buffer))))))
(when shadow-debug
(message
"shadow-add-to-todo: %s %s\n%s"
shadows shadow-files-to-copy (with-output-to-string (backtrace))))
(when shadows (when shadows
(setq shadow-files-to-copy (setq shadow-files-to-copy
(shadow-union shadows shadow-files-to-copy)) (shadow-union shadows shadow-files-to-copy))
...@@ -647,6 +651,10 @@ Consider them as regular expressions if third arg REGEXP is true." ...@@ -647,6 +651,10 @@ Consider them as regular expressions if third arg REGEXP is true."
(defun shadow-remove-from-todo (pair) (defun shadow-remove-from-todo (pair)
"Remove PAIR from `shadow-files-to-copy'. "Remove PAIR from `shadow-files-to-copy'.
PAIR must be `eq' to one of the elements of that list." PAIR must be `eq' to one of the elements of that list."
(when shadow-debug
(message
"shadow-remove-from-todo: %s %s\n%s"
pair shadow-files-to-copy (with-output-to-string (backtrace))))
(setq shadow-files-to-copy (setq shadow-files-to-copy
(cl-remove-if (lambda (s) (eq s pair)) shadow-files-to-copy))) (cl-remove-if (lambda (s) (eq s pair)) shadow-files-to-copy)))
...@@ -717,6 +725,8 @@ With non-nil argument also saves the buffer." ...@@ -717,6 +725,8 @@ With non-nil argument also saves the buffer."
(if save (shadow-save-todo-file)))) (if save (shadow-save-todo-file))))
(defun shadow-save-todo-file () (defun shadow-save-todo-file ()
(when shadow-debug
(message "shadow-save-todo-file:\n%s" (with-output-to-string (backtrace))))
(if (and shadow-todo-buffer (buffer-modified-p shadow-todo-buffer)) (if (and shadow-todo-buffer (buffer-modified-p shadow-todo-buffer))
(with-current-buffer shadow-todo-buffer (with-current-buffer shadow-todo-buffer
(condition-case nil ; have to continue even in case of (condition-case nil ; have to continue even in case of
...@@ -772,7 +782,7 @@ look for files that have been changed and need to be copied to other systems." ...@@ -772,7 +782,7 @@ look for files that have been changed and need to be copied to other systems."
(buffer-list)))) (buffer-list))))
(yes-or-no-p "Modified buffers exist; exit anyway? ")) (yes-or-no-p "Modified buffers exist; exit anyway? "))
(or (not (fboundp 'process-list)) (or (not (fboundp 'process-list))
;; process-list is not defined on MSDOS. ;; `process-list' is not defined on MSDOS.
(let ((processes (process-list)) (let ((processes (process-list))
active) active)
(while processes (while processes
......
...@@ -126,9 +126,9 @@ guaranteed by the originator of a cluster definition." ...@@ -126,9 +126,9 @@ guaranteed by the originator of a cluster definition."
(unwind-protect (unwind-protect
;; We must mock `read-from-minibuffer' and `read-string', in ;; We must mock `read-from-minibuffer' and `read-string', in
;; order to avoid interactive arguments. ;; order to avoid interactive arguments.
(cl-letf* (((symbol-function 'read-from-minibuffer) (cl-letf* (((symbol-function #'read-from-minibuffer)
(lambda (&rest args) (pop mocked-input))) (lambda (&rest args) (pop mocked-input)))
((symbol-function 'read-string) ((symbol-function #'read-string)
(lambda (&rest args) (pop mocked-input)))) (lambda (&rest args) (pop mocked-input))))
;; Cleanup & initialize. ;; Cleanup & initialize.
...@@ -140,7 +140,7 @@ guaranteed by the originator of a cluster definition." ...@@ -140,7 +140,7 @@ guaranteed by the originator of a cluster definition."
primary shadow-system-name primary shadow-system-name
regexp (shadow-regexp-superquote primary) regexp (shadow-regexp-superquote primary)
mocked-input `(,cluster ,primary ,regexp)) mocked-input `(,cluster ,primary ,regexp))
(call-interactively 'shadow-define-cluster) (call-interactively #'shadow-define-cluster)
(should (should
(string-equal (string-equal
(shadow-cluster-name (shadow-get-cluster cluster)) cluster)) (shadow-cluster-name (shadow-get-cluster cluster)) cluster))
...@@ -164,7 +164,7 @@ guaranteed by the originator of a cluster definition." ...@@ -164,7 +164,7 @@ guaranteed by the originator of a cluster definition."
mocked-input `(,cluster ,cluster ,primary ,regexp)) mocked-input `(,cluster ,cluster ,primary ,regexp))
(with-current-buffer (messages-buffer) (with-current-buffer (messages-buffer)
(narrow-to-region (point-max) (point-max))) (narrow-to-region (point-max) (point-max)))
(call-interactively 'shadow-define-cluster) (call-interactively #'shadow-define-cluster)
(should (should
(string-match (string-match
(regexp-quote "Not a valid primary!") (regexp-quote "Not a valid primary!")
...@@ -185,7 +185,7 @@ guaranteed by the originator of a cluster definition." ...@@ -185,7 +185,7 @@ guaranteed by the originator of a cluster definition."
mocked-input `(,cluster ,primary ,cluster ,regexp)) mocked-input `(,cluster ,primary ,cluster ,regexp))
(with-current-buffer (messages-buffer) (with-current-buffer (messages-buffer)
(narrow-to-region (point-max) (point-max))) (narrow-to-region (point-max) (point-max)))
(call-interactively 'shadow-define-cluster) (call-interactively #'shadow-define-cluster)
(should (should
(string-match (string-match
(regexp-quote "Regexp doesn't include the primary host!") (regexp-quote "Regexp doesn't include the primary host!")
...@@ -206,7 +206,7 @@ guaranteed by the originator of a cluster definition." ...@@ -206,7 +206,7 @@ guaranteed by the originator of a cluster definition."
(file-remote-p shadow-test-remote-temporary-file-directory) (file-remote-p shadow-test-remote-temporary-file-directory)
regexp (shadow-regexp-superquote primary) regexp (shadow-regexp-superquote primary)
mocked-input `(,cluster ,primary ,regexp)) mocked-input `(,cluster ,primary ,regexp))
(call-interactively 'shadow-define-cluster) (call-interactively #'shadow-define-cluster)
(should (should
(string-equal (string-equal
(shadow-cluster-name (shadow-get-cluster cluster)) cluster)) (shadow-cluster-name (shadow-get-cluster cluster)) cluster))
...@@ -243,9 +243,9 @@ guaranteed by the originator of a cluster definition." ...@@ -243,9 +243,9 @@ guaranteed by the originator of a cluster definition."
(unwind-protect (unwind-protect
;; We must mock `read-from-minibuffer' and `read-string', in ;; We must mock `read-from-minibuffer' and `read-string', in
;; order to avoid interactive arguments. ;; order to avoid interactive arguments.
(cl-letf* (((symbol-function 'read-from-minibuffer) (cl-letf* (((symbol-function #'read-from-minibuffer)
(lambda (&rest args) (pop mocked-input))) (lambda (&rest args) (pop mocked-input)))
((symbol-function 'read-string) ((symbol-function #'read-string)
(lambda (&rest args) (pop mocked-input)))) (lambda (&rest args) (pop mocked-input))))
;; Cleanup & initialize. ;; Cleanup & initialize.
...@@ -596,9 +596,9 @@ guaranteed by the originator of a cluster definition." ...@@ -596,9 +596,9 @@ guaranteed by the originator of a cluster definition."
(unwind-protect (unwind-protect
;; We must mock `read-from-minibuffer' and `read-string', in ;; We must mock `read-from-minibuffer' and `read-string', in
;; order to avoid interactive arguments. ;; order to avoid interactive arguments.
(cl-letf* (((symbol-function 'read-from-minibuffer) (cl-letf* (((symbol-function #'read-from-minibuffer)
(lambda (&rest args) (pop mocked-input))) (lambda (&rest args) (pop mocked-input)))
((symbol-function 'read-string) ((symbol-function #'read-string)
(lambda (&rest args) (pop mocked-input)))) (lambda (&rest args) (pop mocked-input))))
;; Cleanup & initialize. ;; Cleanup & initialize.
...@@ -629,7 +629,7 @@ guaranteed by the originator of a cluster definition." ...@@ -629,7 +629,7 @@ guaranteed by the originator of a cluster definition."
mocked-input `(,cluster1 ,file1 ,cluster2 ,file2 ,(kbd "RET"))) mocked-input `(,cluster1 ,file1 ,cluster2 ,file2 ,(kbd "RET")))
(with-temp-buffer (with-temp-buffer
(set-visited-file-name file1) (set-visited-file-name file1)
(call-interactively 'shadow-define-literal-group) (call-interactively #'shadow-define-literal-group)
(set-buffer-modified-p nil)) (set-buffer-modified-p nil))
;; `shadow-literal-groups' is a list of lists. ;; `shadow-literal-groups' is a list of lists.
...@@ -657,9 +657,9 @@ guaranteed by the originator of a cluster definition." ...@@ -657,9 +657,9 @@ guaranteed by the originator of a cluster definition."
(unwind-protect (unwind-protect
;; We must mock `read-from-minibuffer' and `read-string', in ;; We must mock `read-from-minibuffer' and `read-string', in
;; order to avoid interactive arguments. ;; order to avoid interactive arguments.
(cl-letf* (((symbol-function 'read-from-minibuffer) (cl-letf* (((symbol-function #'read-from-minibuffer)
(lambda (&rest args) (pop mocked-input))) (lambda (&rest args) (pop mocked-input)))
((symbol-function 'read-string) ((symbol-function #'read-string)
(lambda (&rest args) (pop mocked-input)))) (lambda (&rest args) (pop mocked-input))))
;; Cleanup & initialize. ;; Cleanup & initialize.
...@@ -686,7 +686,8 @@ guaranteed by the originator of a cluster definition." ...@@ -686,7 +686,8 @@ guaranteed by the originator of a cluster definition."
,cluster1 ,cluster2 ,(kbd "RET"))) ,cluster1 ,cluster2 ,(kbd "RET")))
(with-temp-buffer (with-temp-buffer
(set-visited-file-name nil) (set-visited-file-name nil)
(call-interactively 'shadow-define-regexp-group)) (call-interactively #'shadow-define-regexp-group)
(set-buffer-modified-p nil))
;; `shadow-regexp-groups' is a list of lists. ;; `shadow-regexp-groups' is a list of lists.
(should (consp shadow-regexp-groups)) (should (consp shadow-regexp-groups))
...@@ -733,7 +734,9 @@ guaranteed by the originator of a cluster definition." ...@@ -733,7 +734,9 @@ guaranteed by the originator of a cluster definition."
regexp (shadow-regexp-superquote primary)) regexp (shadow-regexp-superquote primary))
(shadow-set-cluster cluster1 primary regexp) (shadow-set-cluster cluster1 primary regexp)
(when shadow-debug (when shadow-debug
(message "%s %s %s %s" cluster1 primary regexp shadow-clusters)) (message
"shadow-test08-shadow-todo: %s %s %s %s"
cluster1 primary regexp shadow-clusters))
(setq cluster2 "cluster2" (setq cluster2 "cluster2"
primary primary
...@@ -741,7 +744,9 @@ guaranteed by the originator of a cluster definition." ...@@ -741,7 +744,9 @@ guaranteed by the originator of a cluster definition."
regexp (shadow-regexp-superquote primary)) regexp (shadow-regexp-superquote primary))
(shadow-set-cluster cluster2 primary regexp) (shadow-set-cluster cluster2 primary regexp)
(when shadow-debug (when shadow-debug
(message "%s %s %s %s" cluster2 primary regexp shadow-clusters)) (message
"shadow-test08-shadow-todo: %s %s %s %s"
cluster2 primary regexp shadow-clusters))
;; Define a literal group. ;; Define a literal group.
(setq file (setq file
...@@ -750,7 +755,8 @@ guaranteed by the originator of a cluster definition." ...@@ -750,7 +755,8 @@ guaranteed by the originator of a cluster definition."
shadow-literal-groups shadow-literal-groups
`((,(concat "/cluster1:" file) ,(concat "/cluster2:" file)))) `((,(concat "/cluster1:" file) ,(concat "/cluster2:" file))))
(when shadow-debug (when shadow-debug
(message "%s %s" file shadow-literal-groups)) (message
"shadow-test08-shadow-todo: %s %s" file shadow-literal-groups))
;; Save file from "cluster1" definition. ;; Save file from "cluster1" definition.
(with-temp-buffer (with-temp-buffer
...@@ -759,7 +765,7 @@ guaranteed by the originator of a cluster definition." ...@@ -759,7 +765,7 @@ guaranteed by the originator of a cluster definition."
(save-buffer)) (save-buffer))
(when shadow-debug (when shadow-debug
(message (message
"%s %s" "shadow-test08-shadow-todo: %s %s"
(cons file (shadow-contract-file-name (concat "/cluster2:" file))) (cons file (shadow-contract-file-name (concat "/cluster2:" file)))
shadow-files-to-copy)) shadow-files-to-copy))
(should (should
...@@ -774,7 +780,7 @@ guaranteed by the originator of a cluster definition." ...@@ -774,7 +780,7 @@ guaranteed by the originator of a cluster definition."
(save-buffer)) (save-buffer))
(when shadow-debug (when shadow-debug
(message (message
"%s %s" "shadow-test08-shadow-todo: %s %s"
(cons (cons
(concat (shadow-site-primary cluster2) file) (concat (shadow-site-primary cluster2) file)
(shadow-contract-file-name (concat "/cluster1:" file))) (shadow-contract-file-name (concat "/cluster1:" file)))
...@@ -794,7 +800,8 @@ guaranteed by the originator of a cluster definition." ...@@ -794,7 +800,8 @@ guaranteed by the originator of a cluster definition."
,(concat (shadow-site-primary cluster2) ,(concat (shadow-site-primary cluster2)
(shadow-regexp-superquote file))))) (shadow-regexp-superquote file)))))
(when shadow-debug (when shadow-debug
(message "%s %s" file shadow-regexp-groups)) (message
"shadow-test08-shadow-todo: %s %s" file shadow-regexp-groups))
;; Save file from "cluster1" definition. ;; Save file from "cluster1" definition.
(with-temp-buffer (with-temp-buffer
...@@ -803,7 +810,7 @@ guaranteed by the originator of a cluster definition." ...@@ -803,7 +810,7 @@ guaranteed by the originator of a cluster definition."
(save-buffer)) (save-buffer))
(when shadow-debug (when shadow-debug
(message (message
"%s %s" "shadow-test08-shadow-todo: %s %s"
(cons file (shadow-contract-file-name (concat "/cluster2:" file))) (cons file (shadow-contract-file-name (concat "/cluster2:" file)))
shadow-files-to-copy)) shadow-files-to-copy))
(should (should
...@@ -818,7 +825,7 @@ guaranteed by the originator of a cluster definition." ...@@ -818,7 +825,7 @@ guaranteed by the originator of a cluster definition."
(save-buffer)) (save-buffer))
(when shadow-debug (when shadow-debug
(message (message
"%s %s" "shadow-test08-shadow-todo: %s %s"
(cons (cons
(concat (shadow-site-primary cluster2) file) (concat (shadow-site-primary cluster2) file)
(shadow-contract-file-name (concat "/cluster1:" file))) (shadow-contract-file-name (concat "/cluster1:" file)))
...@@ -898,7 +905,7 @@ guaranteed by the originator of a cluster definition." ...@@ -898,7 +905,7 @@ guaranteed by the originator of a cluster definition."
;; We must mock `write-region', in order to check proper ;; We must mock `write-region', in order to check proper
;; action. ;; action.
(add-function (add-function
:before (symbol-function 'write-region) :before (symbol-function #'write-region)
(lambda (&rest args) (lambda (&rest args)
(when (and (buffer-file-name) mocked-input) (when (and (buffer-file-name) mocked-input)
(should (equal (buffer-file-name) (pop mocked-input))))) (should (equal (buffer-file-name) (pop mocked-input)))))
...@@ -913,7 +920,7 @@ guaranteed by the originator of a cluster definition." ...@@ -913,7 +920,7 @@ guaranteed by the originator of a cluster definition."
(looking-at (regexp-quote "(setq shadow-files-to-copy nil)"))))) (looking-at (regexp-quote "(setq shadow-files-to-copy nil)")))))
;; Cleanup. ;; Cleanup.
(remove-function (symbol-function 'write-region) "write-region-mock") (remove-function (symbol-function #'write-region) "write-region-mock")
(dolist (elt `(,file ,(concat (shadow-site-primary cluster2) file))) (dolist (elt `(,file ,(concat (shadow-site-primary cluster2) file)))
(ignore-errors (ignore-errors
(with-current-buffer (get-file-buffer elt) (with-current-buffer (get-file-buffer elt)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment