Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-menu.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Menu related functions and commands
2 ;;; Copyright (C) 1995 Kyle E. Jones
3 ;;;
4 ;;; Folders menu derived from
5 ;;; vm-folder-menu.el
6 ;;; v1.10; 03-May-1994
7 ;;; Copyright (C) 1994 Heiko Muenkel
8 ;;; email: muenkel@tnt.uni-hannover.de
9 ;;; Used with permission and my thanks.
10 ;;; Changed 18-May-1995, Kyle Jones
11 ;;; Cosmetic string changes, changed some variable names
12 ;;; and interfaced it with FSF Emacs via easymenu.el.
13 ;;;
14 ;;; Tree menu code is essentially tree-menu.el with renamed functions
15 ;;; tree-menu.el
16 ;;; v1.20; 10-May-1994
17 ;;; Copyright (C) 1994 Heiko Muenkel
18 ;;; email: muenkel@tnt.uni-hannover.de
19 ;;;
20 ;;; Changed 18-May-1995, Kyle Jones
21 ;;; Removed the need for the utils.el package and references thereto.
22 ;;; Changed file-truename calls to tree-menu-file-truename so
23 ;;; the calls could be made compatible with FSF Emacs 19's
24 ;;; file-truename function.
25 ;;; Changed 30-May-1995, Kyle Jones
26 ;;; Renamed functions: tree- -> vm-menu-hm-tree.
27 ;;; Changed 5-July-1995, Kyle Jones
28 ;;; Removed the need for -A in ls flags.
29 ;;; Some systems' ls don't support -A.
30 ;;;
31 ;;; This program is free software; you can redistribute it and/or modify
32 ;;; it under the terms of the GNU General Public License as published by
33 ;;; the Free Software Foundation; either version 1, or (at your option)
34 ;;; any later version.
35 ;;;
36 ;;; This program is distributed in the hope that it will be useful,
37 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
38 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
39 ;;; GNU General Public License for more details.
40 ;;;
41 ;;; You should have received a copy of the GNU General Public License
42 ;;; along with this program; if not, write to the Free Software
43 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
44
45 (provide 'vm-menu)
46
47 (defun vm-menu-fsfemacs-menus-p ()
48 (and (vm-fsfemacs-19-p)
49 (fboundp 'menu-bar-mode)))
50
51 (defun vm-menu-xemacs-menus-p ()
52 (and (vm-xemacs-p)
53 (fboundp 'set-buffer-menubar)))
54
55 ;; defined again in vm-misc.el but we need it here for some
56 ;; initializations. The "noautoload" vm.elc won't work without
57 ;; this.
58 (defun vm-fsfemacs-19-p ()
59 (and (string-match "^19" emacs-version)
60 (not (string-match "XEmacs\\|Lucid" emacs-version))))
61
62 (defvar vm-menu-folders-menu
63 '("Manipulate Folders"
64 ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory])
65 "VM folder menu list.")
66
67 (defconst vm-menu-folder-menu
68 (list
69 "Folder"
70 (if (vm-fsfemacs-19-p)
71 ["Manipulate Folders" ignore (ignore)]
72 vm-menu-folders-menu)
73 "---"
74 ["Display Summary" vm-summarize t]
75 ["Toggle Threading" vm-toggle-threads-display t]
76 "---"
77 ["Get New Mail" vm-get-new-mail (vm-menu-can-get-new-mail-p)]
78 "---"
79 ["Search" vm-isearch-forward vm-message-list]
80 "---"
81 ["Auto-Archive" vm-auto-archive-messages vm-message-list]
82 ["Expunge" vm-expunge-folder vm-message-list]
83 "---"
84 ["Visit Folder" vm-visit-folder t]
85 ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
86 ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
87 ["Save" vm-save-folder (vm-menu-can-save-p)]
88 ["Save As..." vm-write-file t]
89 ["Quit" vm-quit-no-change t]
90 ["Save & Quit" vm-quit t]
91 "---"
92 "---"
93 ;; special string that marks the tail of this menu for
94 ;; vm-menu-install-visited-folders-menu.
95 "-------"
96 ))
97
98 (defconst vm-menu-dispose-menu
99 (let ((title (if (vm-menu-fsfemacs-menus-p)
100 (list "Dispose"
101 "Dispose"
102 "---"
103 "---")
104 (list "Dispose"))))
105 (append
106 title
107 (list
108 ["Reply to Author" vm-reply vm-message-list]
109 ["Reply to All" vm-followup vm-message-list]
110 ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
111 ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
112 ["Forward" vm-forward-message vm-message-list]
113 ["Resend" vm-resend-message vm-message-list]
114 ["Retry Bounce" vm-resend-bounced-message vm-message-list]
115 "---"
116 ["File" vm-save-message vm-message-list]
117 ["Delete" vm-delete-message vm-message-list]
118 ["Undelete" vm-undelete-message vm-message-list]
119 ["Kill Current Subject" vm-kill-subject vm-message-list]
120 ["Mark Unread" vm-unread-message vm-message-list]
121 ["Edit" vm-edit-message vm-message-list]
122 ["Print" vm-print-message vm-message-list]
123 ["Pipe to Command" vm-pipe-message-to-command vm-message-list]
124 "---"
125 ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list]
126 ))))
127
128 (defconst vm-menu-motion-menu
129 '("Motion"
130 ["Page Up" vm-scroll-backward vm-message-list]
131 ["Page Down" vm-scroll-forward vm-message-list]
132 "----"
133 ["Beginning" vm-beginning-of-message vm-message-list]
134 ["End" vm-end-of-message vm-message-list]
135 "----"
136 ["Expose/Hide Headers" vm-expose-hidden-headers vm-message-list]
137 "----"
138 "----"
139 ["Next Message" vm-next-message t]
140 ["Previous Message" vm-previous-message t]
141 "---"
142 ["Next, Same Subject" vm-next-message-same-subject t]
143 ["Previous, Same Subject" vm-previous-message-same-subject t]
144 "---"
145 ["Next Unread" vm-next-unread-message t]
146 ["Previous Unread" vm-previous-unread-message t]
147 "---"
148 ["Next Message (no skip)" vm-next-message-no-skip t]
149 ["Previous Message (no skip)" vm-previous-message-no-skip t]
150 "---"
151 ["Go to Last Seen Message" vm-goto-message-last-seen t]
152 ["Go to Message" vm-goto-message t]
153 ["Go to Parent Message" vm-goto-parent-message t]
154 ))
155
156 (defconst vm-menu-virtual-menu
157 '("Virtual"
158 ["Visit Virtual Folder" vm-visit-virtual-folder t]
159 ["Create Virtual Folder" vm-create-virtual-folder t]
160 ["Apply Virtual Folder" vm-apply-virtual-folder t]
161 "---"
162 "---"
163 ;; special string that marks the tail of this menu for
164 ;; vm-menu-install-known-virtual-folders-menu.
165 "-------"
166 ))
167
168 (defconst vm-menu-send-menu
169 '("Send"
170 ["Compose" vm-mail t]
171 ["Continue Composing" vm-continue-composing-message vm-message-list]
172 ["Reply to Author" vm-reply vm-message-list]
173 ["Reply to All" vm-followup vm-message-list]
174 ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
175 ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
176 ["Forward Message" vm-forward-message vm-message-list]
177 ["Resend Message" vm-resend-message vm-message-list]
178 ["Retry Bounced Message" vm-resend-bounced-message vm-message-list]
179 ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list]
180 ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list]
181 ))
182
183 (defconst vm-menu-mark-menu
184 '("Mark"
185 ["Next Command Uses Marks..." vm-next-command-uses-marks
186 :active vm-message-list
187 :style radio
188 :selected (eq last-command 'vm-next-command-uses-marks)]
189 "----"
190 ["Mark" vm-mark-message vm-message-list]
191 ["Unmark" vm-unmark-message vm-message-list]
192 ["Mark All" vm-mark-all-messages vm-message-list]
193 ["Clear All Marks" vm-clear-all-marks vm-message-list]
194 "----"
195 ["Mark Same Subject" vm-mark-messages-same-subject vm-message-list]
196 ["Unmark Same Subject" vm-unmark-messages-same-subject vm-message-list]
197 ["Mark Same Author" vm-mark-messages-same-author vm-message-list]
198 ["Unmark Same Author" vm-unmark-messages-same-author vm-message-list]
199 ["Mark Messages Matching..." vm-mark-matching-messages vm-message-list]
200 ["Unmark Messages Matching..." vm-unmark-matching-messages vm-message-list]
201 ["Mark Thread Subtree" vm-mark-thread-subtree vm-message-list]
202 ["Unmark Thread Subtree" vm-unmark-thread-subtree vm-message-list]
203 ))
204
205 (defconst vm-menu-label-menu
206 '("Label"
207 ["Add Label" vm-add-message-labels vm-message-list]
208 ["Remove Label" vm-delete-message-labels vm-message-list]
209 ))
210
211 (defconst vm-menu-sort-menu
212 '("Sort"
213 ["By Multiple Fields..." vm-sort-messages vm-message-list]
214 "---"
215 ["By Date" (vm-sort-messages "date") vm-message-list]
216 ["By Subject" (vm-sort-messages "subject") vm-message-list]
217 ["By Author" (vm-sort-messages "author") vm-message-list]
218 ["By Recipients" (vm-sort-messages "recipients") vm-message-list]
219 ["By Lines" (vm-sort-messages "line-count") vm-message-list]
220 ["By Bytes" (vm-sort-messages "byte-count") vm-message-list]
221 "---"
222 ["By Date (backward)" (vm-sort-messages "reversed-date") vm-message-list]
223 ["By Subject (backward)" (vm-sort-messages "reversed-subject") vm-message-list]
224 ["By Author (backward)" (vm-sort-messages "reversed-author") vm-message-list]
225 ["By Recipients (backward)" (vm-sort-messages "reversed-recipients") vm-message-list]
226 ["By Lines (backwards)" (vm-sort-messages "reversed-line-count") vm-message-list]
227 ["By Bytes (backward)" (vm-sort-messages "reversed-byte-count") vm-message-list]
228 "---"
229 ["Toggle Threading" vm-toggle-threads-display t]
230 "---"
231 ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list]
232 ))
233
234 (defconst vm-menu-help-menu
235 '("Help!"
236 ["What Now?" vm-help t]
237 ["Describe Mode" describe-mode t]
238 ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
239 ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
240 "---"
241 ["Save Folder & Quit" vm-quit t]
242 ["Quit Without Saving" vm-quit-no-change t]
243 ))
244
245 (defconst vm-menu-undo-menu
246 ["Undo" vm-undo (vm-menu-can-undo-p)]
247 )
248
249 (defconst vm-menu-emacs-button
250 ["XEmacs" vm-menu-toggle-menubar t]
251 )
252
253 (defconst vm-menu-vm-button
254 ["VM" vm-menu-toggle-menubar t]
255 )
256
257 (defconst vm-menu-mail-menu
258 (let ((title (if (vm-menu-fsfemacs-menus-p)
259 (list "Mail Commands"
260 "Mail Commands"
261 "---"
262 "---")
263 (list "Mail Commands"))))
264 (append
265 title
266 (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)]
267 ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)]
268 ["Cancel" kill-buffer t]
269 "----"
270 "Go to Field:"
271 "----"
272 [" To:" mail-to t]
273 [" Subject:" mail-subject t]
274 [" CC:" mail-cc t]
275 [" BCC:" mail-bcc t]
276 [" Reply-To:" mail-replyto t]
277 [" Text" mail-text t]
278 "----"
279 ["Yank Original" vm-menu-yank-original vm-reply-list]
280 ["Fill Yanked Message" mail-fill-yanked-message t]
281 ["Insert Signature" mail-signature t]
282 ["Insert File..." insert-file t]
283 ["Insert Buffer..." insert-buffer t]
284 ))))
285
286 (defconst vm-menu-url-browser-menu
287 (let ((title (if (vm-menu-fsfemacs-menus-p)
288 (list "Send URL to ..."
289 "Send URL to ..."
290 "---"
291 "---")
292 (list "Send URL to ...")))
293 (w3 (cond ((fboundp 'w3-fetch-other-frame)
294 'w3-fetch-other-frame)
295 ((fboundp 'w3-fetch)
296 'w3-fetch)
297 (t 'w3-fetch-other-frame))))
298 (append
299 title
300 (list (vector "Emacs W3"
301 (list 'vm-mouse-send-url-at-position
302 '(point)
303 (list 'quote w3))
304 (list 'fboundp (list 'quote w3)))
305 ["Mosaic"
306 (vm-mouse-send-url-at-position (point)
307 'vm-mouse-send-url-to-mosaic)
308 t]
309 ["Netscape"
310 (vm-mouse-send-url-at-position (point)
311 'vm-mouse-send-url-to-netscape)
312 t]))))
313
314 (defconst vm-menu-subject-menu
315 (let ((title (if (vm-menu-fsfemacs-menus-p)
316 (list "Take Action on Subject..."
317 "Take Action on Subject..."
318 "---"
319 "---")
320 (list "Take Action on Subject..."))))
321 (append
322 title
323 (list
324 ["Kill Subject" vm-kill-subject vm-message-list]
325 ["Next Message, Same Subject" vm-next-message-same-subject
326 vm-message-list]
327 ["Previous Message, Same Subject" vm-previous-message-same-subject
328 vm-message-list]
329 ["Mark Messages, Same Subject" vm-mark-messages-same-subject
330 vm-message-list]
331 ["Unmark Messages, Same Subject" vm-unmark-messages-same-subject
332 vm-message-list]
333 ["Virtual Folder, Matching Subject" vm-menu-create-subject-virtual-folder
334 vm-message-list]
335 ))))
336
337 (defconst vm-menu-author-menu
338 (let ((title (if (vm-menu-fsfemacs-menus-p)
339 (list "Take Action on Author..."
340 "Take Action on Author..."
341 "---"
342 "---")
343 (list "Take Action on Author..."))))
344 (append
345 title
346 (list
347 ["Mark Messages, Same Author" vm-mark-messages-same-author
348 vm-message-list]
349 ["Unmark Messages, Same Author" vm-unmark-messages-same-author
350 vm-message-list]
351 ["Virtual Folder, Matching Author" vm-menu-create-author-virtual-folder
352 vm-message-list]
353 ))))
354
355 (defvar vm-menu-vm-menubar nil)
356
357 (defconst vm-menu-vm-menu
358 (let ((title (if (vm-menu-fsfemacs-menus-p)
359 (list "VM"
360 "VM"
361 "---"
362 "---")
363 (list "VM"))))
364 (append title
365 (list vm-menu-folder-menu
366 vm-menu-motion-menu
367 vm-menu-send-menu
368 vm-menu-mark-menu
369 vm-menu-label-menu
370 vm-menu-sort-menu
371 vm-menu-virtual-menu
372 vm-menu-undo-menu
373 vm-menu-dispose-menu
374 "---"
375 "---"
376 vm-menu-help-menu))))
377
378 (defvar vm-mode-menu-map nil)
379
380 (defun vm-menu-run-command (command &rest args)
381 "Run COMMAND almost interactively, with ARGS.
382 call-interactive can't be used unfortunately, but this-command is
383 set to the command name so that window configuration will be done."
384 (setq this-command command)
385 (apply command args))
386
387 (defun vm-menu-can-revert-p ()
388 (save-excursion
389 (vm-check-for-killed-folder)
390 (vm-select-folder-buffer)
391 (and (buffer-modified-p) buffer-file-name)))
392
393 (defun vm-menu-can-recover-p ()
394 (save-excursion
395 (vm-check-for-killed-folder)
396 (vm-select-folder-buffer)
397 (and buffer-file-name
398 buffer-auto-save-file-name
399 (file-newer-than-file-p
400 buffer-auto-save-file-name
401 buffer-file-name))))
402
403 (defun vm-menu-can-save-p ()
404 (save-excursion
405 (vm-check-for-killed-folder)
406 (vm-select-folder-buffer)
407 (or (eq major-mode 'vm-virtual-mode)
408 (buffer-modified-p))))
409
410 (defun vm-menu-can-get-new-mail-p ()
411 (save-excursion
412 (vm-check-for-killed-folder)
413 (vm-select-folder-buffer)
414 (or (eq major-mode 'vm-virtual-mode)
415 (and (not vm-block-new-mail) (not vm-folder-read-only)))))
416
417 (defun vm-menu-can-undo-p ()
418 (save-excursion
419 (vm-check-for-killed-folder)
420 (vm-select-folder-buffer)
421 vm-undo-record-list))
422
423 (defun vm-menu-yank-original ()
424 (interactive)
425 (save-excursion
426 (let ((mlist vm-reply-list))
427 (while mlist
428 (vm-yank-message (car mlist))
429 (goto-char (point-max))
430 (setq mlist (cdr mlist))))))
431
432 (defun vm-menu-can-send-mail-p ()
433 (save-match-data
434 (catch 'done
435 (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc"))
436 h)
437 (while headers
438 (setq h (mail-fetch-field (car headers)))
439 (and (stringp h) (string-match "[^ \t\n,]" h)
440 (throw 'done t))
441 (setq headers (cdr headers)))
442 nil ))))
443
444 (defun vm-menu-create-subject-virtual-folder ()
445 (interactive)
446 (vm-select-folder-buffer)
447 (setq this-command 'vm-create-virtual-folder)
448 (vm-create-virtual-folder 'subject (regexp-quote
449 (vm-so-sortable-subject
450 (car vm-message-pointer)))))
451
452 (defun vm-menu-create-author-virtual-folder ()
453 (interactive)
454 (vm-select-folder-buffer)
455 (setq this-command 'vm-create-virtual-folder)
456 (vm-create-virtual-folder 'author (regexp-quote
457 (vm-su-from (car vm-message-pointer)))))
458
459 (defun vm-menu-xemacs-global-menubar ()
460 (save-excursion
461 (set-buffer (get-buffer-create "*scratch*"))
462 current-menubar))
463
464 (defun vm-menu-fsfemacs-global-menubar ()
465 (lookup-key (current-global-map) [menu-bar]))
466
467 (defun vm-menu-initialize-vm-mode-menu-map ()
468 (if (null vm-mode-menu-map)
469 (let ((map (make-sparse-keymap))
470 (dummy (make-sparse-keymap)))
471 ;; initialize all the vm-menu-fsfemacs-*-menu variables
472 ;; with the menus.
473 (vm-easy-menu-define vm-menu-fsfemacs-help-menu (list dummy) nil
474 vm-menu-help-menu)
475 (vm-easy-menu-define vm-menu-fsfemacs-dispose-menu (list dummy) nil
476 (cons "Dispose" (nthcdr 4 vm-menu-dispose-menu)))
477 (vm-easy-menu-define vm-menu-fsfemacs-dispose-popup-menu (list dummy) nil
478 vm-menu-dispose-menu)
479 ;; (vm-easy-menu-define vm-menu-fsfemacs-undo-menu (list dummy) nil
480 ;; (list "Undo" vm-menu-undo-menu))
481 (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu (list dummy) nil
482 vm-menu-virtual-menu)
483 (vm-easy-menu-define vm-menu-fsfemacs-sort-menu (list dummy) nil
484 vm-menu-sort-menu)
485 (vm-easy-menu-define vm-menu-fsfemacs-label-menu (list dummy) nil
486 vm-menu-label-menu)
487 (vm-easy-menu-define vm-menu-fsfemacs-mark-menu (list dummy) nil
488 vm-menu-mark-menu)
489 (vm-easy-menu-define vm-menu-fsfemacs-send-menu (list dummy) nil
490 vm-menu-send-menu)
491 (vm-easy-menu-define vm-menu-fsfemacs-motion-menu (list dummy) nil
492 vm-menu-motion-menu)
493 ;; (vm-easy-menu-define vm-menu-fsfemacs-folders-menu (list dummy) nil
494 ;; vm-menu-folders-menu)
495 (vm-easy-menu-define vm-menu-fsfemacs-folder-menu (list dummy) nil
496 vm-menu-folder-menu)
497 (vm-easy-menu-define vm-menu-fsfemacs-vm-menu (list dummy) nil
498 vm-menu-vm-menu)
499 ;; for mail mode
500 (vm-easy-menu-define vm-menu-fsfemacs-mail-menu (list dummy) nil
501 vm-menu-mail-menu)
502 ;; subject menu
503 (vm-easy-menu-define vm-menu-fsfemacs-subject-menu (list dummy) nil
504 vm-menu-subject-menu)
505 ;; author menu
506 (vm-easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil
507 vm-menu-author-menu)
508 ;; url browser menu
509 (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil
510 vm-menu-url-browser-menu)
511 ;; block the global menubar entries in the map so that VM
512 ;; can take over the menubar if necessary.
513 (define-key map [rootmenu] (make-sparse-keymap))
514 (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM")))
515 (define-key map [rootmenu vm file] 'undefined)
516 (define-key map [rootmenu vm files] 'undefined)
517 (define-key map [rootmenu vm search] 'undefined)
518 (define-key map [rootmenu vm edit] 'undefined)
519 (define-key map [rootmenu vm options] 'undefined)
520 (define-key map [rootmenu vm buffer] 'undefined)
521 (define-key map [rootmenu vm tools] 'undefined)
522 (define-key map [rootmenu vm help] 'undefined)
523 ;; 19.29 changed the tag for the Help menu.
524 (define-key map [rootmenu vm help-menu] 'undefined)
525 ;; now build VM's menu tree.
526 (let ((menu-alist
527 '((dispose
528 (cons "Dispose" vm-menu-fsfemacs-dispose-menu))
529 (folder
530 (cons "Folder" vm-menu-fsfemacs-folder-menu))
531 (help
532 (cons "Help!" vm-menu-fsfemacs-help-menu))
533 (label
534 (cons "Label" vm-menu-fsfemacs-label-menu))
535 (mark
536 (cons "Mark" vm-menu-fsfemacs-mark-menu))
537 (motion
538 (cons "Motion" vm-menu-fsfemacs-motion-menu))
539 (send
540 (cons "Send" vm-menu-fsfemacs-send-menu))
541 (sort
542 (cons "Sort" vm-menu-fsfemacs-sort-menu))
543 (virtual
544 (cons "Virtual" vm-menu-fsfemacs-virtual-menu))
545 (emacs
546 (cons "[Emacs]" 'vm-menu-toggle-menubar))
547 (undo
548 (cons "[Undo]" 'vm-undo))))
549 cons
550 (vec (vector 'rootmenu 'vm nil))
551 ;; menus appear in the opposite order that we
552 ;; define-key them.
553 (menu-list
554 (if (consp vm-use-menus)
555 (reverse vm-use-menus)
556 (list 'help nil 'dispose 'undo 'virtual 'sort
557 'label 'mark 'send 'motion 'folder))))
558 (while menu-list
559 (if (null (car menu-list))
560 nil;; no flushright support in FSF Emacs
561 (aset vec 2 (intern (concat "vm-menubar-"
562 (symbol-name
563 (car menu-list)))))
564 (setq cons (assq (car menu-list) menu-alist))
565 (if cons
566 (define-key map vec (eval (car (cdr cons))))))
567 (setq menu-list (cdr menu-list))))
568 (setq vm-mode-menu-map map)
569 (run-hooks 'vm-menu-setup-hook))))
570
571 (defun vm-menu-make-xemacs-menubar ()
572 (let ((menu-alist
573 '((dispose . vm-menu-dispose-menu)
574 (folder . vm-menu-folder-menu)
575 (help . vm-menu-help-menu)
576 (label . vm-menu-label-menu)
577 (mark . vm-menu-mark-menu)
578 (motion . vm-menu-motion-menu)
579 (send . vm-menu-send-menu)
580 (sort . vm-menu-sort-menu)
581 (virtual . vm-menu-virtual-menu)
582 (emacs . vm-menu-emacs-button)
583 (undo . vm-menu-undo-menu)))
584 cons
585 (menubar nil)
586 (menu-list vm-use-menus))
587 (while menu-list
588 (if (null (car menu-list))
589 (setq menubar (cons nil menubar))
590 (setq cons (assq (car menu-list) menu-alist))
591 (if cons
592 (setq menubar (cons (symbol-value (cdr cons)) menubar))))
593 (setq menu-list (cdr menu-list)))
594 (nreverse menubar) ))
595
596 (defun vm-menu-popup-mode-menu (event)
597 (interactive "e")
598 (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
599 (set-buffer (window-buffer (event-window event)))
600 (and (event-point event) (goto-char (event-point event)))
601 (popup-mode-menu))
602 ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
603 (set-buffer (window-buffer (posn-window (event-start event))))
604 (goto-char (posn-point (event-start event)))
605 (vm-menu-popup-fsfemacs-menu event))))
606
607 (defun vm-menu-popup-context-menu (event)
608 (interactive "e")
609 ;; We should not need to do anything here for XEmacs. The
610 ;; default binding of mouse-3 is popup-mode-menu which does
611 ;; what we want for the normal case. For special contexts,
612 ;; like when the mouse is over an URL, XEmacs has local keymap
613 ;; support for extents. Any context sensitive area should be
614 ;; contained in an extent with a keymap that has mouse-3 bound
615 ;; to a function that will pop up a context sensitive menu.
616 (cond ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
617 (set-buffer (window-buffer (posn-window (event-start event))))
618 (goto-char (posn-point (event-start event)))
619 (let (o-list o menu (found nil))
620 (setq o-list (overlays-at (point)))
621 (while (and o-list (not found))
622 (cond ((overlay-get (car o-list) 'vm-url)
623 (setq found t)
624 (vm-menu-popup-url-browser-menu event))
625 ((setq menu (overlay-get (car o-list) 'vm-header))
626 (setq found t)
627 (vm-menu-popup-fsfemacs-menu event menu)))
628 (setq o-list (cdr o-list)))
629 (and (not found) (vm-menu-popup-fsfemacs-menu event))))))
630
631 ;; to quiet the byte-compiler
632 (defvar vm-menu-fsfemacs-url-browser-menu)
633
634 (defun vm-menu-popup-url-browser-menu (event)
635 (interactive "e")
636 (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
637 ;; Must select window instead of just set-buffer because
638 ;; popup-menu returns before the user has made a
639 ;; selection. This will cause the command loop to
640 ;; resume which might undo what set-buffer does.
641 (select-window (event-window event))
642 (and (event-point event) (goto-char (event-point event)))
643 (popup-menu vm-menu-url-browser-menu))
644 ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
645 (set-buffer (window-buffer (posn-window (event-start event))))
646 (goto-char (posn-point (event-start event)))
647 (vm-menu-popup-fsfemacs-menu
648 event vm-menu-fsfemacs-url-browser-menu))))
649
650 ;; to quiet the byte-compiler
651 (defvar vm-menu-fsfemacs-mail-menu)
652 (defvar vm-menu-fsfemacs-dispose-popup-menu)
653 (defvar vm-menu-fsfemacs-vm-menu)
654
655 (defun vm-menu-popup-fsfemacs-menu (event &optional menu)
656 (interactive "e")
657 (set-buffer (window-buffer (posn-window (event-start event))))
658 (goto-char (posn-point (event-start event)))
659 (let ((map (or menu mode-popup-menu))
660 key command func)
661 (setq key (x-popup-menu event map)
662 key (apply 'vector key)
663 command (lookup-key map key)
664 func (and (symbolp command) (symbol-function command)))
665 (cond ((null func) (setq this-command last-command))
666 ((symbolp func)
667 (setq this-command func)
668 (call-interactively this-command))
669 (t
670 (call-interactively command)))))
671
672 (defun vm-menu-mode-menu ()
673 (if (vm-menu-xemacs-menus-p)
674 (cond ((eq major-mode 'mail-mode)
675 vm-menu-mail-menu)
676 ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode))
677 vm-menu-dispose-menu)
678 (t vm-menu-vm-menu))
679 (cond ((eq major-mode 'mail-mode)
680 vm-menu-fsfemacs-mail-menu)
681 ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode))
682 vm-menu-fsfemacs-dispose-popup-menu)
683 (t vm-menu-fsfemacs-vm-menu))))
684
685 (defun vm-menu-set-menubar-dirty-flag ()
686 (cond ((vm-menu-xemacs-menus-p)
687 (set-menubar-dirty-flag))
688 ((vm-menu-fsfemacs-menus-p)
689 (force-mode-line-update))))
690
691 (defun vm-menu-toggle-menubar (&optional buffer)
692 (interactive)
693 (if buffer
694 (set-buffer buffer)
695 (vm-select-folder-buffer))
696 (cond ((vm-menu-xemacs-menus-p)
697 (if (null (car (find-menu-item current-menubar '("XEmacs"))))
698 (set-buffer-menubar vm-menu-vm-menubar)
699 (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
700 (condition-case nil
701 (add-menu-button nil vm-menu-vm-button nil)
702 (void-function
703 (add-menu-item nil "VM" 'vm-menu-toggle-menubar t))))
704 (vm-menu-set-menubar-dirty-flag)
705 (vm-check-for-killed-summary)
706 (and vm-summary-buffer
707 (vm-menu-toggle-menubar vm-summary-buffer)))
708 ((vm-menu-fsfemacs-menus-p)
709 (if (not (eq (lookup-key vm-mode-map [menu-bar])
710 (lookup-key vm-mode-menu-map [rootmenu vm])))
711 (define-key vm-mode-map [menu-bar]
712 (lookup-key vm-mode-menu-map [rootmenu vm]))
713 (define-key vm-mode-map [menu-bar]
714 (make-sparse-keymap))
715 (define-key vm-mode-map [menu-bar vm]
716 (cons "[VM]" 'vm-menu-toggle-menubar)))
717 (vm-menu-set-menubar-dirty-flag))))
718
719 (defun vm-menu-install-menubar ()
720 (cond ((vm-menu-xemacs-menus-p)
721 (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar))
722 (set-buffer-menubar vm-menu-vm-menubar))
723 ((and (vm-menu-fsfemacs-menus-p)
724 ;; menus only need to be installed once for FSF Emacs
725 (not (fboundp 'vm-menu-undo-menu)))
726 (vm-menu-initialize-vm-mode-menu-map)
727 (define-key vm-mode-map [menu-bar]
728 (lookup-key vm-mode-menu-map [rootmenu vm])))))
729
730 (defun vm-menu-install-menubar-item ()
731 (cond ((and (vm-menu-xemacs-menus-p) (vm-menu-xemacs-global-menubar))
732 (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
733 (add-menu nil "VM" (cdr vm-menu-vm-menu)))
734 ((and (vm-menu-fsfemacs-menus-p)
735 ;; menus only need to be installed once for FSF Emacs
736 (not (fboundp 'vm-menu-undo-menu)))
737 (vm-menu-initialize-vm-mode-menu-map)
738 (define-key vm-mode-map [menu-bar]
739 (lookup-key vm-mode-menu-map [rootmenu])))))
740
741 (defun vm-menu-install-vm-mode-menu ()
742 ;; nothing to do here.
743 ;; handled in vm-mouse.el
744 (cond ((vm-menu-xemacs-menus-p)
745 t )
746 ((vm-menu-fsfemacs-menus-p)
747 t )))
748
749 (defun vm-menu-install-mail-mode-menu ()
750 (cond ((vm-menu-xemacs-menus-p)
751 ;; mail-mode doesn't have mode-popup-menu bound to
752 ;; mouse-3 by default. fix that.
753 (define-key vm-mail-mode-map 'button3 'popup-mode-menu)
754 ;; put menu on menubar also.
755 (if (vm-menu-xemacs-global-menubar)
756 (progn
757 (set-buffer-menubar
758 (copy-sequence (vm-menu-xemacs-global-menubar)))
759 (add-menu nil "Mail" (cdr vm-menu-mail-menu))))
760 t )
761 ((vm-menu-fsfemacs-menus-p)
762 ;; I'd like to do this, but the result is a combination
763 ;; of the Emacs and VM Mail menus glued together.
764 ;; Poorly.
765 ;;(define-key vm-mail-mode-map [menu-bar mail]
766 ;; (cons "Mail" vm-menu-fsfemacs-mail-menu))
767 (define-key vm-mail-mode-map [down-mouse-3]
768 'vm-menu-popup-mode-menu))))
769
770 (defun vm-menu-install-menus ()
771 (cond ((consp vm-use-menus)
772 (vm-menu-install-vm-mode-menu)
773 (vm-menu-install-menubar)
774 (vm-menu-install-known-virtual-folders-menu))
775 ((eq vm-use-menus 1)
776 (vm-menu-install-vm-mode-menu)
777 (vm-menu-install-menubar-item)
778 (vm-menu-install-known-virtual-folders-menu))
779 (t nil)))
780
781 (defun vm-menu-install-known-virtual-folders-menu ()
782 (let ((folders (sort (mapcar 'car vm-virtual-folder-alist)
783 (function string-lessp)))
784 (menu nil)
785 tail
786 ;; special string indicating tail of Virtual menu
787 (special "-------"))
788 (while folders
789 (setq menu (cons (vector " "
790 (list 'vm-menu-run-command
791 ''vm-visit-virtual-folder (car folders))
792 t
793 (car folders))
794 menu)
795 folders (cdr folders)))
796 (and menu (setq menu (nreverse menu)
797 menu (nconc (list "Visit:" "---") menu)))
798 (setq tail (vm-member special vm-menu-virtual-menu))
799 (if (and menu tail)
800 (progn
801 (setcdr tail menu)
802 (vm-menu-set-menubar-dirty-flag)
803 (cond ((vm-menu-fsfemacs-menus-p)
804 (makunbound 'vm-menu-fsfemacs-virtual-menu)
805 (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu
806 (list (make-sparse-keymap))
807 nil
808 vm-menu-virtual-menu)
809 (define-key vm-mode-menu-map [rootmenu vm vm-menubar-virtual]
810 (cons "Virtual" vm-menu-fsfemacs-virtual-menu))))))))
811
812 (defun vm-menu-install-visited-folders-menu ()
813 (let ((folders (vm-delete-duplicates (copy-sequence vm-folder-history)))
814 (menu nil)
815 tail
816 spool-files
817 (i 0)
818 ;; special string indicating tail of Folder menu
819 (special "-------"))
820 (while (and folders (< i 10))
821 (setq menu (cons (vector " "
822 (list 'vm-menu-run-command
823 ''vm-visit-folder (car folders))
824 t
825 (car folders))
826 menu)
827 folders (cdr folders)
828 i (1+ i)))
829 (and menu (setq menu (nreverse menu)
830 menu (nconc (list "Visit:" "---") menu)))
831 (setq spool-files (vm-spool-files)
832 folders (cond ((and (consp spool-files)
833 (consp (car spool-files)))
834 (mapcar (function car) spool-files))
835 ((and (consp spool-files)
836 (stringp (car spool-files))
837 (stringp vm-primary-inbox))
838 (list vm-primary-inbox))
839 (t nil)))
840 (if (and menu folders)
841 (nconc menu (list "---" "---")))
842 (while folders
843 (setq menu (nconc menu
844 (list (vector " "
845 (list 'vm-menu-run-command
846 ''vm-visit-folder (car folders))
847 t
848 (car folders))))
849 folders (cdr folders)))
850 (setq tail (vm-member special vm-menu-folder-menu))
851 (if (and menu tail)
852 (progn
853 (setcdr tail menu)
854 (vm-menu-set-menubar-dirty-flag)
855 (cond ((vm-menu-fsfemacs-menus-p)
856 (makunbound 'vm-menu-fsfemacs-folder-menu)
857 (vm-easy-menu-define vm-menu-fsfemacs-folder-menu
858 (list (make-sparse-keymap))
859 nil
860 vm-menu-folder-menu)
861 (define-key vm-mode-menu-map [rootmenu vm vm-menubar-folder]
862 (cons "Folder" vm-menu-fsfemacs-folder-menu))))))))
863
864
865 ;;; Muenkel Folders menu code
866
867 (defvar vm-menu-hm-no-hidden-dirs t
868 "*Hidden directories are suppressed in the folder menus, if non nil.")
869
870 (defvar vm-menu-hm-hidden-file-list '("^\\..*" ".*\\.~[0-9]+~"))
871
872 (defun vm-menu-hm-delete-folder (folder)
873 "Query deletes a folder."
874 (interactive "fDelete folder: ")
875 (if (file-exists-p folder)
876 (if (y-or-n-p (concat "Delete the folder " folder " ? "))
877 (progn
878 (if (file-directory-p folder)
879 (delete-directory folder)
880 (delete-file folder))
881 (message "Folder deleted.")
882 (vm-menu-hm-make-folder-menu)
883 (vm-menu-hm-install-menu)
884 )
885 (message "Aborted"))
886 (error "Folder %s does not exist." folder)
887 (vm-menu-hm-make-folder-menu)
888 (vm-menu-hm-install-menu)
889 ))
890
891
892 (defun vm-menu-hm-rename-folder (folder)
893 "Rename a folder."
894 (interactive "fRename folder: ")
895 (if (file-exists-p folder)
896 (rename-file folder
897 (read-file-name (concat "Rename "
898 folder
899 " to ")
900 (directory-file-name folder)
901 folder))
902 (error "Folder %s does not exist." folder))
903 (vm-menu-hm-make-folder-menu)
904 (vm-menu-hm-install-menu)
905 )
906
907
908 (defun vm-menu-hm-create-dir (parent-dir)
909 "Create a subdir in PARENT-DIR."
910 (interactive "DCreate new directory in: ")
911 (make-directory
912 (expand-file-name (read-file-name "Create directory in %s called: "
913 (concat parent-dir
914 "/")))
915 t)
916 (vm-menu-hm-make-folder-menu)
917 (vm-menu-hm-install-menu)
918 )
919
920
921 (defun vm-menu-hm-make-folder-menu ()
922 "Makes a menu with the mail folders of the directory `vm-folder-directory'."
923 (interactive)
924 (vm-unsaved-message "Building folders menu...")
925 (let ((folder-list (vm-menu-hm-tree-make-file-list vm-folder-directory))
926 (inbox-list (if (listp (car vm-spool-files))
927 (mapcar 'car vm-spool-files)
928 (list vm-primary-inbox))))
929 (setq vm-menu-folders-menu
930 (cons "Manipulate Folders"
931 (list (cons "Visit Inboxes "
932 (vm-menu-hm-tree-make-menu
933 inbox-list
934 'vm-visit-folder
935 t))
936 (cons "Visit Folder "
937 (vm-menu-hm-tree-make-menu
938 folder-list
939 'vm-visit-folder
940 t
941 vm-menu-hm-no-hidden-dirs
942 vm-menu-hm-hidden-file-list))
943 (cons "Save Message "
944 (vm-menu-hm-tree-make-menu
945 folder-list
946 'vm-save-message
947 t
948 vm-menu-hm-no-hidden-dirs
949 vm-menu-hm-hidden-file-list))
950 "----"
951 (cons "Delete Folder "
952 (vm-menu-hm-tree-make-menu
953 folder-list
954 'vm-menu-hm-delete-folder
955 t
956 nil
957 nil
958 t
959 ))
960 (cons "Rename Folder "
961 (vm-menu-hm-tree-make-menu
962 folder-list
963 'vm-menu-hm-rename-folder
964 t
965 nil
966 nil
967 t
968 ))
969 (cons "Make New Directory in..."
970 (vm-menu-hm-tree-make-menu
971 (cons (list ".") folder-list)
972 'vm-menu-hm-create-dir
973 t
974 nil
975 '(".*")
976 t
977 ))
978 "----"
979 ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]
980 ))))
981 (vm-unsaved-message "Building folders menu... done")
982 (vm-menu-hm-install-menu))
983
984 (defun vm-menu-hm-install-menu ()
985 (cond ((vm-menu-xemacs-menus-p)
986 (cond ((car (find-menu-item current-menubar '("VM")))
987 (add-menu '("VM") "Folders"
988 (cdr vm-menu-folders-menu) "Motion"))
989 ((car (find-menu-item current-menubar
990 '("Folder" "Manipulate Folders")))
991 (add-menu '("Folder") "Manipulate Folders"
992 (cdr vm-menu-folders-menu) "Motion"))))
993 ((vm-menu-fsfemacs-menus-p)
994 (vm-easy-menu-define vm-menu-fsfemacs-folders-menu
995 (list (make-sparse-keymap))
996 nil
997 vm-menu-folders-menu)
998 (define-key vm-mode-menu-map [rootmenu vm folder folders]
999 (cons "Manipulate Folders" vm-menu-fsfemacs-folders-menu)))))
1000
1001
1002 ;;; Muenkel tree-menu code
1003
1004 (defvar vm-menu-hm-tree-ls-flags "-aFLR"
1005 "*A String with the flags used in the function
1006 vm-menu-hm-tree-ls-in-temp-buffer for the ls command.
1007 Be careful if you want to change this variable.
1008 The ls command must append a / on all files which are directories.
1009 The original flags are -aFLR.")
1010
1011
1012 (defun vm-menu-hm-tree-ls-in-temp-buffer (dir temp-buffer)
1013 "List the directory DIR in the TEMP-BUFFER."
1014 (switch-to-buffer temp-buffer)
1015 (erase-buffer)
1016 (let ((process-connection-type nil))
1017 (call-process "ls" nil temp-buffer nil vm-menu-hm-tree-ls-flags dir))
1018 (goto-char (point-min))
1019 (while (search-forward "//" nil t)
1020 (replace-match "/"))
1021 (goto-char (point-min))
1022 (while (re-search-forward "\\.\\.?/\n" nil t)
1023 (replace-match ""))
1024 (goto-char (point-min)))
1025
1026
1027 (defvar vm-menu-hm-tree-temp-buffername "*tree*"
1028 "Name of the temp buffers in tree.")
1029
1030
1031 (defun vm-menu-hm-tree-make-file-list-1 (root list)
1032 (let ((filename (buffer-substring (point) (progn
1033 (end-of-line)
1034 (point)))))
1035 (while (not (string= filename ""))
1036 (setq
1037 list
1038 (append
1039 list
1040 (list
1041 (cond ((char-equal (char-after (- (point) 1)) ?/)
1042 ;; Directory
1043 (setq filename (substring filename 0 (1- (length filename))))
1044 (save-excursion
1045 (search-forward (concat root filename ":"))
1046 (forward-line)
1047 (vm-menu-hm-tree-make-file-list-1 (concat root filename "/")
1048 (list (vm-menu-hm-tree-menu-file-truename
1049 filename
1050 root)))))
1051 ((char-equal (char-after (- (point) 1)) ?*)
1052 ;; Executable
1053 (setq filename (substring filename 0 (1- (length filename))))
1054 (vm-menu-hm-tree-menu-file-truename filename root))
1055 (t (vm-menu-hm-tree-menu-file-truename filename root))))))
1056 (forward-line)
1057 (setq filename (buffer-substring (point) (progn
1058 (end-of-line)
1059 (point)))))
1060 list))
1061
1062
1063 (defun vm-menu-hm-tree-menu-file-truename (file &optional root)
1064 (file-truename (expand-file-name file root)))
1065
1066 (defun vm-menu-hm-tree-make-file-list (dir)
1067 "Makes a list with the files and subdirectories of DIR.
1068 The list looks like: ((dirname1 file1 file2)
1069 file3
1070 (dirname2 (dirname3 file4 file5) file6))"
1071 (save-window-excursion
1072 (setq dir (expand-file-name dir))
1073 (if (not (string= (substring dir -1) "/"))
1074 (setq dir (concat dir "/")))
1075 ;; (while (string-match "/$" dir)
1076 ;; (setq dir (substring dir 0 -1)))
1077 (vm-menu-hm-tree-ls-in-temp-buffer dir
1078 (generate-new-buffer-name
1079 vm-menu-hm-tree-temp-buffername))
1080 (let ((list nil))
1081 (setq list (vm-menu-hm-tree-make-file-list-1 dir nil))
1082 (kill-buffer (current-buffer))
1083 list)))
1084
1085
1086 (defun vm-menu-hm-tree-hide-file-p (filename re-hidden-file-list)
1087 "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME."
1088 (cond ((not re-hidden-file-list) nil)
1089 ((string-match (car re-hidden-file-list)
1090 (vm-menu-hm-tree-menu-file-truename filename)))
1091 (t (vm-menu-hm-tree-hide-file-p filename (cdr re-hidden-file-list)))))
1092
1093
1094 (defun vm-menu-hm-tree-make-menu (dirlist
1095 function
1096 selectable
1097 &optional
1098 no-hidden-dirs
1099 re-hidden-file-list
1100 include-current-dir)
1101 "Returns a menu list.
1102 Each item of the menu list has the form
1103 [\"subdir\" (FUNCTION \"dir\") SELECTABLE].
1104 Hidden directories (with a leading point) are suppressed,
1105 if NO-HIDDEN-DIRS are non nil. Also all files which are
1106 matching a regexp in RE-HIDDEN-FILE-LIST are suppressed.
1107 If INCLUDE-CURRENT-DIR non nil, then an additional command
1108 for the current directory (.) is inserted."
1109 (let ((subdir nil)
1110 (menulist nil))
1111 (while (setq subdir (car dirlist))
1112 (setq dirlist (cdr dirlist))
1113 (cond ((and (stringp subdir)
1114 (not (vm-menu-hm-tree-hide-file-p subdir re-hidden-file-list)))
1115 (setq menulist
1116 (append menulist
1117 (list
1118 (vector (file-name-nondirectory subdir)
1119 (list function subdir)
1120 selectable)))))
1121 ((and (listp subdir)
1122 (or (not no-hidden-dirs)
1123 (not (char-equal
1124 ?.
1125 (string-to-char
1126 (file-name-nondirectory (car subdir))))))
1127 (setq menulist
1128 (append
1129 menulist
1130 (list
1131 (cons (file-name-nondirectory (car subdir))
1132 (if include-current-dir
1133 (cons
1134 (vector "."
1135 (list function
1136 (car subdir))
1137 selectable)
1138 (vm-menu-hm-tree-make-menu (cdr subdir)
1139 function
1140 selectable
1141 no-hidden-dirs
1142 re-hidden-file-list
1143 include-current-dir
1144 ))
1145 (vm-menu-hm-tree-make-menu (cdr subdir)
1146 function
1147 selectable
1148 no-hidden-dirs
1149 re-hidden-file-list
1150 ))))))))
1151 (t nil))
1152 )
1153 menulist
1154 )
1155 )