Mercurial > hg > xemacs-beta

comparison lisp/prim/userlock.el @ 72:b9518feda344 r20-0b31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b31
author cvs
date Mon, 13 Aug 2007 09:03:46 +0200
parents 131b0175ea99
children
comparison
equal deleted inserted replaced
71:bae944334fa4 72:b9518feda344
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details. 18 ;; General Public License for more details.
19 19
20 ;; You should have received a copy of the GNU General Public License 20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Free Software Foundation, 59 Temple Place - Suite 330, 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; Boston, MA 02111-1307, USA. 23 ;; 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.30. 25 ;;; Synched up with: FSF 19.34.
26 26
27 ;;; Commentary: 27 ;;; Commentary:
28 28
29 ;; This file is autoloaded to handle certain conditions 29 ;; This file is autoloaded to handle certain conditions
30 ;; detected by the file-locking code within XEmacs. 30 ;; detected by the file-locking code within XEmacs.
31 ;; The two entry points are `ask-user-about-lock' and 31 ;; The two entry points are `ask-user-about-lock' and
32 ;; `ask-user-about-supersession-threat'. 32 ;; `ask-user-about-supersession-threat'.
33 33
34 ;;; Code: 34 ;;; Code:
35 35
36 (define-error 'file-locked "File is locked" 'file-error) 36 (define-error 'file-locked "File is locked" 'file-error) ; XEmacs
37 37
38 (defun ask-user-about-lock-minibuf (fn opponent) 38 (defun ask-user-about-lock-minibuf (fn opponent)
39 (save-window-excursion 39 (save-window-excursion
40 (let (answer) 40 (let (answer)
41 (while (null answer) 41 (while (null answer)
57 (sit-for 3)) 57 (sit-for 3))
58 ((eq (cdr answer) 'help) 58 ((eq (cdr answer) 'help)
59 (ask-user-about-lock-help) 59 (ask-user-about-lock-help)
60 (setq answer nil)) 60 (setq answer nil))
61 ((eq (cdr answer) 'yield) 61 ((eq (cdr answer) 'yield)
62 (signal 'file-locked (list fn opponent))))))) 62 (signal 'file-locked (list "File is locked" fn opponent)))))))
63 (cdr answer)))) 63 (cdr answer))))
64 64
65 (defun ask-user-about-lock-help () 65 (defun ask-user-about-lock-help ()
66 (with-output-to-temp-buffer "*Help*" 66 (with-output-to-temp-buffer "*Help*"
67 (princ "It has been detected that you want to modify a file that someone else has 67 (princ "It has been detected that you want to modify a file that someone else has
73 You can <q>uit; don't modify this file.") 73 You can <q>uit; don't modify this file.")
74 (save-excursion 74 (save-excursion
75 (set-buffer standard-output) 75 (set-buffer standard-output)
76 (help-mode)))) 76 (help-mode))))
77 77
78 (define-error 'file-supersession "File changed on disk" 'file-error) 78 (define-error 'file-supersession "File changed on disk" 'file-error) ; XEmacs
79 79
80 (defun ask-user-about-supersession-threat-minibuf (fn) 80 (defun ask-user-about-supersession-threat-minibuf (fn)
81 (save-window-excursion 81 (save-window-excursion
82 (let (answer) 82 (let (answer)
83 (while (null answer) 83 (while (null answer)
84 (message "%s changed on disk; really edit the buffer? (y, n or C-h) " 84 (message "%s changed on disk; really edit the buffer? (y, n, r or C-h) "
85 (file-name-nondirectory fn)) 85 (file-name-nondirectory fn))
86 (let ((tem (downcase (let ((cursor-in-echo-area t)) 86 (let ((tem (downcase (let ((cursor-in-echo-area t))
87 (read-char))))) 87 (read-char)))))
88 (setq answer 88 (setq answer
89 (if (= tem help-char) 89 (if (= tem help-char)
90 'help 90 'help
91 (cdr (assoc tem '((?n . yield) 91 (cdr (assoc tem '((?n . yield)
92 (?\C-g . yield) 92 (?\C-g . yield)
93 (?y . proceed) 93 (?y . proceed)
94 (?r . revert)
94 (?? . help)))))) 95 (?? . help))))))
95 (cond ((null answer) 96 (cond ((null answer)
96 (beep) 97 (beep)
97 (message "Please type y or n; or ? for help") 98 (message "Please type y, n or r; or ? for help")
98 (sit-for 3)) 99 (sit-for 3))
99 ((eq answer 'help) 100 ((eq answer 'help)
100 (ask-user-about-supersession-help) 101 (ask-user-about-supersession-help)
101 (setq answer nil)) 102 (setq answer nil))
103 ((eq answer 'revert)
104 (revert-buffer nil (not (buffer-modified-p)))
105 ; ask confirmation iff buffer modified
106 (signal 'file-supersession
107 (list "File reverted" fn)))
102 ((eq answer 'yield) 108 ((eq answer 'yield)
103 (signal 'file-supersession 109 (signal 'file-supersession
104 (list fn)))))) 110 (list "File changed on disk" fn))))))
105 (message 111 (message
106 "File on disk now will become a backup file if you save these changes.") 112 "File on disk now will become a backup file if you save these changes.")
107 (setq buffer-backed-up nil)))) 113 (setq buffer-backed-up nil))))
108 114
109 (defun ask-user-about-supersession-help () 115 (defun ask-user-about-supersession-help ()
111 (princ "You want to modify a buffer whose disk file has changed 117 (princ "You want to modify a buffer whose disk file has changed
112 since you last read it in or saved it with this buffer. 118 since you last read it in or saved it with this buffer.
113 119
114 If you say `y' to go ahead and modify this buffer, 120 If you say `y' to go ahead and modify this buffer,
115 you risk ruining the work of whoever rewrote the file. 121 you risk ruining the work of whoever rewrote the file.
122 If you say `r' to revert, the contents of the buffer are refreshed
123 from the file on disk.
116 If you say `n', the change you started to make will be aborted. 124 If you say `n', the change you started to make will be aborted.
117 125
118 Usually, you should type `n' and then `M-x revert-buffer', 126 Usually, you should type `n' and then `M-x revert-buffer',
119 to get the latest version of the file, then make the change again.") 127 to get the latest version of the file, then make the change again.")
120 (save-excursion 128 (save-excursion
121 (set-buffer standard-output) 129 (set-buffer standard-output)
122 (help-mode)))) 130 (help-mode))))
123
124 131
125 ;;; dialog-box versions 132 ;;; dialog-box versions [XEmacs]
126 133
127 (defun ask-user-about-lock-dbox (fn opponent) 134 (defun ask-user-about-lock-dbox (fn opponent)
128 (let ((echo-keystrokes 0) 135 (let ((echo-keystrokes 0)
129 (dbox 136 (dbox
130 (cons 137 (cons
144 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed)) 151 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed))
145 (throw 'aual-done nil)) 152 (throw 'aual-done nil))
146 ((and (misc-user-event-p event) (eq (event-object event) 'steal)) 153 ((and (misc-user-event-p event) (eq (event-object event) 'steal))
147 (throw 'aual-done t)) 154 (throw 'aual-done t))
148 ((and (misc-user-event-p event) (eq (event-object event) 'yield)) 155 ((and (misc-user-event-p event) (eq (event-object event) 'yield))
149 (signal 'file-locked (list fn opponent))) 156 (signal 'file-locked (list "File is locked" fn opponent)))
150 ((button-release-event-p event) ;; don't beep twice 157 ((button-release-event-p event) ;; don't beep twice
151 nil) 158 nil)
152 (t 159 (t
153 (beep) 160 (beep)
154 (message "please answer the dialog box")))))))) 161 (message "please answer the dialog box"))))))))