|
0
|
1 ;;; Minibuffer read functions for VM
|
|
|
2 ;;; Copyright (C) 1993, 1994 Kyle E. Jones
|
|
|
3 ;;;
|
|
|
4 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
5 ;;; it under the terms of the GNU General Public License as published by
|
|
|
6 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
7 ;;; any later version.
|
|
|
8 ;;;
|
|
|
9 ;;; This program is distributed in the hope that it will be useful,
|
|
|
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
12 ;;; GNU General Public License for more details.
|
|
|
13 ;;;
|
|
|
14 ;;; You should have received a copy of the GNU General Public License
|
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
17
|
|
|
18 (provide 'vm-minibuf)
|
|
|
19
|
|
|
20 (defun vm-minibuffer-complete-word (&optional exiting)
|
|
|
21 (interactive)
|
|
|
22 (let ((opoint (point))
|
|
|
23 trimmed-c-list c-list beg end diff word word-prefix-regexp completion)
|
|
|
24 ;; find the beginning and end of the word we're trying to complete
|
|
|
25 (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ )))
|
|
|
26 (progn
|
|
|
27 (skip-chars-backward " \t\n")
|
|
|
28 (and (not (eobp)) (forward-char))
|
|
|
29 (setq end (point)))
|
|
|
30 (skip-chars-forward "^ \t\n")
|
|
|
31 (setq end (point)))
|
|
|
32 (skip-chars-backward "^ \t\n")
|
|
|
33 (setq beg (point))
|
|
|
34 (goto-char opoint)
|
|
|
35 ;; copy the word into a string
|
|
|
36 (setq word (buffer-substring beg end))
|
|
|
37 ;; trim the completion list down to just likely candidates
|
|
|
38 ;; then convert it to an alist.
|
|
|
39 (setq word-prefix-regexp (concat "^" (regexp-quote word))
|
|
|
40 trimmed-c-list (vm-delete-non-matching-strings
|
|
|
41 word-prefix-regexp
|
|
|
42 vm-minibuffer-completion-table)
|
|
|
43 trimmed-c-list (mapcar 'list trimmed-c-list)
|
|
|
44 c-list (mapcar 'list vm-minibuffer-completion-table))
|
|
|
45 ;; Try the word against the completion list.
|
|
|
46 (and trimmed-c-list
|
|
|
47 (setq completion (try-completion word trimmed-c-list)))
|
|
|
48 ;; If completion is nil, figure out what prefix of the word would prefix
|
|
|
49 ;; something in the completion list... but only if the user is interested.
|
|
|
50 (if (and (null completion) vm-completion-auto-correct c-list)
|
|
|
51 (let ((i -1))
|
|
|
52 (while (null (setq completion
|
|
|
53 (try-completion (substring word 0 i) c-list)))
|
|
|
54 (vm-decrement i))
|
|
|
55 (setq completion (substring word 0 i))))
|
|
|
56 ;; If completion is t, we had a perfect match already.
|
|
|
57 (if (eq completion t)
|
|
|
58 (cond ((and (cdr trimmed-c-list)
|
|
|
59 (not (eq last-command 'vm-minibuffer-complete-word)))
|
|
|
60 (and (not exiting)
|
|
|
61 (vm-minibuffer-completion-message
|
|
|
62 "[Complete, but not unique]")))
|
|
|
63 (vm-completion-auto-space
|
|
|
64 (goto-char end)
|
|
|
65 (insert " "))
|
|
|
66 (t
|
|
|
67 (and (not exiting)
|
|
|
68 (vm-minibuffer-completion-message "[Sole completion]"))))
|
|
|
69 ;; Compute the difference in length between the completion and the
|
|
|
70 ;; word. A negative difference means no match and the magnitude
|
|
|
71 ;; indicates the number of chars that need to be shaved off the end
|
|
|
72 ;; before a match will occur. A positive difference means a match
|
|
|
73 ;; occurred and the magnitude specifies the number of new chars that
|
|
|
74 ;; can be appended to the word as a completion.
|
|
|
75 ;;
|
|
|
76 ;; `completion' can be nil here, but the code works anyway because
|
|
|
77 ;; (length nil) still equals 0!
|
|
|
78 (setq diff (- (length completion) (length word)))
|
|
|
79 (cond
|
|
|
80 ;; We have some completion chars. Insert them.
|
|
|
81 ((> diff 0)
|
|
|
82 (goto-char end)
|
|
|
83 (insert (substring completion (- diff)))
|
|
|
84 (if (and vm-completion-auto-space
|
|
|
85 (null (cdr trimmed-c-list)))
|
|
|
86 (insert " ")))
|
|
|
87 ;; The word prefixed more than one string, but we can't complete
|
|
|
88 ;; any further. Either give help or say "Ambiguous".
|
|
|
89 ((zerop diff)
|
|
|
90 (and (not exiting)
|
|
|
91 (if (null completion-auto-help)
|
|
|
92 (vm-minibuffer-completion-message "[Ambiguous]")
|
|
|
93 (vm-minibuffer-show-completions (sort
|
|
|
94 (mapcar 'car trimmed-c-list)
|
|
|
95 'string-lessp)))))
|
|
|
96 ;; The word didn't prefix anything... if vm-completion-auto-correct is
|
|
|
97 ;; non-nil strip the offending characters and try again.
|
|
|
98 (vm-completion-auto-correct
|
|
|
99 (goto-char end)
|
|
|
100 (delete-char diff)
|
|
|
101 (vm-minibuffer-complete-word exiting))
|
|
|
102 ;; if we're not auto-correcting and we're doing
|
|
|
103 ;; multi-word, just let the user insert a space.
|
|
|
104 (vm-completion-auto-space
|
|
|
105 (insert " "))
|
|
|
106 ;; completion utterly failed, tell the user so.
|
|
|
107 (t
|
|
|
108 (and (not exiting)
|
|
|
109 (vm-minibuffer-completion-message "[No match]")))))))
|
|
|
110
|
|
|
111 (defun vm-minibuffer-complete-word-and-exit ()
|
|
|
112 (interactive)
|
|
|
113 (vm-minibuffer-complete-word t)
|
|
|
114 (exit-minibuffer))
|
|
|
115
|
|
|
116 (defun vm-minibuffer-completion-message (string &optional seconds)
|
|
|
117 "Briefly display STRING to the right of the current minibuffer input.
|
|
|
118 Optional second arg SECONDS specifies how long to keep the message visible;
|
|
|
119 the default is 2 seconds.
|
|
|
120
|
|
|
121 A keypress causes the immediate erasure of the STRING, and return of control
|
|
|
122 to the calling program."
|
|
|
123 (let (omax (inhibit-quit t))
|
|
|
124 (save-excursion
|
|
|
125 (goto-char (point-max))
|
|
|
126 (setq omax (point))
|
|
|
127 (insert " " string))
|
|
|
128 (sit-for (or seconds 2))
|
|
|
129 (delete-region omax (point-max))))
|
|
|
130
|
|
|
131 (defun vm-minibuffer-replace-word (word)
|
|
|
132 (goto-char (point-max))
|
|
|
133 (skip-chars-backward "^ \t\n")
|
|
|
134 (delete-region (point) (point-max))
|
|
|
135 (insert word))
|
|
|
136
|
|
|
137 (defun vm-minibuffer-show-completions (list)
|
|
|
138 "Display LIST in a multi-column listing in the \" *Completions*\" buffer.
|
|
|
139 LIST should be a list of strings."
|
|
|
140 (save-excursion
|
|
|
141 (set-buffer (get-buffer-create " *Completions*"))
|
|
|
142 (setq buffer-read-only nil)
|
|
|
143 (use-local-map (make-sparse-keymap))
|
|
|
144 ;; ignore vm-mutable-* here. the user shouldn't mind
|
|
|
145 ;; because when they exit the minibuffer the windows will be
|
|
|
146 ;; set right again.
|
|
|
147 (display-buffer (current-buffer))
|
|
|
148 (erase-buffer)
|
|
|
149 (insert "Possible completions are:\n")
|
|
|
150 (setq buffer-read-only t)
|
|
|
151 (vm-show-list list 'vm-minibuffer-replace-word
|
|
|
152 (list (current-local-map) minibuffer-local-map))
|
|
|
153 (goto-char (point-min))))
|
|
|
154
|
|
|
155 (defun vm-show-list (list &optional function keymaps)
|
|
|
156 "Display LIST in a multi-column listing in the current buffer at point.
|
|
|
157 The current buffer must be displayed in some window at the time
|
|
|
158 this function is called.
|
|
|
159
|
|
|
160 LIST should be a list of strings.
|
|
|
161
|
|
|
162 Optional second argument FUNCTION will be called if the mouse is
|
|
|
163 clicked on one of the strings in the current buffer. The string
|
|
|
164 clicked upon will be passed to FUNCTION as its sole argument.
|
|
|
165
|
|
|
166 Optional third argument KEYMAPS specifies a lists of keymaps
|
|
|
167 where the FUNCTION should be bound to the mouse clicks. By
|
|
|
168 default the local keymap of the current buffer is used."
|
|
|
169 (or keymaps (setq keymaps (and (current-local-map)
|
|
|
170 (list (current-local-map)))))
|
|
|
171 (save-excursion
|
|
|
172 (let ((buffer-read-only nil)
|
|
|
173 tab-stops longest rows columns list-length q i w start command
|
|
|
174 keymap)
|
|
|
175 (cond ((and function keymaps (vm-mouse-support-possible-p))
|
|
|
176 (setq command
|
|
|
177 (list 'lambda '(e) '(interactive "e")
|
|
|
178 (list 'let
|
|
|
179 '((string (vm-mouse-get-mouse-track-string e)))
|
|
|
180 (list 'and 'string (list function 'string)))))
|
|
|
181 (while keymaps
|
|
|
182 (setq keymap (car keymaps))
|
|
|
183 (cond ((vm-mouse-xemacs-mouse-p)
|
|
54
|
184 (define-key keymap 'button1 command)
|
|
98
|
185 (define-key keymap 'button2 command))
|
|
0
|
186 ((vm-mouse-fsfemacs-mouse-p)
|
|
|
187 (define-key keymap [down-mouse-1] 'ignore)
|
|
|
188 (define-key keymap [drag-mouse-1] 'ignore)
|
|
|
189 (define-key keymap [mouse-1] command)
|
|
|
190 (define-key keymap [drag-mouse-2] 'ignore)
|
|
|
191 (define-key keymap [down-mouse-2] 'ignore)
|
|
98
|
192 (define-key keymap [mouse-2] command)))
|
|
0
|
193 (setq keymaps (cdr keymaps)))))
|
|
|
194 (setq w (vm-get-buffer-window (current-buffer)))
|
|
|
195 (setq q list
|
|
|
196 list-length 0
|
|
|
197 longest 0)
|
|
|
198 (while q
|
|
|
199 (setq longest (max longest (length (car q)))
|
|
|
200 list-length (1+ list-length)
|
|
|
201 q (cdr q)))
|
|
|
202 ;; provide for separation between columns
|
|
|
203 (setq longest (+ 3 longest))
|
|
|
204 (setq columns (max 1 (/ (- (window-width w) 2) longest))
|
|
|
205 rows (/ list-length columns)
|
|
|
206 rows
|
|
|
207 (+ (if (zerop (% list-length columns)) 0 1)
|
|
|
208 rows))
|
|
|
209 (setq i columns
|
|
|
210 tab-stops nil)
|
|
|
211 (while (not (zerop i))
|
|
|
212 (setq tab-stops (cons (* longest i) tab-stops)
|
|
|
213 i (1- i)))
|
|
|
214 (setq q list
|
|
|
215 i 0)
|
|
|
216 (while q
|
|
|
217 (setq start (point))
|
|
|
218 (insert (car q))
|
|
|
219 (and function (vm-mouse-set-mouse-track-highlight start (point)))
|
|
|
220 (setq i (1+ i)
|
|
|
221 q (cdr q))
|
|
|
222 (if (zerop (% i columns))
|
|
|
223 (insert "\n")
|
|
|
224 (let ((tab-stop-list tab-stops))
|
|
|
225 (tab-to-tab-stop)))))))
|
|
|
226
|
|
|
227 (defun vm-minibuffer-completion-help ()
|
|
|
228 (interactive)
|
|
|
229 (let ((opoint (point))
|
|
|
230 c-list beg end word word-prefix-regexp)
|
|
|
231 ;; find the beginning and end of the word we're trying to complete
|
|
|
232 (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ )))
|
|
|
233 (progn
|
|
|
234 (skip-chars-backward " \t\n")
|
|
|
235 (and (not (eobp)) (forward-char))
|
|
|
236 (setq end (point)))
|
|
|
237 (skip-chars-forward "^ \t\n")
|
|
|
238 (setq end (point)))
|
|
|
239 (skip-chars-backward "^ \t\n")
|
|
|
240 (setq beg (point))
|
|
|
241 (goto-char opoint)
|
|
|
242 ;; copy the word into a string
|
|
|
243 (setq word (buffer-substring beg end))
|
|
|
244 ;; trim the completion list down to just likely candidates
|
|
|
245 ;; then convert it to an alist.
|
|
|
246 (setq word-prefix-regexp (concat "^" (regexp-quote word))
|
|
|
247 c-list (vm-delete-non-matching-strings
|
|
|
248 word-prefix-regexp
|
|
|
249 vm-minibuffer-completion-table)
|
|
|
250 c-list (sort c-list (function string-lessp)))
|
|
|
251 (if c-list
|
|
|
252 (vm-minibuffer-show-completions c-list)
|
|
|
253 (vm-minibuffer-completion-message " [No match]"))))
|
|
|
254
|
|
|
255 (defun vm-keyboard-read-string (prompt completion-list &optional multi-word)
|
|
|
256 (let ((minibuffer-local-map (copy-keymap minibuffer-local-map))
|
|
|
257 (vm-completion-auto-space multi-word)
|
|
|
258 (vm-minibuffer-completion-table completion-list))
|
|
|
259 (define-key minibuffer-local-map "\t" 'vm-minibuffer-complete-word)
|
|
|
260 (define-key minibuffer-local-map " " 'vm-minibuffer-complete-word)
|
|
|
261 (define-key minibuffer-local-map "?" 'vm-minibuffer-completion-help)
|
|
|
262 (if (not multi-word)
|
|
|
263 (define-key minibuffer-local-map "\r"
|
|
|
264 'vm-minibuffer-complete-word-and-exit))
|
|
98
|
265 ;; evade the XEmacs dialox box, yeccch.
|
|
|
266 (let ((should-use-dialog-box nil))
|
|
|
267 (read-string prompt))))
|
|
0
|
268
|
|
|
269 (defvar last-nonmenu-event)
|
|
|
270
|
|
|
271 (defun vm-read-string (prompt completion-list &optional multi-word)
|
|
|
272 ;; handle alist
|
|
|
273 (if (consp (car completion-list))
|
|
|
274 (setq completion-list (nreverse (mapcar 'car completion-list))))
|
|
70
|
275 (if (and completion-list (vm-mouse-support-possible-p))
|
|
0
|
276 (cond ((and (vm-mouse-xemacs-mouse-p)
|
|
|
277 (or (button-press-event-p last-command-event)
|
|
|
278 (button-release-event-p last-command-event)
|
|
|
279 (menu-event-p last-command-event)))
|
|
|
280 (vm-mouse-read-string prompt completion-list multi-word))
|
|
|
281 ((and (vm-mouse-fsfemacs-mouse-p)
|
|
|
282 (listp last-nonmenu-event))
|
|
|
283 (vm-mouse-read-string prompt completion-list multi-word))
|
|
|
284 (t
|
|
|
285 (vm-keyboard-read-string prompt completion-list multi-word)))
|
|
|
286 (vm-keyboard-read-string prompt completion-list multi-word)))
|
|
|
287
|
|
|
288 (defun vm-read-number (prompt)
|
|
|
289 (let (result)
|
|
|
290 (while
|
|
|
291 (null
|
|
|
292 (string-match "^[ \t]*-?[0-9]+" (setq result (read-string prompt)))))
|
|
|
293 (string-to-int result)))
|
|
|
294
|
|
|
295 (defun vm-read-password (prompt &optional confirm)
|
|
|
296 "Read and return a password from the minibuffer, prompting with PROMPT.
|
|
|
297 Optional second argument CONFIRM non-nil means that the user will be asked
|
|
|
298 to type the password a second time for confirmation and if there is a
|
|
|
299 mismatch, the process is repeated.
|
|
|
300
|
|
|
301 Line editing keys are:
|
|
|
302 C-h, DEL rubout
|
|
|
303 C-u, C-x line kill
|
|
|
304 C-q, C-v literal next"
|
|
|
305 (catch 'return-value
|
|
|
306 (save-excursion
|
|
|
307 (let ((cursor-in-echo-area t)
|
|
|
308 (echo-keystrokes 0)
|
|
|
309 (input-buffer nil)
|
|
|
310 (help-form nil)
|
|
|
311 (xxx "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
|
|
|
312 (string nil)
|
|
|
313 char done form)
|
|
|
314 (unwind-protect
|
|
|
315 (save-excursion
|
|
|
316 (setq input-buffer (get-buffer-create " *password*"))
|
|
|
317 (set-buffer input-buffer)
|
|
|
318 (while t
|
|
|
319 (erase-buffer)
|
|
70
|
320 (vm-unsaved-message "%s%s" prompt
|
|
0
|
321 (vm-truncate-string xxx (buffer-size)))
|
|
|
322 (while (not (memq (setq char (read-char)) '(?\C-m ?\C-j)))
|
|
|
323 (if (setq form
|
|
|
324 (cdr
|
|
|
325 (assq char
|
|
|
326 '((?\C-h . (delete-char -1))
|
|
|
327 (?\C-? . (delete-char -1))
|
|
|
328 (?\C-u . (delete-region 1 (point)))
|
|
|
329 (?\C-x . (delete-region 1 (point)))
|
|
|
330 (?\C-q . (quoted-insert 1))
|
|
|
331 (?\C-v . (quoted-insert 1))))))
|
|
|
332 (condition-case error-data
|
|
|
333 (eval form)
|
|
|
334 (error t))
|
|
|
335 (insert char))
|
|
70
|
336 (vm-unsaved-message "%s%s" prompt
|
|
0
|
337 (vm-truncate-string xxx (buffer-size))))
|
|
|
338 (cond ((and confirm string)
|
|
|
339 (cond ((not (string= string (buffer-string)))
|
|
70
|
340 (vm-unsaved-message
|
|
0
|
341 (concat prompt
|
|
|
342 (vm-truncate-string xxx (buffer-size))
|
|
|
343 " [Mismatch... try again.]"))
|
|
|
344 (ding)
|
|
|
345 (sit-for 2)
|
|
|
346 (setq string nil))
|
|
|
347 (t (throw 'return-value string))))
|
|
|
348 (confirm
|
|
|
349 (setq string (buffer-string))
|
|
70
|
350 (vm-unsaved-message
|
|
0
|
351 (concat prompt
|
|
|
352 (vm-truncate-string xxx (buffer-size))
|
|
|
353 " [Retype to confirm...]"))
|
|
|
354 (sit-for 2))
|
|
|
355 (t
|
|
70
|
356 (vm-unsaved-message "")
|
|
0
|
357 (throw 'return-value (buffer-string))))))
|
|
|
358 (and input-buffer (kill-buffer input-buffer)))))))
|
|
|
359
|
|
|
360 (defun vm-keyboard-read-file-name (prompt &optional dir default
|
|
|
361 must-match initial history)
|
|
|
362 "Like read-file-name, except HISTORY's value is unaltered."
|
|
98
|
363 (let ((oldvalue (symbol-value history))
|
|
|
364 ;; evade the XEmacs dialox box, yeccch.
|
|
|
365 (should-use-dialog-box nil))
|
|
0
|
366 (unwind-protect
|
|
|
367 (condition-case nil
|
|
|
368 (read-file-name prompt dir default must-match initial history)
|
|
|
369 (wrong-number-of-arguments
|
|
|
370 (if history
|
|
|
371 (let ((file-name-history (symbol-value history))
|
|
|
372 file)
|
|
|
373 (setq file
|
|
|
374 (read-file-name prompt dir default must-match initial))
|
|
|
375 file )
|
|
|
376 (read-file-name prompt dir default must-match initial))))
|
|
|
377 (and history (set history oldvalue)))))
|
|
|
378
|
|
|
379 (defun vm-read-file-name (prompt &optional dir default
|
|
|
380 must-match initial history)
|
|
|
381 "Like read-file-name, except a mouse interface is used if a mouse
|
|
|
382 click mouse triggered the current command."
|
|
70
|
383 (if (vm-mouse-support-possible-p)
|
|
0
|
384 (cond ((and (vm-mouse-xemacs-mouse-p)
|
|
|
385 (or (button-press-event-p last-command-event)
|
|
|
386 (button-release-event-p last-command-event)
|
|
|
387 (menu-event-p last-command-event)))
|
|
|
388 (vm-mouse-read-file-name prompt dir default
|
|
|
389 must-match initial history))
|
|
|
390 ((and (vm-mouse-fsfemacs-mouse-p)
|
|
|
391 (listp last-nonmenu-event))
|
|
|
392 (vm-mouse-read-file-name prompt dir default
|
|
|
393 must-match initial history))
|
|
|
394 (t
|
|
|
395 (vm-keyboard-read-file-name prompt dir default
|
|
|
396 must-match initial history)))
|
|
|
397 (vm-keyboard-read-file-name prompt dir default
|
|
|
398 must-match initial history)))
|
|
|
399
|
|
|
400
|
