Mercurial > hg > xemacs-beta

comparison lisp/prim/userlock.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents b82b59fe008d
children b9518feda344
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
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 Free 21 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
23 ;; 02111-1307, USA. 23 ;; Boston, MA 02111-1307, USA.
24 24
25 ;;; Synched up with: FSF 19.34. 25 ;;; Synched up with: FSF 19.30.
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) ; XEmacs 36 (define-error 'file-locked "File is locked" 'file-error)
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 "File is locked" fn opponent))))))) 62 (signal 'file-locked (list 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) ; XEmacs 78 (define-error 'file-supersession "File changed on disk" 'file-error)
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, r or C-h) " 84 (message "%s changed on disk; really edit the buffer? (y, n 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)
95 (?? . help)))))) 94 (?? . help))))))
96 (cond ((null answer) 95 (cond ((null answer)
97 (beep) 96 (beep)
98 (message "Please type y, n or r; or ? for help") 97 (message "Please type y or n; or ? for help")
99 (sit-for 3)) 98 (sit-for 3))
100 ((eq answer 'help) 99 ((eq answer 'help)
101 (ask-user-about-supersession-help) 100 (ask-user-about-supersession-help)
102 (setq answer nil)) 101 (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)))
108 ((eq answer 'yield) 102 ((eq answer 'yield)
109 (signal 'file-supersession 103 (signal 'file-supersession
110 (list "File changed on disk" fn)))))) 104 (list fn))))))
111 (message 105 (message
112 "File on disk now will become a backup file if you save these changes.") 106 "File on disk now will become a backup file if you save these changes.")
113 (setq buffer-backed-up nil)))) 107 (setq buffer-backed-up nil))))
114 108
115 (defun ask-user-about-supersession-help () 109 (defun ask-user-about-supersession-help ()
117 (princ "You want to modify a buffer whose disk file has changed 111 (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. 112 since you last read it in or saved it with this buffer.
119 113
120 If you say `y' to go ahead and modify this buffer, 114 If you say `y' to go ahead and modify this buffer,
121 you risk ruining the work of whoever rewrote the file. 115 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. 116 If you say `n', the change you started to make will be aborted.
125 117
126 Usually, you should type `n' and then `M-x revert-buffer', 118 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.") 119 to get the latest version of the file, then make the change again.")
128 (save-excursion 120 (save-excursion
129 (set-buffer standard-output) 121 (set-buffer standard-output)
130 (help-mode)))) 122 (help-mode))))
123
131 124
132 ;;; dialog-box versions [XEmacs] 125 ;;; dialog-box versions
133 126
134 (defun ask-user-about-lock-dbox (fn opponent) 127 (defun ask-user-about-lock-dbox (fn opponent)
135 (let ((echo-keystrokes 0) 128 (let ((echo-keystrokes 0)
136 (dbox 129 (dbox
137 (cons 130 (cons
151 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed)) 144 (cond ((and (misc-user-event-p event) (eq (event-object event) 'proceed))
152 (throw 'aual-done nil)) 145 (throw 'aual-done nil))
153 ((and (misc-user-event-p event) (eq (event-object event) 'steal)) 146 ((and (misc-user-event-p event) (eq (event-object event) 'steal))
154 (throw 'aual-done t)) 147 (throw 'aual-done t))
155 ((and (misc-user-event-p event) (eq (event-object event) 'yield)) 148 ((and (misc-user-event-p event) (eq (event-object event) 'yield))
156 (signal 'file-locked (list "File is locked" fn opponent))) 149 (signal 'file-locked (list fn opponent)))
157 ((button-release-event-p event) ;; don't beep twice 150 ((button-release-event-p event) ;; don't beep twice
158 nil) 151 nil)
159 (t 152 (t
160 (beep) 153 (beep)
161 (message "please answer the dialog box")))))))) 154 (message "please answer the dialog box"))))))))