aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMichael Albinus2019-09-07 12:31:31 +0200
committerMichael Albinus2019-09-07 12:31:31 +0200
commit01a04880ca7469626a03ea10481d60c5ddec4663 (patch)
tree171e9538fc8e870bb046053946ff0490ef95dd11
parent52f83af1f3975130b6bd035166780c2c2dde778c (diff)
downloademacs-01a04880ca7469626a03ea10481d60c5ddec4663.tar.gz
emacs-01a04880ca7469626a03ea10481d60c5ddec4663.zip
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.
-rw-r--r--lisp/shadowfile.el12
-rw-r--r--test/lisp/shadowfile-tests.el55
2 files changed, 42 insertions, 25 deletions
diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el
index 4566ea19f8d..2778e583674 100644
--- a/lisp/shadowfile.el
+++ b/lisp/shadowfile.el
@@ -634,6 +634,10 @@ Consider them as regular expressions if third arg REGEXP is true."
634 (let ((shadows (shadow-shadows-of 634 (let ((shadows (shadow-shadows-of
635 (shadow-expand-file-name 635 (shadow-expand-file-name
636 (buffer-file-name (current-buffer)))))) 636 (buffer-file-name (current-buffer))))))
637 (when shadow-debug
638 (message
639 "shadow-add-to-todo: %s %s\n%s"
640 shadows shadow-files-to-copy (with-output-to-string (backtrace))))
637 (when shadows 641 (when shadows
638 (setq shadow-files-to-copy 642 (setq shadow-files-to-copy
639 (shadow-union shadows shadow-files-to-copy)) 643 (shadow-union shadows shadow-files-to-copy))
@@ -647,6 +651,10 @@ Consider them as regular expressions if third arg REGEXP is true."
647(defun shadow-remove-from-todo (pair) 651(defun shadow-remove-from-todo (pair)
648 "Remove PAIR from `shadow-files-to-copy'. 652 "Remove PAIR from `shadow-files-to-copy'.
649PAIR must be `eq' to one of the elements of that list." 653PAIR must be `eq' to one of the elements of that list."
654 (when shadow-debug
655 (message
656 "shadow-remove-from-todo: %s %s\n%s"
657 pair shadow-files-to-copy (with-output-to-string (backtrace))))
650 (setq shadow-files-to-copy 658 (setq shadow-files-to-copy
651 (cl-remove-if (lambda (s) (eq s pair)) shadow-files-to-copy))) 659 (cl-remove-if (lambda (s) (eq s pair)) shadow-files-to-copy)))
652 660
@@ -717,6 +725,8 @@ With non-nil argument also saves the buffer."
717 (if save (shadow-save-todo-file)))) 725 (if save (shadow-save-todo-file))))
718 726
719(defun shadow-save-todo-file () 727(defun shadow-save-todo-file ()
728 (when shadow-debug
729 (message "shadow-save-todo-file:\n%s" (with-output-to-string (backtrace))))
720 (if (and shadow-todo-buffer (buffer-modified-p shadow-todo-buffer)) 730 (if (and shadow-todo-buffer (buffer-modified-p shadow-todo-buffer))
721 (with-current-buffer shadow-todo-buffer 731 (with-current-buffer shadow-todo-buffer
722 (condition-case nil ; have to continue even in case of 732 (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 (buffer-list)))) 782 (buffer-list))))
773 (yes-or-no-p "Modified buffers exist; exit anyway? ")) 783 (yes-or-no-p "Modified buffers exist; exit anyway? "))
774 (or (not (fboundp 'process-list)) 784 (or (not (fboundp 'process-list))
775 ;; process-list is not defined on MSDOS. 785 ;; `process-list' is not defined on MSDOS.
776 (let ((processes (process-list)) 786 (let ((processes (process-list))
777 active) 787 active)
778 (while processes 788 (while processes
diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el
index a523a340a40..2696704e7fe 100644
--- a/test/lisp/shadowfile-tests.el
+++ b/test/lisp/shadowfile-tests.el
@@ -126,9 +126,9 @@ guaranteed by the originator of a cluster definition."
126 (unwind-protect 126 (unwind-protect
127 ;; We must mock `read-from-minibuffer' and `read-string', in 127 ;; We must mock `read-from-minibuffer' and `read-string', in
128 ;; order to avoid interactive arguments. 128 ;; order to avoid interactive arguments.
129 (cl-letf* (((symbol-function 'read-from-minibuffer) 129 (cl-letf* (((symbol-function #'read-from-minibuffer)
130 (lambda (&rest args) (pop mocked-input))) 130 (lambda (&rest args) (pop mocked-input)))
131 ((symbol-function 'read-string) 131 ((symbol-function #'read-string)
132 (lambda (&rest args) (pop mocked-input)))) 132 (lambda (&rest args) (pop mocked-input))))
133 133
134 ;; Cleanup & initialize. 134 ;; Cleanup & initialize.
@@ -140,7 +140,7 @@ guaranteed by the originator of a cluster definition."
140 primary shadow-system-name 140 primary shadow-system-name
141 regexp (shadow-regexp-superquote primary) 141 regexp (shadow-regexp-superquote primary)
142 mocked-input `(,cluster ,primary ,regexp)) 142 mocked-input `(,cluster ,primary ,regexp))
143 (call-interactively 'shadow-define-cluster) 143 (call-interactively #'shadow-define-cluster)
144 (should 144 (should
145 (string-equal 145 (string-equal
146 (shadow-cluster-name (shadow-get-cluster cluster)) cluster)) 146 (shadow-cluster-name (shadow-get-cluster cluster)) cluster))
@@ -164,7 +164,7 @@ guaranteed by the originator of a cluster definition."
164 mocked-input `(,cluster ,cluster ,primary ,regexp)) 164 mocked-input `(,cluster ,cluster ,primary ,regexp))
165 (with-current-buffer (messages-buffer) 165 (with-current-buffer (messages-buffer)
166 (narrow-to-region (point-max) (point-max))) 166 (narrow-to-region (point-max) (point-max)))
167 (call-interactively 'shadow-define-cluster) 167 (call-interactively #'shadow-define-cluster)
168 (should 168 (should
169 (string-match 169 (string-match
170 (regexp-quote "Not a valid primary!") 170 (regexp-quote "Not a valid primary!")
@@ -185,7 +185,7 @@ guaranteed by the originator of a cluster definition."
185 mocked-input `(,cluster ,primary ,cluster ,regexp)) 185 mocked-input `(,cluster ,primary ,cluster ,regexp))
186 (with-current-buffer (messages-buffer) 186 (with-current-buffer (messages-buffer)
187 (narrow-to-region (point-max) (point-max))) 187 (narrow-to-region (point-max) (point-max)))
188 (call-interactively 'shadow-define-cluster) 188 (call-interactively #'shadow-define-cluster)
189 (should 189 (should
190 (string-match 190 (string-match
191 (regexp-quote "Regexp doesn't include the primary host!") 191 (regexp-quote "Regexp doesn't include the primary host!")
@@ -206,7 +206,7 @@ guaranteed by the originator of a cluster definition."
206 (file-remote-p shadow-test-remote-temporary-file-directory) 206 (file-remote-p shadow-test-remote-temporary-file-directory)
207 regexp (shadow-regexp-superquote primary) 207 regexp (shadow-regexp-superquote primary)
208 mocked-input `(,cluster ,primary ,regexp)) 208 mocked-input `(,cluster ,primary ,regexp))
209 (call-interactively 'shadow-define-cluster) 209 (call-interactively #'shadow-define-cluster)
210 (should 210 (should
211 (string-equal 211 (string-equal
212 (shadow-cluster-name (shadow-get-cluster cluster)) cluster)) 212 (shadow-cluster-name (shadow-get-cluster cluster)) cluster))
@@ -243,9 +243,9 @@ guaranteed by the originator of a cluster definition."
243 (unwind-protect 243 (unwind-protect
244 ;; We must mock `read-from-minibuffer' and `read-string', in 244 ;; We must mock `read-from-minibuffer' and `read-string', in
245 ;; order to avoid interactive arguments. 245 ;; order to avoid interactive arguments.
246 (cl-letf* (((symbol-function 'read-from-minibuffer) 246 (cl-letf* (((symbol-function #'read-from-minibuffer)
247 (lambda (&rest args) (pop mocked-input))) 247 (lambda (&rest args) (pop mocked-input)))
248 ((symbol-function 'read-string) 248 ((symbol-function #'read-string)
249 (lambda (&rest args) (pop mocked-input)))) 249 (lambda (&rest args) (pop mocked-input))))
250 250
251 ;; Cleanup & initialize. 251 ;; Cleanup & initialize.
@@ -596,9 +596,9 @@ guaranteed by the originator of a cluster definition."
596 (unwind-protect 596 (unwind-protect
597 ;; We must mock `read-from-minibuffer' and `read-string', in 597 ;; We must mock `read-from-minibuffer' and `read-string', in
598 ;; order to avoid interactive arguments. 598 ;; order to avoid interactive arguments.
599 (cl-letf* (((symbol-function 'read-from-minibuffer) 599 (cl-letf* (((symbol-function #'read-from-minibuffer)
600 (lambda (&rest args) (pop mocked-input))) 600 (lambda (&rest args) (pop mocked-input)))
601 ((symbol-function 'read-string) 601 ((symbol-function #'read-string)
602 (lambda (&rest args) (pop mocked-input)))) 602 (lambda (&rest args) (pop mocked-input))))
603 603
604 ;; Cleanup & initialize. 604 ;; Cleanup & initialize.
@@ -629,7 +629,7 @@ guaranteed by the originator of a cluster definition."
629 mocked-input `(,cluster1 ,file1 ,cluster2 ,file2 ,(kbd "RET"))) 629 mocked-input `(,cluster1 ,file1 ,cluster2 ,file2 ,(kbd "RET")))
630 (with-temp-buffer 630 (with-temp-buffer
631 (set-visited-file-name file1) 631 (set-visited-file-name file1)
632 (call-interactively 'shadow-define-literal-group) 632 (call-interactively #'shadow-define-literal-group)
633 (set-buffer-modified-p nil)) 633 (set-buffer-modified-p nil))
634 634
635 ;; `shadow-literal-groups' is a list of lists. 635 ;; `shadow-literal-groups' is a list of lists.
@@ -657,9 +657,9 @@ guaranteed by the originator of a cluster definition."
657 (unwind-protect 657 (unwind-protect
658 ;; We must mock `read-from-minibuffer' and `read-string', in 658 ;; We must mock `read-from-minibuffer' and `read-string', in
659 ;; order to avoid interactive arguments. 659 ;; order to avoid interactive arguments.
660 (cl-letf* (((symbol-function 'read-from-minibuffer) 660 (cl-letf* (((symbol-function #'read-from-minibuffer)
661 (lambda (&rest args) (pop mocked-input))) 661 (lambda (&rest args) (pop mocked-input)))
662 ((symbol-function 'read-string) 662 ((symbol-function #'read-string)
663 (lambda (&rest args) (pop mocked-input)))) 663 (lambda (&rest args) (pop mocked-input))))
664 664
665 ;; Cleanup & initialize. 665 ;; Cleanup & initialize.
@@ -686,7 +686,8 @@ guaranteed by the originator of a cluster definition."
686 ,cluster1 ,cluster2 ,(kbd "RET"))) 686 ,cluster1 ,cluster2 ,(kbd "RET")))
687 (with-temp-buffer 687 (with-temp-buffer
688 (set-visited-file-name nil) 688 (set-visited-file-name nil)
689 (call-interactively 'shadow-define-regexp-group)) 689 (call-interactively #'shadow-define-regexp-group)
690 (set-buffer-modified-p nil))
690 691
691 ;; `shadow-regexp-groups' is a list of lists. 692 ;; `shadow-regexp-groups' is a list of lists.
692 (should (consp shadow-regexp-groups)) 693 (should (consp shadow-regexp-groups))
@@ -733,7 +734,9 @@ guaranteed by the originator of a cluster definition."
733 regexp (shadow-regexp-superquote primary)) 734 regexp (shadow-regexp-superquote primary))
734 (shadow-set-cluster cluster1 primary regexp) 735 (shadow-set-cluster cluster1 primary regexp)
735 (when shadow-debug 736 (when shadow-debug
736 (message "%s %s %s %s" cluster1 primary regexp shadow-clusters)) 737 (message
738 "shadow-test08-shadow-todo: %s %s %s %s"
739 cluster1 primary regexp shadow-clusters))
737 740
738 (setq cluster2 "cluster2" 741 (setq cluster2 "cluster2"
739 primary 742 primary
@@ -741,7 +744,9 @@ guaranteed by the originator of a cluster definition."
741 regexp (shadow-regexp-superquote primary)) 744 regexp (shadow-regexp-superquote primary))
742 (shadow-set-cluster cluster2 primary regexp) 745 (shadow-set-cluster cluster2 primary regexp)
743 (when shadow-debug 746 (when shadow-debug
744 (message "%s %s %s %s" cluster2 primary regexp shadow-clusters)) 747 (message
748 "shadow-test08-shadow-todo: %s %s %s %s"
749 cluster2 primary regexp shadow-clusters))
745 750
746 ;; Define a literal group. 751 ;; Define a literal group.
747 (setq file 752 (setq file
@@ -750,7 +755,8 @@ guaranteed by the originator of a cluster definition."
750 shadow-literal-groups 755 shadow-literal-groups
751 `((,(concat "/cluster1:" file) ,(concat "/cluster2:" file)))) 756 `((,(concat "/cluster1:" file) ,(concat "/cluster2:" file))))
752 (when shadow-debug 757 (when shadow-debug
753 (message "%s %s" file shadow-literal-groups)) 758 (message
759 "shadow-test08-shadow-todo: %s %s" file shadow-literal-groups))
754 760
755 ;; Save file from "cluster1" definition. 761 ;; Save file from "cluster1" definition.
756 (with-temp-buffer 762 (with-temp-buffer
@@ -759,7 +765,7 @@ guaranteed by the originator of a cluster definition."
759 (save-buffer)) 765 (save-buffer))
760 (when shadow-debug 766 (when shadow-debug
761 (message 767 (message
762 "%s %s" 768 "shadow-test08-shadow-todo: %s %s"
763 (cons file (shadow-contract-file-name (concat "/cluster2:" file))) 769 (cons file (shadow-contract-file-name (concat "/cluster2:" file)))
764 shadow-files-to-copy)) 770 shadow-files-to-copy))
765 (should 771 (should
@@ -774,7 +780,7 @@ guaranteed by the originator of a cluster definition."
774 (save-buffer)) 780 (save-buffer))
775 (when shadow-debug 781 (when shadow-debug
776 (message 782 (message
777 "%s %s" 783 "shadow-test08-shadow-todo: %s %s"
778 (cons 784 (cons
779 (concat (shadow-site-primary cluster2) file) 785 (concat (shadow-site-primary cluster2) file)
780 (shadow-contract-file-name (concat "/cluster1:" file))) 786 (shadow-contract-file-name (concat "/cluster1:" file)))
@@ -794,7 +800,8 @@ guaranteed by the originator of a cluster definition."
794 ,(concat (shadow-site-primary cluster2) 800 ,(concat (shadow-site-primary cluster2)
795 (shadow-regexp-superquote file))))) 801 (shadow-regexp-superquote file)))))
796 (when shadow-debug 802 (when shadow-debug
797 (message "%s %s" file shadow-regexp-groups)) 803 (message
804 "shadow-test08-shadow-todo: %s %s" file shadow-regexp-groups))
798 805
799 ;; Save file from "cluster1" definition. 806 ;; Save file from "cluster1" definition.
800 (with-temp-buffer 807 (with-temp-buffer
@@ -803,7 +810,7 @@ guaranteed by the originator of a cluster definition."
803 (save-buffer)) 810 (save-buffer))
804 (when shadow-debug 811 (when shadow-debug
805 (message 812 (message
806 "%s %s" 813 "shadow-test08-shadow-todo: %s %s"
807 (cons file (shadow-contract-file-name (concat "/cluster2:" file))) 814 (cons file (shadow-contract-file-name (concat "/cluster2:" file)))
808 shadow-files-to-copy)) 815 shadow-files-to-copy))
809 (should 816 (should
@@ -818,7 +825,7 @@ guaranteed by the originator of a cluster definition."
818 (save-buffer)) 825 (save-buffer))
819 (when shadow-debug 826 (when shadow-debug
820 (message 827 (message
821 "%s %s" 828 "shadow-test08-shadow-todo: %s %s"
822 (cons 829 (cons
823 (concat (shadow-site-primary cluster2) file) 830 (concat (shadow-site-primary cluster2) file)
824 (shadow-contract-file-name (concat "/cluster1:" file))) 831 (shadow-contract-file-name (concat "/cluster1:" file)))
@@ -898,7 +905,7 @@ guaranteed by the originator of a cluster definition."
898 ;; We must mock `write-region', in order to check proper 905 ;; We must mock `write-region', in order to check proper
899 ;; action. 906 ;; action.
900 (add-function 907 (add-function
901 :before (symbol-function 'write-region) 908 :before (symbol-function #'write-region)
902 (lambda (&rest args) 909 (lambda (&rest args)
903 (when (and (buffer-file-name) mocked-input) 910 (when (and (buffer-file-name) mocked-input)
904 (should (equal (buffer-file-name) (pop mocked-input))))) 911 (should (equal (buffer-file-name) (pop mocked-input)))))
@@ -913,7 +920,7 @@ guaranteed by the originator of a cluster definition."
913 (looking-at (regexp-quote "(setq shadow-files-to-copy nil)"))))) 920 (looking-at (regexp-quote "(setq shadow-files-to-copy nil)")))))
914 921
915 ;; Cleanup. 922 ;; Cleanup.
916 (remove-function (symbol-function 'write-region) "write-region-mock") 923 (remove-function (symbol-function #'write-region) "write-region-mock")
917 (dolist (elt `(,file ,(concat (shadow-site-primary cluster2) file))) 924 (dolist (elt `(,file ,(concat (shadow-site-primary cluster2) file)))
918 (ignore-errors 925 (ignore-errors
919 (with-current-buffer (get-file-buffer elt) 926 (with-current-buffer (get-file-buffer elt)