cgit.sxemacs.org Git - sxemacs/blob - lisp/userlock.el

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