Mercurial > hg > xemacs-beta

comparison lisp/userlock.el @ 444:576fb035e263 r21-2-37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-37
author cvs
date Mon, 13 Aug 2007 11:36:19 +0200
parents abe6d1db359e
children 308d34e9f07d
comparison
equal deleted inserted replaced
443:a8296e22da4e 444:576fb035e263
33 33
34 ;;; Code: 34 ;;; Code:
35 35
36 (define-error 'file-locked "File is locked" 'file-error) ; XEmacs 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 (filename other-user)
39 (save-window-excursion 39 (save-window-excursion
40 (let (answer) 40 (let (answer)
41 (while (null answer) 41 (while (null answer)
42 (message "%s is locking %s: action (s, q, p, ?)? " opponent fn) 42 (message "%s is locking %s: action (s, q, p, ?)? " other-user filename)
43 (let ((tem (let ((inhibit-quit t) 43 (let ((tem (let ((inhibit-quit t)
44 (cursor-in-echo-area t)) 44 (cursor-in-echo-area t))
45 (prog1 (downcase (read-char)) 45 (prog1 (downcase (read-char))
46 (setq quit-flag nil))))) 46 (setq quit-flag nil)))))
47 (if (= tem help-char) 47 (if (= tem help-char)
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 "File is locked" fn opponent))))))) 62 (signal 'file-locked (list "File is locked" filename other-user)))))))
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
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) ; XEmacs 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 (filename)
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, r 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 filename))
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
102 (setq answer nil)) 102 (setq answer nil))
103 ((eq answer 'revert) 103 ((eq answer 'revert)
104 (revert-buffer nil (not (buffer-modified-p))) 104 (revert-buffer nil (not (buffer-modified-p)))
105 ; ask confirmation iff buffer modified 105 ; ask confirmation iff buffer modified
106 (signal 'file-supersession 106 (signal 'file-supersession
107 (list "File reverted" fn))) 107 (list "File reverted" filename)))
108 ((eq answer 'yield) 108 ((eq answer 'yield)
109 (signal 'file-supersession 109 (signal 'file-supersession
110 (list "File changed on disk" fn)))))) 110 (list "File changed on disk" filename))))))
111 (message 111 (message
112 "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.")
113 (setq buffer-backed-up nil)))) 113 (setq buffer-backed-up nil))))
114 114
115 (defun ask-user-about-supersession-help () 115 (defun ask-user-about-supersession-help ()
129 (set-buffer standard-output) 129 (set-buffer standard-output)
130 (help-mode)))) 130 (help-mode))))
131 131
132 ;;; dialog-box versions [XEmacs] 132 ;;; dialog-box versions [XEmacs]
133 133
134 (defun ask-user-about-lock-dbox (fn opponent) 134 (defun ask-user-about-lock-dbox (filename other-user)
135 (let ((echo-keystrokes 0)) 135 (let ((echo-keystrokes 0))
136 (make-dialog-box 136 (make-dialog-box
137 'question 137 'question
138 :question (format "%s is locking %s\n 138 :question (format "%s is locking %s\n
139 It has been detected that you want to modify a file that 139 It has been detected that you want to modify a file that
140 someone else has already started modifying in XEmacs." 140 someone else has already started modifying in XEmacs."
141 opponent fn) 141 other-user filename)
142 :buttons 142 :buttons
143 '(["Steal Lock\n\nThe other user will\nbecome the intruder" steal t] 143 '(["Steal Lock\n\nThe other user will\nbecome the intruder" steal t]
144 ["Proceed\n\nEdit file at your own\n\(and the other user's) risk" 144 ["Proceed\n\nEdit file at your own\n\(and the other user's) risk"
145 proceed t] 145 proceed t]
146 nil 146 nil
154 ((and (misc-user-event-p event) 154 ((and (misc-user-event-p event)
155 (eq (event-object event) 'steal)) 155 (eq (event-object event) 'steal))
156 (throw 'aual-done t)) 156 (throw 'aual-done t))
157 ((and (misc-user-event-p event) 157 ((and (misc-user-event-p event)
158 (eq (event-object event) 'yield)) 158 (eq (event-object event) 'yield))
159 (signal 'file-locked (list "File is locked" fn opponent))) 159 (signal 'file-locked (list "File is locked" filename other-user)))
160 ((and (misc-user-event-p event) 160 ((and (misc-user-event-p event)
161 (eq (event-object event) 'menu-no-selection-hook)) 161 (eq (event-object event) 'menu-no-selection-hook))
162 (signal 'quit nil)) 162 (signal 'quit nil))
163 ;; safety check, so we're not endlessly stuck when no 163 ;; safety check, so we're not endlessly stuck when no
164 ;; dialog box up 164 ;; dialog box up
168 nil) 168 nil)
169 (t 169 (t
170 (beep) 170 (beep)
171 (message "please answer the dialog box")))))))) 171 (message "please answer the dialog box"))))))))
172 172
173 (defun ask-user-about-supersession-threat-dbox (fn) 173 (defun ask-user-about-supersession-threat-dbox (filename)
174 (let ((echo-keystrokes 0)) 174 (let ((echo-keystrokes 0))
175 (make-dialog-box 175 (make-dialog-box
176 'question 176 'question
177 :question 177 :question
178 (format "File %s has changed on disk 178 (format "File %s has changed on disk
179 since its buffer was last read in or saved. 179 since its buffer was last read in or saved.
180 180
181 Do you really want to edit the buffer? " fn) 181 Do you really want to edit the buffer? " filename)
182 :buttons 182 :buttons
183 '(["Yes\n\nEdit the buffer anyway,\nignoring the disk file" 183 '(["Yes\n\nEdit the buffer anyway,\nignoring the disk file"
184 proceed t] 184 proceed t]
185 ["No\n\nDon't modify the buffer\n" yield t] 185 ["No\n\nDon't modify the buffer\n" yield t]
186 nil 186 nil
190 (while t 190 (while t
191 (let ((event (next-command-event))) 191 (let ((event (next-command-event)))
192 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed)) 192 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed))
193 (throw 'auast-done nil)) 193 (throw 'auast-done nil))
194 ((and (misc-user-event-p event) (eq (event-object event) 'yield)) 194 ((and (misc-user-event-p event) (eq (event-object event) 'yield))
195 (signal 'file-supersession (list fn))) 195 (signal 'file-supersession (list filename)))
196 ((and (misc-user-event-p event) (eq (event-object event) 'revert)) 196 ((and (misc-user-event-p event) (eq (event-object event) 'revert))
197 (or (equal fn (buffer-file-name)) 197 (or (equal filename (buffer-file-name))
198 (error 198 (error
199 "ask-user-about-supersession-threat called bogusly")) 199 "ask-user-about-supersession-threat called bogusly"))
200 (revert-buffer nil t) 200 (revert-buffer nil t)
201 (signal 'file-supersession 201 (signal 'file-supersession
202 (list fn "(reverted)"))) 202 (list filename "(reverted)")))
203 ((and (misc-user-event-p event) 203 ((and (misc-user-event-p event)
204 (eq (event-object event) 'menu-no-selection-hook)) 204 (eq (event-object event) 'menu-no-selection-hook))
205 (signal 'quit nil)) 205 (signal 'quit nil))
206 ;; safety check, so we're not endlessly stuck when no 206 ;; safety check, so we're not endlessly stuck when no
207 ;; dialog box up 207 ;; dialog box up
215 215
216 216
217 ;;; top-level 217 ;;; top-level
218 218
219 ;;;###autoload 219 ;;;###autoload
220 (defun ask-user-about-lock (fn opponent) 220 (defun ask-user-about-lock (filename other-user)
221 "Ask user what to do when he wants to edit FILE but it is locked by USER. 221 "Ask user wanting to edit FILENAME, locked by OTHER-USER, what to do.
222 This function has a choice of three things to do: 222 This function has a choice of three things to do:
223 do (signal 'file-locked (list FILE USER)) 223 do (signal 'file-locked (list FILENAME OTHER-USER))
224 to refrain from editing the file 224 to refrain from editing the file
225 return t (grab the lock on the file) 225 return t (grab the lock on the file)
226 return nil (edit the file even though it is locked). 226 return nil (edit the file even though it is locked).
227 You can rewrite it to use any criterion you like to choose which one to do." 227 You can rewrite it to use any criteria you like to choose which one to do."
228 (discard-input) 228 (discard-input)
229 (if (should-use-dialog-box-p) 229 (if (should-use-dialog-box-p)
230 (ask-user-about-lock-dbox fn opponent) 230 (ask-user-about-lock-dbox filename other-user)
231 (ask-user-about-lock-minibuf fn opponent))) 231 (ask-user-about-lock-minibuf filename other-user)))
232 232
233 ;;;###autoload 233 ;;;###autoload
234 (defun ask-user-about-supersession-threat (fn) 234 (defun ask-user-about-supersession-threat (filename)
235 "Ask a user who is about to modify an obsolete buffer what to do. 235 "Ask user who is about to modify an obsolete buffer what to do.
236 This function has two choices: it can return, in which case the modification 236 This function has two choices: it can return, in which case the modification
237 of the buffer will proceed, or it can (signal 'file-supersession (file)), 237 of the buffer will proceed, or it can (signal 'file-supersession (FILENAME)),
238 in which case the proposed buffer modification will not be made. 238 in which case the proposed buffer modification will not be made.
239 239
240 You can rewrite this to use any criterion you like to choose which one to do. 240 You can rewrite this to use any criteria you like to choose which one to do.
241 The buffer in question is current when this function is called." 241 The buffer in question is current when this function is called."
242 (discard-input) 242 (discard-input)
243 (if (should-use-dialog-box-p) 243 (if (should-use-dialog-box-p)
244 (ask-user-about-supersession-threat-dbox fn) 244 (ask-user-about-supersession-threat-dbox filename)
245 (ask-user-about-supersession-threat-minibuf fn))) 245 (ask-user-about-supersession-threat-minibuf filename)))
246 246
247 ;;; userlock.el ends here 247 ;;; userlock.el ends here