428
+ − 1 ;;; userlock.el --- handle file access contention between multiple users
+ − 2
+ − 3 ;; Copyright (C) 1985, 1986, 1993 Free Software Foundation, inc.
+ − 4
+ − 5 ;; Maintainer: FSF
+ − 6 ;; Keywords: internal
+ − 7
+ − 8 ;; This file is part of XEmacs.
+ − 9
+ − 10 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 11 ;; under the terms of the GNU General Public License as published by
+ − 12 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 13 ;; any later version.
+ − 14
+ − 15 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 18 ;; General Public License for more details.
+ − 19
+ − 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 Free
+ − 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ − 23 ;; 02111-1307, USA.
+ − 24
+ − 25 ;;; Synched up with: FSF 19.34.
+ − 26
+ − 27 ;;; Commentary:
+ − 28
+ − 29 ;; This file is autoloaded to handle certain conditions
+ − 30 ;; detected by the file-locking code within XEmacs.
+ − 31 ;; The two entry points are `ask-user-about-lock' and
+ − 32 ;; `ask-user-about-supersession-threat'.
+ − 33
+ − 34 ;;; Code:
+ − 35
+ − 36 (define-error 'file-locked "File is locked" 'file-error) ; XEmacs
+ − 37
444
+ − 38 (defun ask-user-about-lock-minibuf (filename other-user)
428
+ − 39 (save-window-excursion
+ − 40 (let (answer)
+ − 41 (while (null answer)
444
+ − 42 (message "%s is locking %s: action (s, q, p, ?)? " other-user filename)
428
+ − 43 (let ((tem (let ((inhibit-quit t)
+ − 44 (cursor-in-echo-area t))
+ − 45 (prog1 (downcase (read-char))
+ − 46 (setq quit-flag nil)))))
+ − 47 (if (= tem help-char)
+ − 48 (ask-user-about-lock-help)
+ − 49 (setq answer (assoc tem '((?s . t)
+ − 50 (?q . yield)
+ − 51 (?\C-g . yield)
+ − 52 (?p . nil)
+ − 53 (?? . help))))
+ − 54 (cond ((null answer)
+ − 55 (beep)
+ − 56 (message "Please type q, s, or p; or ? for help")
+ − 57 (sit-for 3))
+ − 58 ((eq (cdr answer) 'help)
+ − 59 (ask-user-about-lock-help)
+ − 60 (setq answer nil))
+ − 61 ((eq (cdr answer) 'yield)
444
+ − 62 (signal 'file-locked (list "File is locked" filename other-user)))))))
428
+ − 63 (cdr answer))))
+ − 64
+ − 65 (defun ask-user-about-lock-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
+ − 68 already started modifying in EMACS.
+ − 69
+ − 70 You can <s>teal the file; The other user becomes the
+ − 71 intruder if (s)he ever unmodifies the file and then changes it again.
+ − 72 You can <p>roceed; you edit at your own (and the other user's) risk.
+ − 73 You can <q>uit; don't modify this file.")
+ − 74 (save-excursion
+ − 75 (set-buffer standard-output)
+ − 76 (help-mode))))
+ − 77
+ − 78 (define-error 'file-supersession "File changed on disk" 'file-error) ; XEmacs
+ − 79
444
+ − 80 (defun ask-user-about-supersession-threat-minibuf (filename)
428
+ − 81 (save-window-excursion
+ − 82 (let (answer)
+ − 83 (while (null answer)
+ − 84 (message "%s changed on disk; really edit the buffer? (y, n, r or C-h) "
444
+ − 85 (file-name-nondirectory filename))
428
+ − 86 (let ((tem (downcase (let ((cursor-in-echo-area t))
+ − 87 (read-char)))))
+ − 88 (setq answer
+ − 89 (if (= tem help-char)
+ − 90 'help
+ − 91 (cdr (assoc tem '((?n . yield)
+ − 92 (?\C-g . yield)
+ − 93 (?y . proceed)
+ − 94 (?r . revert)
+ − 95 (?? . help))))))
+ − 96 (cond ((null answer)
+ − 97 (beep)
+ − 98 (message "Please type y, n or r; or ? for help")
+ − 99 (sit-for 3))
+ − 100 ((eq answer 'help)
+ − 101 (ask-user-about-supersession-help)
+ − 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
444
+ − 107 (list "File reverted" filename)))
428
+ − 108 ((eq answer 'yield)
+ − 109 (signal 'file-supersession
444
+ − 110 (list "File changed on disk" filename))))))
428
+ − 111 (message
+ − 112 "File on disk now will become a backup file if you save these changes.")
+ − 113 (setq buffer-backed-up nil))))
+ − 114
+ − 115 (defun ask-user-about-supersession-help ()
+ − 116 (with-output-to-temp-buffer "*Help*"
+ − 117 (princ "You want to modify a buffer whose disk file has changed
+ − 118 since you last read it in or saved it with this buffer.
+ − 119
+ − 120 If you say `y' to go ahead and modify this buffer,
+ − 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.
+ − 124 If you say `n', the change you started to make will be aborted.
+ − 125
+ − 126 Usually, you should type `n' and then `M-x revert-buffer',
+ − 127 to get the latest version of the file, then make the change again.")
+ − 128 (save-excursion
+ − 129 (set-buffer standard-output)
+ − 130 (help-mode))))
+ − 131
+ − 132 ;;; dialog-box versions [XEmacs]
+ − 133
444
+ − 134 (defun ask-user-about-lock-dbox (filename other-user)
442
+ − 135 (let ((echo-keystrokes 0))
+ − 136 (make-dialog-box
+ − 137 'question
+ − 138 :question (format "%s is locking %s\n
428
+ − 139 It has been detected that you want to modify a file that
+ − 140 someone else has already started modifying in XEmacs."
444
+ − 141 other-user filename)
442
+ − 142 :buttons
+ − 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"
+ − 145 proceed t]
+ − 146 nil
+ − 147 ["Abort\n\nDon't modify the buffer\n" yield t]))
428
+ − 148 (catch 'aual-done
+ − 149 (while t
+ − 150 (let ((event (next-command-event)))
442
+ − 151 (cond ((and (misc-user-event-p event)
+ − 152 (eq (event-object event) 'proceed))
428
+ − 153 (throw 'aual-done nil))
442
+ − 154 ((and (misc-user-event-p event)
+ − 155 (eq (event-object event) 'steal))
428
+ − 156 (throw 'aual-done t))
442
+ − 157 ((and (misc-user-event-p event)
+ − 158 (eq (event-object event) 'yield))
444
+ − 159 (signal 'file-locked (list "File is locked" filename other-user)))
428
+ − 160 ((and (misc-user-event-p event)
+ − 161 (eq (event-object event) 'menu-no-selection-hook))
+ − 162 (signal 'quit nil))
442
+ − 163 ;; safety check, so we're not endlessly stuck when no
+ − 164 ;; dialog box up
+ − 165 ((not (popup-up-p))
+ − 166 (signal 'quit nil))
428
+ − 167 ((button-release-event-p event) ;; don't beep twice
+ − 168 nil)
+ − 169 (t
+ − 170 (beep)
+ − 171 (message "please answer the dialog box"))))))))
+ − 172
444
+ − 173 (defun ask-user-about-supersession-threat-dbox (filename)
442
+ − 174 (let ((echo-keystrokes 0))
+ − 175 (make-dialog-box
+ − 176 'question
+ − 177 :question
+ − 178 (format "File %s has changed on disk
428
+ − 179 since its buffer was last read in or saved.
+ − 180
444
+ − 181 Do you really want to edit the buffer? " filename)
442
+ − 182 :buttons
+ − 183 '(["Yes\n\nEdit the buffer anyway,\nignoring the disk file"
+ − 184 proceed t]
+ − 185 ["No\n\nDon't modify the buffer\n" yield t]
+ − 186 nil
+ − 187 ["No\n\nDon't modify the buffer\nbut revert it" revert t]
+ − 188 ))
428
+ − 189 (catch 'auast-done
+ − 190 (while t
+ − 191 (let ((event (next-command-event)))
+ − 192 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed))
+ − 193 (throw 'auast-done nil))
+ − 194 ((and (misc-user-event-p event) (eq (event-object event) 'yield))
444
+ − 195 (signal 'file-supersession (list filename)))
428
+ − 196 ((and (misc-user-event-p event) (eq (event-object event) 'revert))
444
+ − 197 (or (equal filename (buffer-file-name))
428
+ − 198 (error
+ − 199 "ask-user-about-supersession-threat called bogusly"))
+ − 200 (revert-buffer nil t)
+ − 201 (signal 'file-supersession
444
+ − 202 (list filename "(reverted)")))
428
+ − 203 ((and (misc-user-event-p event)
+ − 204 (eq (event-object event) 'menu-no-selection-hook))
+ − 205 (signal 'quit nil))
442
+ − 206 ;; safety check, so we're not endlessly stuck when no
+ − 207 ;; dialog box up
+ − 208 ((not (popup-up-p))
+ − 209 (signal 'quit nil))
428
+ − 210 ((button-release-event-p event) ;; don't beep twice
+ − 211 nil)
+ − 212 (t
+ − 213 (beep)
+ − 214 (message "please answer the dialog box"))))))))
+ − 215
+ − 216
+ − 217 ;;; top-level
+ − 218
+ − 219 ;;;###autoload
444
+ − 220 (defun ask-user-about-lock (filename other-user)
+ − 221 "Ask user wanting to edit FILENAME, locked by OTHER-USER, what to do.
428
+ − 222 This function has a choice of three things to do:
444
+ − 223 do (signal 'file-locked (list FILENAME OTHER-USER))
428
+ − 224 to refrain from editing the file
+ − 225 return t (grab the lock on the file)
+ − 226 return nil (edit the file even though it is locked).
444
+ − 227 You can rewrite it to use any criteria you like to choose which one to do."
428
+ − 228 (discard-input)
442
+ − 229 (if (should-use-dialog-box-p)
444
+ − 230 (ask-user-about-lock-dbox filename other-user)
+ − 231 (ask-user-about-lock-minibuf filename other-user)))
428
+ − 232
+ − 233 ;;;###autoload
444
+ − 234 (defun ask-user-about-supersession-threat (filename)
+ − 235 "Ask user who is about to modify an obsolete buffer what to do.
428
+ − 236 This function has two choices: it can return, in which case the modification
444
+ − 237 of the buffer will proceed, or it can (signal 'file-supersession (FILENAME)),
428
+ − 238 in which case the proposed buffer modification will not be made.
+ − 239
444
+ − 240 You can rewrite this to use any criteria you like to choose which one to do.
428
+ − 241 The buffer in question is current when this function is called."
+ − 242 (discard-input)
442
+ − 243 (if (should-use-dialog-box-p)
444
+ − 244 (ask-user-about-supersession-threat-dbox filename)
+ − 245 (ask-user-about-supersession-threat-minibuf filename)))
428
+ − 246
+ − 247 ;;; userlock.el ends here