Mercurial > hg > xemacs-beta

comparison lisp/prim/userlock.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents 376386a54a3c
children 131b0175ea99
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
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 Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 23 ;; 02111-1307, USA.
24 ;;; Synched up with: FSF 19.30. 24
25 ;;; Synched up with: FSF 19.34.
25 26
26 ;;; Commentary: 27 ;;; Commentary:
27 28
28 ;; This file is autoloaded to handle certain conditions 29 ;; This file is autoloaded to handle certain conditions
29 ;; detected by the file-locking code within XEmacs. 30 ;; detected by the file-locking code within XEmacs.
30 ;; The two entry points are `ask-user-about-lock' and 31 ;; The two entry points are `ask-user-about-lock' and
31 ;; `ask-user-about-supersession-threat'. 32 ;; `ask-user-about-supersession-threat'.
32 33
33 ;;; Code: 34 ;;; Code:
34 35
35 (define-error 'file-locked "File is locked" 'file-error) 36 (define-error 'file-locked "File is locked" 'file-error) ; XEmacs
36 37
37 (defun ask-user-about-lock-minibuf (fn opponent) 38 (defun ask-user-about-lock-minibuf (fn opponent)
38 (save-window-excursion 39 (save-window-excursion
39 (let (answer) 40 (let (answer)
40 (while (null answer) 41 (while (null answer)
56 (sit-for 3)) 57 (sit-for 3))
57 ((eq (cdr answer) 'help) 58 ((eq (cdr answer) 'help)
58 (ask-user-about-lock-help) 59 (ask-user-about-lock-help)
59 (setq answer nil)) 60 (setq answer nil))
60 ((eq (cdr answer) 'yield) 61 ((eq (cdr answer) 'yield)
61 (signal 'file-locked (list fn opponent))))))) 62 (signal 'file-locked (list "File is locked" fn opponent)))))))
62 (cdr answer)))) 63 (cdr answer))))
63 64
64 (defun ask-user-about-lock-help () 65 (defun ask-user-about-lock-help ()
65 (with-output-to-temp-buffer "*Help*" 66 (with-output-to-temp-buffer "*Help*"
66 (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
72 You can <q>uit; don't modify this file.") 73 You can <q>uit; don't modify this file.")
73 (save-excursion 74 (save-excursion
74 (set-buffer standard-output) 75 (set-buffer standard-output)
75 (help-mode)))) 76 (help-mode))))
76 77
77 (define-error 'file-supersession "File changed on disk" 'file-error) 78 (define-error 'file-supersession "File changed on disk" 'file-error) ; XEmacs
78 79
79 (defun ask-user-about-supersession-threat-minibuf (fn) 80 (defun ask-user-about-supersession-threat-minibuf (fn)
80 (save-window-excursion 81 (save-window-excursion
81 (let (answer) 82 (let (answer)
82 (while (null answer) 83 (while (null answer)
83 (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) "
84 (file-name-nondirectory fn)) 85 (file-name-nondirectory fn))
85 (let ((tem (downcase (let ((cursor-in-echo-area t)) 86 (let ((tem (downcase (let ((cursor-in-echo-area t))
86 (read-char))))) 87 (read-char)))))
87 (setq answer 88 (setq answer
88 (if (= tem help-char) 89 (if (= tem help-char)
89 'help 90 'help
90 (cdr (assoc tem '((?n . yield) 91 (cdr (assoc tem '((?n . yield)
91 (?\C-g . yield) 92 (?\C-g . yield)
92 (?y . proceed) 93 (?y . proceed)
94 (?r . revert)
93 (?? . help)))))) 95 (?? . help))))))
94 (cond ((null answer) 96 (cond ((null answer)
95 (beep) 97 (beep)
96 (message "Please type y or n; or ? for help") 98 (message "Please type y, n or r; or ? for help")
97 (sit-for 3)) 99 (sit-for 3))
98 ((eq answer 'help) 100 ((eq answer 'help)
99 (ask-user-about-supersession-help) 101 (ask-user-about-supersession-help)
100 (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)))
101 ((eq answer 'yield) 108 ((eq answer 'yield)
102 (signal 'file-supersession 109 (signal 'file-supersession
103 (list fn)))))) 110 (list "File changed on disk" fn))))))
104 (message 111 (message
105 "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.")
106 (setq buffer-backed-up nil)))) 113 (setq buffer-backed-up nil))))
107 114
108 (defun ask-user-about-supersession-help () 115 (defun ask-user-about-supersession-help ()
110 (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
111 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.
112 119
113 If you say `y' to go ahead and modify this buffer, 120 If you say `y' to go ahead and modify this buffer,
114 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.
115 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.
116 125
117 Usually, you should type `n' and then `M-x revert-buffer', 126 Usually, you should type `n' and then `M-x revert-buffer',
118 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.")
119 (save-excursion 128 (save-excursion
120 (set-buffer standard-output) 129 (set-buffer standard-output)
121 (help-mode)))) 130 (help-mode))))
122
123 131
124 ;;; dialog-box versions 132 ;;; dialog-box versions [XEmacs]
125 133
126 (defun ask-user-about-lock-dbox (fn opponent) 134 (defun ask-user-about-lock-dbox (fn opponent)
127 (let ((echo-keystrokes 0) 135 (let ((echo-keystrokes 0)
128 (dbox 136 (dbox
129 (cons 137 (cons
143 (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))
144 (throw 'aual-done nil)) 152 (throw 'aual-done nil))
145 ((and (misc-user-event-p event) (eq (event-object event) 'steal)) 153 ((and (misc-user-event-p event) (eq (event-object event) 'steal))
146 (throw 'aual-done t)) 154 (throw 'aual-done t))
147 ((and (misc-user-event-p event) (eq (event-object event) 'yield)) 155 ((and (misc-user-event-p event) (eq (event-object event) 'yield))
148 (signal 'file-locked (list fn opponent))) 156 (signal 'file-locked (list "File is locked" fn opponent)))
149 ((button-release-event-p event) ;; don't beep twice 157 ((button-release-event-p event) ;; don't beep twice
150 nil) 158 nil)
151 (t 159 (t
152 (beep) 160 (beep)
153 (message "please answer the dialog box")))))))) 161 (message "please answer the dialog box"))))))))