cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-menu.el

   1 ;;; vm-menu.el --- Menu related functions and commands
   2 ;;
   3 ;; Copyright (C) 1994 Heiko Muenkel
   4 ;; Copyright (C) 1995, 1997 Kyle E. Jones
   5 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   6 ;;
   7 ;;
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12 ;;
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17 ;;
  18 ;; You should have received a copy of the GNU General Public License along
  19 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  20 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  21 ;;
  22 ;;; History:
  23 ;;
  24 ;; Folders menu derived from
  25 ;;     vm-folder-menu.el
  26 ;;     v1.10; 03-May-1994
  27 ;;     Copyright (C) 1994 Heiko Muenkel
  28 ;;     email: muenkel@tnt.uni-hannover.de
  29 ;;  Used with permission and my thanks.
  30 ;;  Changed 18-May-1995, Kyle Jones
  31 ;;     Cosmetic string changes, changed some variable names
  32 ;;     and interfaced it with FSF Emacs via easymenu.el.
  33 ;;
  34 ;; Tree menu code is essentially tree-menu.el with renamed functions
  35 ;;     tree-menu.el
  36 ;;     v1.20; 10-May-1994
  37 ;;     Copyright (C) 1994 Heiko Muenkel
  38 ;;     email: muenkel@tnt.uni-hannover.de
  39 ;;
  40 ;;  Changed 18-May-1995, Kyle Jones
  41 ;;    Removed the need for the utils.el package and references thereto.
  42 ;;    Changed file-truename calls to tree-menu-file-truename so
  43 ;;    the calls could be made compatible with FSF Emacs 19's
  44 ;;    file-truename function.
  45 ;;  Changed 30-May-1995, Kyle Jones
  46 ;;    Renamed functions: tree- -> vm-menu-hm-tree.
  47 ;;  Changed 5-July-1995, Kyle Jones
  48 ;;    Removed the need for -A in ls flags.
  49 ;;    Some systems' ls don't support -A.
  50
  51 (eval-when-compile
  52   (defvar current-menubar nil))
  53
  54 ;;; Code:
  55 (defvar vm-menu-folders-menu
  56   '("Manipulate Folders"
  57     ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory])
  58   "VM folder menu list.")
  59
  60 (defvar vm-menu-folder-menu
  61   `("Folder"
  62     ,(if vm-fsfemacs-p
  63         ["Manipulate Folders" ignore (ignore)]
  64       vm-menu-folders-menu)
  65     "---"
  66     ["Display Summary" vm-summarize t]
  67     ["Toggle Threading" vm-toggle-threads-display t]
  68     "---"
  69     ["Get New Mail" vm-get-new-mail (vm-menu-can-get-new-mail-p)]
  70     "---"
  71     ["Search" vm-isearch-forward vm-message-list]
  72     "---"
  73     ["Auto-Archive" vm-auto-archive-messages vm-message-list]
  74     ["Expunge" vm-expunge-folder vm-message-list]
  75     ["Expunge POP Messages" vm-expunge-pop-messages
  76      (vm-menu-can-expunge-pop-messages-p)]
  77     ["Expunge IMAP Messages" vm-expunge-pop-messages
  78      (vm-menu-can-expunge-imap-messages-p)]
  79     "---"
  80     ["Visit Local Folder" vm-visit-folder t]
  81     ["Visit POP Folder" vm-visit-pop-folder vm-pop-folder-alist]
  82     ["Visit IMAP Folder" vm-visit-imap-folder vm-imap-server-list]
  83     ["Revert Folder (back to disk version)" vm-revert-buffer
  84      (vm-menu-can-revert-p)]
  85     ["Recover Folder (from auto-save file)" vm-recover-file
  86      (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 (defvar vm-menu-dispose-menu
  99   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 100                    (list "Dispose"
 101                          "Dispose"
 102                          "---"
 103                          "---")
 104                  (list "Dispose"))))
 105     `(,@title
 106       ["Reply to Author" vm-reply vm-message-list]
 107       ["Reply to All" vm-followup vm-message-list]
 108       ["Reply to Author (citing original)" vm-reply-include-text
 109        vm-message-list]
 110       ["Reply to All (citing original)" vm-followup-include-text
 111        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       ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)]
 127       )))
 128
 129 (defvar vm-menu-motion-menu
 130   '("Motion"
 131     ["Page Up" vm-scroll-backward vm-message-list]
 132     ["Page Down" vm-scroll-forward vm-message-list]
 133     "----"
 134     ["Beginning" vm-beginning-of-message vm-message-list]
 135     ["End" vm-end-of-message vm-message-list]
 136     "----"
 137     ["Expose/Hide Headers" vm-expose-hidden-headers vm-message-list]
 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 (defvar vm-menu-virtual-menu
 157   '("Virtual"
 158     ["Visit Virtual Folder" vm-visit-virtual-folder t]
 159     ["Visit Virtual Folder Same Author" vm-visit-virtual-folder-same-author t]
 160     ["Visit Virtual Folder Same Subject" vm-visit-virtual-folder-same-subject t]
 161     ["Create Virtual Folder" vm-create-virtual-folder t]
 162     ["Apply Virtual Folder" vm-apply-virtual-folder t]
 163     "---"
 164     "---"
 165     ;; special string that marks the tail of this menu for
 166     ;; vm-menu-install-known-virtual-folders-menu.
 167     "-------"
 168     ))
 169
 170 (defvar vm-menu-send-menu
 171   '("Send"
 172     ["Compose" vm-mail t]
 173     ["Continue Composing" vm-continue-composing-message vm-message-list]
 174     ["Reply to Author" vm-reply vm-message-list]
 175     ["Reply to All" vm-followup vm-message-list]
 176     ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
 177     ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
 178     ["Forward Message" vm-forward-message vm-message-list]
 179     ["Resend Message" vm-resend-message vm-message-list]
 180     ["Retry Bounced Message" vm-resend-bounced-message vm-message-list]
 181     ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list]
 182     ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list]
 183     ["Send MIME Digest" vm-send-mime-digest vm-message-list]
 184     ))
 185
 186 (defvar vm-menu-mark-menu
 187   '("Mark"
 188     ["Next Command Uses Marks..." vm-next-command-uses-marks
 189      :active vm-message-list
 190      :style radio
 191      :selected (eq last-command 'vm-next-command-uses-marks)]
 192     "----"
 193     ["Mark" vm-mark-message vm-message-list]
 194     ["Unmark" vm-unmark-message vm-message-list]
 195     ["Mark All" vm-mark-all-messages vm-message-list]
 196     ["Clear All Marks" vm-clear-all-marks vm-message-list]
 197     ["Mark Region in Summary" vm-mark-summary-region vm-message-list]
 198     ["Unmark Region in Summary" vm-unmark-summary-region vm-message-list]
 199     "----"
 200     ["Mark Same Subject" vm-mark-messages-same-subject vm-message-list]
 201     ["Unmark Same Subject" vm-unmark-messages-same-subject vm-message-list]
 202     ["Mark Same Author" vm-mark-messages-same-author vm-message-list]
 203     ["Unmark Same Author" vm-unmark-messages-same-author vm-message-list]
 204     ["Mark Messages Matching..." vm-mark-matching-messages vm-message-list]
 205     ["Unmark Messages Matching..." vm-unmark-matching-messages vm-message-list]
 206     ["Mark Thread Subtree" vm-mark-thread-subtree vm-message-list]
 207     ["Unmark Thread Subtree" vm-unmark-thread-subtree vm-message-list]
 208     ))
 209
 210 (defvar vm-menu-label-menu
 211   '("Label"
 212     ["Add Label" vm-add-message-labels vm-message-list]
 213     ["Add Existing Label" vm-add-existing-message-labels vm-message-list]
 214     ["Remove Label" vm-delete-message-labels vm-message-list]
 215     ))
 216
 217 (defvar vm-menu-sort-menu
 218   '("Sort"
 219     ["By Multiple Fields..." vm-sort-messages vm-message-list]
 220     "---"
 221     ["By Date" (vm-sort-messages "date") vm-message-list]
 222     ["By Subject" (vm-sort-messages "subject") vm-message-list]
 223     ["By Author" (vm-sort-messages "author") vm-message-list]
 224     ["By Recipients" (vm-sort-messages "recipients") vm-message-list]
 225     ["By Lines" (vm-sort-messages "line-count") vm-message-list]
 226     ["By Bytes" (vm-sort-messages "byte-count") vm-message-list]
 227     "---"
 228     ["By Date (backward)" (vm-sort-messages "reversed-date") vm-message-list]
 229     ["By Subject (backward)" (vm-sort-messages "reversed-subject") vm-message-list]
 230     ["By Author (backward)" (vm-sort-messages "reversed-author") vm-message-list]
 231     ["By Recipients (backward)" (vm-sort-messages "reversed-recipients") vm-message-list]
 232     ["By Lines (backward)" (vm-sort-messages "reversed-line-count") vm-message-list]
 233     ["By Bytes (backward)" (vm-sort-messages "reversed-byte-count") vm-message-list]
 234     "---"
 235     ["Toggle Threading" vm-toggle-threads-display t]
 236     "---"
 237     ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list]
 238     ))
 239
 240 (defvar vm-menu-help-menu
 241   '("Help"
 242     ["Switch to Emacs Toolbar" vm-menu-toggle-menubar]
 243     "---"
 244     ["What Now?" vm-help t]
 245     ["Describe Mode" describe-mode t]
 246     ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
 247     ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
 248     "---"
 249     ["Save Folder & Quit" vm-quit t]
 250     ["Quit Without Saving" vm-quit-no-change t]
 251     ))
 252
 253 (defvar vm-menu-undo-menu
 254   ["Undo" vm-undo (vm-menu-can-undo-p)]
 255   )
 256
 257 (defvar vm-menu-emacs-button
 258   ["XEmacs" vm-menu-toggle-menubar t]
 259   )
 260
 261 (defvar vm-menu-vm-button
 262   ["VM" vm-menu-toggle-menubar t]
 263   )
 264
 265 (defvar vm-menu-mail-menu
 266   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 267                    (list "Mail Commands"
 268                          "Mail Commands"
 269                          "---"
 270                          "---")
 271                  (list "Mail Commands"))))
 272     `(,@title
 273       ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)]
 274       ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)]
 275       ["Cancel" kill-buffer t]
 276       "----"
 277       ["Yank Original" vm-menu-yank-original vm-reply-list]
 278       "----"
 279       (
 280        ,@(if (vm-menu-fsfemacs19-menus-p)
 281              (list "Send Using MIME..."
 282                    "Send Using MIME..."
 283                    "---"
 284                    "---")
 285            (list "Send Using MIME..."))
 286        ["Use MIME"
 287         (progn (set (make-local-variable 'vm-send-using-mime) t)
 288                (vm-mail-mode-remove-tm-hooks))
 289         :active t
 290         :style radio
 291         :selected vm-send-using-mime]
 292        ["Don't use MIME"
 293         (set (make-local-variable 'vm-send-using-mime) nil)
 294         :active t
 295         :style radio
 296         :selected (not vm-send-using-mime)])
 297       (
 298        ,@(if (vm-menu-fsfemacs19-menus-p)
 299              (list "Fragment Messages Larger Than ..."
 300                    "Fragment Messages Larger Than ..."
 301                    "---"
 302                    "---")
 303            (list "Fragment Messages Larger Than ..."))
 304        ["Infinity, i.e., don't fragment"
 305         (set (make-local-variable 'vm-mime-max-message-size) nil)
 306         :active vm-send-using-mime
 307         :style radio
 308         :selected (eq vm-mime-max-message-size nil)]
 309        ["50000 bytes"
 310         (set (make-local-variable 'vm-mime-max-message-size)
 311              50000)
 312         :active vm-send-using-mime
 313         :style radio
 314         :selected (eq vm-mime-max-message-size 50000)]
 315        ["100000 bytes"
 316         (set (make-local-variable 'vm-mime-max-message-size)
 317              100000)
 318         :active vm-send-using-mime
 319         :style radio
 320         :selected (eq vm-mime-max-message-size 100000)]
 321        ["200000 bytes"
 322         (set (make-local-variable 'vm-mime-max-message-size)
 323              200000)
 324         :active vm-send-using-mime
 325         :style radio
 326         :selected (eq vm-mime-max-message-size 200000)]
 327        ["500000 bytes"
 328         (set (make-local-variable 'vm-mime-max-message-size)
 329              500000)
 330         :active vm-send-using-mime
 331         :style radio
 332         :selected (eq vm-mime-max-message-size 500000)]
 333        ["1000000 bytes"
 334         (set (make-local-variable 'vm-mime-max-message-size)
 335              1000000)
 336         :active vm-send-using-mime
 337         :style radio
 338         :selected (eq vm-mime-max-message-size 1000000)]
 339        ["2000000 bytes"
 340         (set (make-local-variable 'vm-mime-max-message-size)
 341              2000000)
 342         :active vm-send-using-mime
 343         :style radio
 344         :selected (eq vm-mime-max-message-size 2000000)])
 345       (
 346        ,@(if (vm-menu-fsfemacs19-menus-p)
 347              (list "Encode 8-bit Characters Using ..."
 348                    "Encode 8-bit Characters Using ..."
 349                    "---"
 350                    "---")
 351            (list "Encode 8-bit Characters Using ..."))
 352        ["Nothing, i.e., send unencoded"
 353         (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding)
 354              '8bit)
 355         :active vm-send-using-mime
 356         :style radio
 357         :selected (eq vm-mime-8bit-text-transfer-encoding '8bit)]
 358        ["Quoted-Printable"
 359         (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding)
 360              'quoted-printable)
 361         :active vm-send-using-mime
 362         :style radio
 363         :selected (eq vm-mime-8bit-text-transfer-encoding
 364                       'quoted-printable)]
 365        ["BASE64"
 366         (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding)
 367              'base64)
 368         :active vm-send-using-mime
 369         :style radio
 370         :selected (eq vm-mime-8bit-text-transfer-encoding 'base64)])
 371       "----"
 372       ["Attach File..." vm-mime-attach-file vm-send-using-mime]
 373       ["Attach MIME Message..." vm-mime-attach-mime-file vm-send-using-mime]
 374       ["Encode MIME, But Don't Send" vm-mime-encode-composition
 375        (and vm-send-using-mime
 376             (null (vm-mail-mode-get-header-contents "MIME-Version:")))]
 377       ["Preview MIME Before Sending" vm-mime-preview-composition
 378        vm-send-using-mime]
 379       )))
 380
 381 (defvar vm-menu-mime-dispose-menu
 382   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 383                    (list "Take Action on MIME body ..."
 384                          "Take Action on MIME body ..."
 385                          "---"
 386                          "---")
 387                  (list "Take Action on MIME body ..."))))
 388     `(,@title
 389       ["Display as Text (in default face)"
 390        (vm-mime-run-display-function-at-point
 391         'vm-mime-display-body-as-text) t]
 392       ["Display using External Viewer"
 393        (vm-mime-run-display-function-at-point
 394         'vm-mime-display-body-using-external-viewer) t]
 395       ;; FSF Emacs does not allow a non-string menu element name.
 396       ,@(if (vm-menu-can-eval-item-name)
 397             (list [(format "Convert to %s and Display"
 398                            (or (nth 1 (vm-mime-can-convert
 399                                        (car
 400                                         (vm-mm-layout-type
 401                                          (vm-mime-get-button-layout e)))))
 402                                "different type"))
 403                    (vm-mime-run-display-function-at-point
 404                     'vm-mime-convert-body-then-display)
 405                    (vm-mime-can-convert
 406                     (car (vm-mm-layout-type
 407                           (vm-mime-get-button-layout e))))]))
 408       "---"
 409       ["Undo" vm-undo]
 410       "---"
 411       ["Save to File" vm-mime-reader-map-save-file t]
 412       ["Save to Folder" vm-mime-reader-map-save-message
 413        (let ((layout (vm-mime-run-display-function-at-point
 414                       (function
 415                        (lambda (e)
 416                          (vm-extent-property e 'vm-mime-layout))))))
 417          (if (null layout)
 418              nil
 419            (or (vm-mime-types-match "message/rfc822"
 420                                     (car (vm-mm-layout-type layout)))
 421                (vm-mime-types-match "message/news"
 422                                     (car (vm-mm-layout-type layout))))))]
 423       ["Send to Printer" (vm-mime-run-display-function-at-point
 424                           'vm-mime-send-body-to-printer) t]
 425       ["Pipe to Shell Command (display output)"
 426        (vm-mime-run-display-function-at-point
 427         'vm-mime-pipe-body-to-queried-command) t]
 428       ["Pipe to Shell Command (discard output)"
 429        (vm-mime-run-display-function-at-point
 430         'vm-mime-pipe-body-to-queried-command-discard-output) t]
 431       ["Attach to Message Composition Buffer"
 432        vm-mime-attach-object-from-message t]
 433       ["Delete" vm-delete-mime-object t])))
 434
 435 (defvar vm-menu-url-browser-menu
 436   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 437                    (list "Send URL to ..."
 438                          "Send URL to ..."
 439                          "---"
 440                          "---")
 441                  (list "Send URL to ...")))
 442         (w3 (cond ((fboundp 'w3-fetch-other-frame)
 443                    'w3-fetch-other-frame)
 444                   ((fboundp 'w3-fetch)
 445                    'w3-fetch)
 446                   (t 'w3-fetch-other-frame))))
 447     `(,@title
 448       ["Emacs W3" (vm-mouse-send-url-at-position (point) (quote ,w3))
 449        (fboundp (quote ,w3))]
 450       ["Mosaic"
 451        (vm-mouse-send-url-at-position (point)
 452                                       'vm-mouse-send-url-to-mosaic)
 453        t]
 454       ["mMosaic"
 455        (vm-mouse-send-url-at-position (point)
 456                                       'vm-mouse-send-url-to-mmosaic)
 457        t]
 458       ["Netscape"
 459        (vm-mouse-send-url-at-position (point)
 460                                       'vm-mouse-send-url-to-netscape)
 461        t]
 462       ["Konqueror"
 463        (vm-mouse-send-url-at-position (point)
 464                                       'vm-mouse-send-url-to-konqueror)
 465        t]
 466       ["X Clipboard"
 467        (vm-mouse-send-url-at-position (point)
 468                                       'vm-mouse-send-url-to-clipboard)
 469        t])))
 470
 471 (defvar vm-menu-mailto-url-browser-menu
 472   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 473                    (list "Send Mail using ..."
 474                          "Send Mail using ..."
 475                          "---"
 476                          "---")
 477                  (list "Send Mail using ..."))))
 478     `(,@title
 479       ["VM" (vm-mouse-send-url-at-position (point) 'ignore) t])))
 480
 481 (defvar vm-menu-subject-menu
 482   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 483                    (list "Take Action on Subject..."
 484                          "Take Action on Subject..."
 485                          "---"
 486                          "---")
 487                  (list "Take Action on Subject..."))))
 488     `(,@title
 489       ["Kill Subject" vm-kill-subject vm-message-list]
 490       ["Next Message, Same Subject" vm-next-message-same-subject
 491        vm-message-list]
 492       ["Previous Message, Same Subject" vm-previous-message-same-subject
 493        vm-message-list]
 494       ["Mark Messages, Same Subject" vm-mark-messages-same-subject
 495        vm-message-list]
 496       ["Unmark Messages, Same Subject" vm-unmark-messages-same-subject
 497        vm-message-list]
 498       ["Virtual Folder, Matching Subject" vm-menu-create-subject-virtual-folder
 499        vm-message-list]
 500       )))
 501
 502 (defvar vm-menu-author-menu
 503   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 504                    (list "Take Action on Author..."
 505                          "Take Action on Author..."
 506                          "---"
 507                          "---")
 508                  (list "Take Action on Author..."))))
 509     `(,@title
 510       ["Mark Messages, Same Author" vm-mark-messages-same-author
 511        vm-message-list]
 512       ["Unmark Messages, Same Author" vm-unmark-messages-same-author
 513        vm-message-list]
 514       ["Virtual Folder, Matching Author" vm-menu-create-author-virtual-folder
 515        vm-message-list]
 516       )))
 517
 518 (defvar vm-menu-attachment-menu
 519   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 520                    (list "Fiddle With Attachment"
 521                          "Fiddle With Attachment"
 522                          "---"
 523                          "---")
 524                  (list "Fiddle With Attachment"))))
 525     `(,@title
 526       (
 527        ,@(if (vm-menu-fsfemacs19-menus-p)
 528              (list "Set Content Disposition..."
 529                    "Set Content Disposition..."
 530                    "---"
 531                    "---")
 532            (list "Set Content Disposition..."))
 533          ["Unspecified"
 534           (vm-mime-set-attachment-disposition-at-point 'unspecified)
 535           :active vm-send-using-mime
 536           :style radio
 537           :selected (eq (vm-mime-attachment-disposition-at-point)
 538                         'unspecified)]
 539          ["Inline"
 540           (vm-mime-set-attachment-disposition-at-point 'inline)
 541           :active vm-send-using-mime
 542           :style radio
 543           :selected (eq (vm-mime-attachment-disposition-at-point) 'inline)]
 544          ["Attachment"
 545           (vm-mime-set-attachment-disposition-at-point 'attachment)
 546           :active vm-send-using-mime
 547           :style radio
 548           :selected (eq (vm-mime-attachment-disposition-at-point)
 549                         'attachment)])
 550       (
 551        ,@(if (vm-menu-fsfemacs19-menus-p)
 552              (list "Set Content Encoding..."
 553                    "Set Content Encoding..."
 554                    "---"
 555                    "---")
 556            (list "Set Content Encoding..."))
 557          ["Guess"
 558           (vm-mime-set-attachment-encoding-at-point "guess")
 559           :active vm-send-using-mime
 560           :style radio
 561           :selected (eq (vm-mime-attachment-encoding-at-point) nil)]
 562          ["Binary"
 563           (vm-mime-set-attachment-encoding-at-point "binary")
 564           :active vm-send-using-mime
 565           :style radio
 566           :selected (string= (vm-mime-attachment-encoding-at-point) "binary")]
 567          ["7bit"
 568           (vm-mime-set-attachment-encoding-at-point "7bit")
 569           :active vm-send-using-mime
 570           :style radio
 571           :selected (string= (vm-mime-attachment-encoding-at-point) "7bit")]
 572          ["8bit"
 573           (vm-mime-set-attachment-encoding-at-point "8bit")
 574           :active vm-send-using-mime
 575           :style radio
 576           :selected (string= (vm-mime-attachment-encoding-at-point) "8bit")]
 577          ["quoted-printable"
 578           (vm-mime-set-attachment-encoding-at-point "quoted-printable")
 579           :active vm-send-using-mime
 580           :style radio
 581           :selected (string= (vm-mime-attachment-encoding-at-point) "quoted-printable")]
 582          )
 583       (
 584        ,@(if (vm-menu-fsfemacs19-menus-p)
 585              (list "Forward Local External Bodies"
 586                    "Forward Local External Bodies"
 587                    "---"
 588                    "---")
 589            (list "Forward Local External Bodies"))
 590          ["Forward Unchanged"
 591           (vm-mime-set-attachment-forward-local-refs-at-point t)
 592           :active vm-send-using-mime
 593           :style radio
 594           :selected (vm-mime-attachment-forward-local-refs-at-point)]
 595          ["Convert to Internal Object"
 596           (vm-mime-set-attachment-forward-local-refs-at-point nil)
 597           :active vm-send-using-mime
 598           :style radio
 599           :selected (not (vm-mime-attachment-forward-local-refs-at-point))])
 600       ["Delete"
 601        (vm-mime-delete-attachment-button)
 602        :style button]
 603       ["Delete, but keep infos"
 604        (vm-mime-delete-attachment-button-keep-infos)
 605        :style button]
 606       )))
 607
 608 (defvar vm-menu-image-menu
 609   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 610                    (list "Redisplay Image"
 611                          "Redisplay Image"
 612                          "---"
 613                          "---")
 614                  (list "Redisplay Image"))))
 615     `(,@title
 616       ["4x Larger"
 617        (vm-mime-run-display-function-at-point 'vm-mime-larger-image)
 618        (stringp vm-imagemagick-convert-program)]
 619       ["4x Smaller"
 620        (vm-mime-run-display-function-at-point 'vm-mime-smaller-image)
 621        (stringp vm-imagemagick-convert-program)]
 622       ["Rotate Left"
 623        (vm-mime-run-display-function-at-point 'vm-mime-rotate-image-left)
 624        (stringp vm-imagemagick-convert-program)]
 625       ["Rotate Right"
 626        (vm-mime-run-display-function-at-point 'vm-mime-rotate-image-right)
 627        (stringp vm-imagemagick-convert-program)]
 628       ["Mirror"
 629        (vm-mime-run-display-function-at-point 'vm-mime-mirror-image)
 630        (stringp vm-imagemagick-convert-program)]
 631       ["Brighter"
 632        (vm-mime-run-display-function-at-point 'vm-mime-brighten-image)
 633        (stringp vm-imagemagick-convert-program)]
 634       ["Dimmer"
 635        (vm-mime-run-display-function-at-point 'vm-mime-dim-image)
 636        (stringp vm-imagemagick-convert-program)]
 637       ["Monochrome"
 638        (vm-mime-run-display-function-at-point 'vm-mime-monochrome-image)
 639        (stringp vm-imagemagick-convert-program)]
 640       ["Revert to Original"
 641        (vm-mime-run-display-function-at-point 'vm-mime-revert-image)
 642        (get
 643         (vm-mm-layout-cache
 644          (vm-extent-property (vm-find-layout-extent-at-point) 'vm-mime-layout))
 645         'vm-image-modified)]
 646       )))
 647
 648 (defvar vm-menu-vm-menubar nil)
 649
 650 (defvar vm-menu-vm-menu
 651   (let ((title (if (vm-menu-fsfemacs19-menus-p)
 652                    (list "VM"
 653                          "VM"
 654                          "---"
 655                          "---")
 656                  (list "VM"))))
 657     `(,@title
 658       ,vm-menu-folder-menu
 659       ,vm-menu-motion-menu
 660       ,vm-menu-send-menu
 661       ,vm-menu-mark-menu
 662       ,vm-menu-label-menu
 663       ,vm-menu-sort-menu
 664       ,vm-menu-virtual-menu
 665 ;;    ,vm-menu-undo-menu
 666       ,vm-menu-dispose-menu
 667       "---"
 668       "---"
 669       ,vm-menu-help-menu)))
 670
 671 (defvar vm-mode-menu-map nil)
 672
 673 (defun vm-menu-run-command (command &rest args)
 674   "Run COMMAND almost interactively, with ARGS.
 675 call-interactive can't be used unfortunately, but this-command is
 676 set to the command name so that window configuration will be done."
 677   (setq this-command command)
 678   (apply command args))
 679
 680 (defun vm-menu-can-revert-p ()
 681   (condition-case nil
 682       (save-excursion
 683         (vm-select-folder-buffer)
 684         (and (buffer-modified-p) buffer-file-name))
 685     (error nil)))
 686
 687 (defun vm-menu-can-recover-p ()
 688   (condition-case nil
 689       (save-excursion
 690         (vm-select-folder-buffer)
 691         (and buffer-file-name
 692              buffer-auto-save-file-name
 693              (file-newer-than-file-p
 694               buffer-auto-save-file-name
 695               buffer-file-name)))
 696     (error nil)))
 697
 698 (defun vm-menu-can-save-p ()
 699   (condition-case nil
 700       (save-excursion
 701         (vm-select-folder-buffer)
 702         (or (eq major-mode 'vm-virtual-mode)
 703             (buffer-modified-p)))
 704     (error nil)))
 705
 706 (defun vm-menu-can-get-new-mail-p ()
 707   (condition-case nil
 708       (save-excursion
 709         (vm-select-folder-buffer)
 710         (or (eq major-mode 'vm-virtual-mode)
 711             (and (not vm-block-new-mail) (not vm-folder-read-only))))
 712     (error nil)))
 713
 714 (defun vm-menu-can-undo-p ()
 715   (condition-case nil
 716       (save-excursion
 717         (vm-select-folder-buffer)
 718         vm-undo-record-list)
 719     (error nil)))
 720
 721 (defun vm-menu-can-decode-mime-p ()
 722   (condition-case nil
 723       (save-excursion
 724         (vm-select-folder-buffer)
 725         (and vm-display-using-mime
 726              vm-message-pointer
 727              vm-presentation-buffer
 728 ;;           (not vm-mime-decoded)
 729              (not (vm-mime-plain-message-p (car vm-message-pointer)))))
 730     (error nil)))
 731
 732 (defun vm-menu-can-expunge-pop-messages-p ()
 733   (condition-case nil
 734       (save-excursion
 735         (vm-select-folder-buffer)
 736         (not (eq vm-folder-access-method 'pop)))
 737     (error nil)))
 738
 739 (defun vm-menu-can-expunge-imap-messages-p ()
 740   (condition-case nil
 741       (save-excursion
 742         (vm-select-folder-buffer)
 743         (not (eq vm-folder-access-method 'imap)))
 744     (error nil)))
 745
 746 (defun vm-menu-yank-original ()
 747   (interactive)
 748   (save-excursion
 749     (let ((mlist vm-reply-list))
 750       (while mlist
 751         (vm-yank-message (car mlist))
 752         (goto-char (point-max))
 753         (setq mlist (cdr mlist))))))
 754
 755 (defun vm-menu-can-send-mail-p ()
 756   (save-match-data
 757     (catch 'done
 758       (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc"))
 759             h)
 760         (while headers
 761           (setq h (vm-mail-mode-get-header-contents (car headers)))
 762           (and (stringp h) (string-match "[^ \t\n,]" h)
 763                (throw 'done t))
 764           (setq headers (cdr headers)))
 765         nil ))))
 766
 767 (defun vm-menu-create-subject-virtual-folder ()
 768   (interactive)
 769   (vm-select-folder-buffer)
 770   (setq this-command 'vm-create-virtual-folder)
 771   (vm-create-virtual-folder 'sortable-subject (regexp-quote
 772                                        (vm-so-sortable-subject
 773                                         (car vm-message-pointer)))))
 774
 775 (defun vm-menu-create-author-virtual-folder ()
 776   (interactive)
 777   (vm-select-folder-buffer)
 778   (setq this-command 'vm-create-virtual-folder)
 779   (vm-create-virtual-folder 'author (regexp-quote
 780                                      (vm-su-from (car vm-message-pointer)))))
 781
 782 (defun vm-menu-xemacs-global-menubar ()
 783   (save-excursion
 784     (set-buffer (get-buffer-create "*scratch*"))
 785     current-menubar))
 786
 787 (defun vm-menu-fsfemacs-global-menubar ()
 788   (lookup-key (current-global-map) [menu-bar]))
 789
 790 (defun vm-menu-initialize-vm-mode-menu-map ()
 791   (if (null vm-mode-menu-map)
 792       (let ((map (make-sparse-keymap))
 793             (dummy (make-sparse-keymap)))
 794         ;; initialize all the vm-menu-fsfemacs-*-menu variables
 795         ;; with the menus.
 796         (easy-menu-define vm-menu-fsfemacs-help-menu (list dummy) nil
 797                              vm-menu-help-menu)
 798         (easy-menu-define vm-menu-fsfemacs-dispose-menu (list dummy) nil
 799                              (cons "Dispose" (nthcdr 4 vm-menu-dispose-menu)))
 800         (easy-menu-define vm-menu-fsfemacs-dispose-popup-menu (list dummy) nil
 801                              vm-menu-dispose-menu)
 802 ;;      (easy-menu-define vm-menu-fsfemacs-undo-menu (list dummy) nil
 803 ;;                           (list "Undo" vm-menu-undo-menu))
 804         (easy-menu-define vm-menu-fsfemacs-virtual-menu (list dummy) nil
 805                              vm-menu-virtual-menu)
 806         (easy-menu-define vm-menu-fsfemacs-sort-menu (list dummy) nil
 807                              vm-menu-sort-menu)
 808         (easy-menu-define vm-menu-fsfemacs-label-menu (list dummy) nil
 809                              vm-menu-label-menu)
 810         (easy-menu-define vm-menu-fsfemacs-mark-menu (list dummy) nil
 811                              vm-menu-mark-menu)
 812         (easy-menu-define vm-menu-fsfemacs-send-menu (list dummy) nil
 813                              vm-menu-send-menu)
 814         (easy-menu-define vm-menu-fsfemacs-motion-menu (list dummy) nil
 815                              vm-menu-motion-menu)
 816 ;;      (easy-menu-define vm-menu-fsfemacs-folders-menu (list dummy) nil
 817 ;;                           vm-menu-folders-menu)
 818         (easy-menu-define vm-menu-fsfemacs-folder-menu (list dummy) nil
 819                              vm-menu-folder-menu)
 820         (easy-menu-define vm-menu-fsfemacs-vm-menu (list dummy) nil
 821                              vm-menu-vm-menu)
 822         ;; for mail mode
 823         (easy-menu-define vm-menu-fsfemacs-mail-menu (list dummy) nil
 824                              vm-menu-mail-menu)
 825         ;; subject menu
 826         (easy-menu-define vm-menu-fsfemacs-subject-menu (list dummy) nil
 827                              vm-menu-subject-menu)
 828         ;; author menu
 829         (easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil
 830                              vm-menu-author-menu)
 831         ;; url browser menu
 832         (easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil
 833                              vm-menu-url-browser-menu)
 834         ;; mailto url browser menu
 835         (easy-menu-define vm-menu-fsfemacs-mailto-url-browser-menu
 836                              (list dummy) nil
 837                              vm-menu-url-browser-menu)
 838         ;; mime dispose menu
 839         (easy-menu-define vm-menu-fsfemacs-mime-dispose-menu
 840                              (list dummy) nil
 841                              vm-menu-mime-dispose-menu)
 842         ;; attachment menu
 843         (easy-menu-define vm-menu-fsfemacs-attachment-menu
 844                              (list dummy) nil
 845                              vm-menu-attachment-menu)
 846         ;; image menu
 847         (easy-menu-define vm-menu-fsfemacs-image-menu
 848                              (list dummy) nil
 849                              vm-menu-image-menu)
 850         ;; block the global menubar entries in the map so that VM
 851         ;; can take over the menubar if necessary.
 852         (define-key map [rootmenu] (make-sparse-keymap))
 853         (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM")))
 854         (define-key map [rootmenu vm file] 'undefined)
 855         (define-key map [rootmenu vm files] 'undefined)
 856         (define-key map [rootmenu vm search] 'undefined)
 857         (define-key map [rootmenu vm edit] 'undefined)
 858         (define-key map [rootmenu vm options] 'undefined)
 859         (define-key map [rootmenu vm buffer] 'undefined)
 860         (define-key map [rootmenu vm tools] 'undefined)
 861         (define-key map [rootmenu vm help] 'undefined)
 862         (define-key map [rootmenu vm mule] 'undefined)
 863         ;; 19.29 changed the tag for the Help menu.
 864         (define-key map [rootmenu vm help-menu] 'undefined)
 865         ;; now build VM's menu tree.
 866         (let ((menu-alist
 867                '((dispose
 868                   (cons "Dispose" vm-menu-fsfemacs-dispose-menu))
 869                  (folder
 870                   (cons "Folder" vm-menu-fsfemacs-folder-menu))
 871                  (help
 872                   (cons "Help" vm-menu-fsfemacs-help-menu))
 873                  (label
 874                   (cons "Label" vm-menu-fsfemacs-label-menu))
 875                  (mark
 876                   (cons "Mark" vm-menu-fsfemacs-mark-menu))
 877                  (motion
 878                   (cons "Motion" vm-menu-fsfemacs-motion-menu))
 879                  (send
 880                   (cons "Send" vm-menu-fsfemacs-send-menu))
 881                  (sort
 882                   (cons "Sort" vm-menu-fsfemacs-sort-menu))
 883                  (virtual
 884                   (cons "Virtual" vm-menu-fsfemacs-virtual-menu))))
 885               cons (vec (vector 'rootmenu 'vm nil))
 886               ;; menus appear in the opposite order that we
 887               ;; define-key them.
 888               (menu-list
 889                (if (consp vm-use-menus)
 890                    (reverse vm-use-menus)
 891                  (list 'help nil 'dispose 'virtual 'sort
 892                        'label 'mark 'send 'motion 'folder))))
 893           (while menu-list
 894             (if (null (car menu-list))
 895                 nil;; no flushright support in FSF Emacs
 896               (aset vec 2 (intern (concat "vm-menubar-"
 897                                           (symbol-name
 898                                            (car menu-list)))))
 899               (setq cons (assq (car menu-list) menu-alist))
 900               (if cons
 901                   (define-key map vec (eval (car (cdr cons))))))
 902             (setq menu-list (cdr menu-list))))
 903         (setq vm-mode-menu-map map)
 904         (run-hooks 'vm-menu-setup-hook))))
 905
 906 (defun vm-menu-make-xemacs-menubar ()
 907   (let ((menu-alist
 908          '((dispose . vm-menu-dispose-menu)
 909            (folder . vm-menu-folder-menu)
 910            (help . vm-menu-help-menu)
 911            (label . vm-menu-label-menu)
 912            (mark . vm-menu-mark-menu)
 913            (motion . vm-menu-motion-menu)
 914            (send . vm-menu-send-menu)
 915            (sort . vm-menu-sort-menu)
 916            (virtual . vm-menu-virtual-menu)
 917            (emacs . vm-menu-emacs-button)
 918            (undo . vm-menu-undo-menu)))
 919         cons
 920         (menubar nil)
 921         (menu-list vm-use-menus))
 922     (while menu-list
 923       (if (null (car menu-list))
 924           (setq menubar (cons nil menubar))
 925         (setq cons (assq (car menu-list) menu-alist))
 926         (if cons
 927             (setq menubar (cons (symbol-value (cdr cons)) menubar))))
 928       (setq menu-list (cdr menu-list)))
 929     (nreverse menubar) ))
 930
 931 (defun vm-menu-popup-mode-menu (event)
 932   (interactive "e")
 933   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
 934          (set-buffer (window-buffer (event-window event)))
 935          (and (event-point event) (goto-char (event-point event)))
 936          (popup-mode-menu))
 937         ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
 938          (set-buffer (window-buffer (posn-window (event-start event))))
 939          (goto-char (posn-point (event-start event)))
 940          (vm-menu-popup-fsfemacs-menu event))))
 941
 942 (defvar vm-menu-fsfemacs-attachment-menu)
 943 (defun vm-menu-popup-context-menu (event)
 944   (interactive "e")
 945   ;; We should not need to do anything here for XEmacs.  The
 946   ;; default binding of mouse-3 is popup-mode-menu which does
 947   ;; what we want for the normal case.  For special contexts,
 948   ;; like when the mouse is over an URL, XEmacs has local keymap
 949   ;; support for extents.  Any context sensitive area should be
 950   ;; contained in an extent with a keymap that has mouse-3 bound
 951   ;; to a function that will pop up a context sensitive menu.
 952   (cond ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
 953          (set-buffer (window-buffer (posn-window (event-start event))))
 954          (goto-char (posn-point (event-start event)))
 955          (if (get-text-property (point) 'vm-mime-object)
 956              (vm-menu-popup-fsfemacs-menu
 957               event vm-menu-fsfemacs-attachment-menu)
 958            (let (o-list o menu (found nil))
 959              (setq o-list (overlays-at (point)))
 960              (while (and o-list (not found))
 961                (cond ((overlay-get (car o-list) 'vm-url)
 962                       (setq found t)
 963                       (vm-menu-popup-url-browser-menu event))
 964                      ((setq menu (overlay-get (car o-list) 'vm-header))
 965                       (setq found t)
 966                       (vm-menu-popup-fsfemacs-menu event menu))
 967                      ((setq menu (overlay-get (car o-list) 'vm-image))
 968                       (setq found t)
 969                       (vm-menu-popup-fsfemacs-menu event menu))
 970                      ((overlay-get (car o-list) 'vm-mime-layout)
 971                       (setq found t)
 972                       (vm-menu-popup-mime-dispose-menu event)))
 973                (setq o-list (cdr o-list)))
 974              (and (not found) (vm-menu-popup-fsfemacs-menu event)))))))
 975
 976 ;; to quiet the byte-compiler
 977 (defvar vm-menu-fsfemacs-url-browser-menu)
 978 (defvar vm-menu-fsfemacs-mailto-url-browser-menu)
 979 (defvar vm-menu-fsfemacs-mime-dispose-menu)
 980
 981 (defun vm-menu-goto-event (event)
 982   (cond ((vm-menu-xemacs-menus-p)
 983          ;; Must select window instead of just set-buffer because
 984          ;; popup-menu returns before the user has made a
 985          ;; selection.  This will cause the command loop to
 986          ;; resume which might undo what set-buffer does.
 987          (select-window (event-window event))
 988          (and (event-closest-point event)
 989               (goto-char (event-closest-point event))))
 990         ((vm-menu-fsfemacs-menus-p)
 991          (set-buffer (window-buffer (posn-window (event-start event))))
 992          (goto-char (posn-point (event-start event))))))
 993
 994 (defun vm-menu-popup-url-browser-menu (event)
 995   (interactive "e")
 996   (vm-menu-goto-event event)
 997   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
 998          (popup-menu vm-menu-url-browser-menu))
 999         ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
1000          (vm-menu-popup-fsfemacs-menu
1001           event vm-menu-fsfemacs-url-browser-menu))))
1002
1003 (defun vm-menu-popup-mailto-url-browser-menu (event)
1004   (interactive "e")
1005   (vm-menu-goto-event event)
1006   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
1007          (popup-menu vm-menu-mailto-url-browser-menu))
1008         ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
1009          (vm-menu-popup-fsfemacs-menu
1010           event vm-menu-fsfemacs-mailto-url-browser-menu))))
1011
1012 (defun vm-menu-popup-mime-dispose-menu (event)
1013   (interactive "e")
1014   (vm-menu-goto-event event)
1015   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
1016          (popup-menu vm-menu-mime-dispose-menu))
1017         ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
1018          (vm-menu-popup-fsfemacs-menu
1019           event vm-menu-fsfemacs-mime-dispose-menu))))
1020
1021 (defun vm-menu-popup-attachment-menu (event)
1022   (interactive "e")
1023   (vm-menu-goto-event event)
1024   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
1025          (popup-menu vm-menu-attachment-menu))
1026         ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
1027          (vm-menu-popup-fsfemacs-menu
1028           event vm-menu-fsfemacs-attachment-menu))))
1029
1030 (defvar vm-menu-fsfemacs-image-menu)
1031 (defun vm-menu-popup-image-menu (event)
1032   (interactive "e")
1033   (vm-menu-goto-event event)
1034   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
1035          (popup-menu vm-menu-image-menu))
1036         ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
1037          (vm-menu-popup-fsfemacs-menu
1038           event vm-menu-fsfemacs-image-menu))))
1039
1040 ;; to quiet the byte-compiler
1041 (defvar vm-menu-fsfemacs-mail-menu)
1042 (defvar vm-menu-fsfemacs-dispose-popup-menu)
1043 (defvar vm-menu-fsfemacs-vm-menu)
1044
1045 (defun vm-menu-popup-fsfemacs-menu (event &optional menu)
1046   (interactive "e")
1047   (set-buffer (window-buffer (posn-window (event-start event))))
1048   (goto-char (posn-point (event-start event)))
1049   (let ((map (or menu mode-popup-menu))
1050         key command func)
1051     (setq key (x-popup-menu event map)
1052           key (apply 'vector key)
1053           command (lookup-key map key)
1054           func (and (symbolp command) (symbol-function command)))
1055     (cond ((null func) (setq this-command last-command))
1056           ((symbolp func)
1057            (setq this-command func)
1058            (call-interactively this-command))
1059           (t
1060            (call-interactively command)))))
1061
1062 (defun vm-menu-mode-menu ()
1063   (if (vm-menu-xemacs-menus-p)
1064       (cond ((eq major-mode 'mail-mode)
1065              vm-menu-mail-menu)
1066             ((memq major-mode '(vm-mode vm-presentation-mode
1067                                 vm-summary-mode vm-virtual-mode))
1068              vm-menu-dispose-menu)
1069             (t vm-menu-vm-menu))
1070     (cond ((eq major-mode 'mail-mode)
1071            vm-menu-fsfemacs-mail-menu)
1072           ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode))
1073            vm-menu-fsfemacs-dispose-popup-menu)
1074           (t vm-menu-fsfemacs-vm-menu))))
1075
1076 (defun vm-menu-set-menubar-dirty-flag ()
1077   (cond ((vm-menu-xemacs-menus-p)
1078          (set-menubar-dirty-flag))
1079         ((vm-menu-fsfemacs-menus-p)
1080          (force-mode-line-update))))
1081
1082 (defun vm-menu-toggle-menubar (&optional buffer)
1083   (interactive)
1084   (if buffer
1085       (set-buffer buffer)
1086     (vm-select-folder-buffer))
1087   (cond ((vm-menu-xemacs-menus-p)
1088          (if (null (car (find-menu-item current-menubar '("XEmacs"))))
1089              (set-buffer-menubar vm-menu-vm-menubar)
1090            ;; copy the current menubar in case it has been changed.
1091            (make-local-variable 'vm-menu-vm-menubar)
1092            (setq vm-menu-vm-menubar (copy-sequence current-menubar))
1093            (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
1094            (condition-case nil
1095                (add-menu-button nil vm-menu-vm-button nil)
1096              (void-function
1097               (add-menu-item nil "VM" 'vm-menu-toggle-menubar t))))
1098          (vm-menu-set-menubar-dirty-flag)
1099          (vm-check-for-killed-summary)
1100          (and vm-summary-buffer
1101               (save-excursion
1102                 (vm-menu-toggle-menubar vm-summary-buffer)))
1103          (vm-check-for-killed-presentation)
1104          (and vm-presentation-buffer-handle
1105               (save-excursion
1106                 (vm-menu-toggle-menubar vm-presentation-buffer-handle))))
1107         ((vm-menu-fsfemacs-menus-p)
1108          (if (not (eq (lookup-key vm-mode-map [menu-bar])
1109                       (lookup-key vm-mode-menu-map [rootmenu vm])))
1110              (define-key vm-mode-map [menu-bar]
1111                (lookup-key vm-mode-menu-map [rootmenu vm]))
1112            (define-key vm-mode-map [menu-bar]
1113              (make-sparse-keymap))
1114            (define-key vm-mode-map [menu-bar vm]
1115              (cons "[VM]" 'vm-menu-toggle-menubar)))
1116          (vm-menu-set-menubar-dirty-flag))))
1117
1118 (defun vm-menu-install-menubar ()
1119   (cond ((vm-menu-xemacs-menus-p)
1120          (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar))
1121          (set-buffer-menubar vm-menu-vm-menubar)
1122          (run-hooks 'vm-menu-setup-hook)
1123          (setq vm-menu-vm-menubar current-menubar))
1124         ((and (vm-menu-fsfemacs-menus-p)
1125               ;; menus only need to be installed once for FSF Emacs
1126               (not (fboundp 'vm-menu-undo-menu)))
1127          (vm-menu-initialize-vm-mode-menu-map)
1128          (define-key vm-mode-map [menu-bar]
1129            (lookup-key vm-mode-menu-map [rootmenu vm])))))
1130
1131 (defun vm-menu-install-menubar-item ()
1132   (cond ((and (vm-menu-xemacs-menus-p) (vm-menu-xemacs-global-menubar))
1133          (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
1134          (add-menu nil "VM" (cdr vm-menu-vm-menu)))
1135         ((and (vm-menu-fsfemacs-menus-p)
1136               ;; menus only need to be installed once for FSF Emacs
1137               (not (fboundp 'vm-menu-undo-menu)))
1138          (vm-menu-initialize-vm-mode-menu-map)
1139          (define-key vm-mode-map [menu-bar]
1140            (lookup-key vm-mode-menu-map [rootmenu])))))
1141
1142 (defun vm-menu-install-vm-mode-menu ()
1143   ;; nothing to do here.
1144   ;; handled in vm-mouse.el
1145   (cond ((vm-menu-xemacs-menus-p)
1146          t )
1147         ((vm-menu-fsfemacs-menus-p)
1148          t )))
1149
1150 (defun vm-menu-install-mail-mode-menu ()
1151   (cond ((vm-menu-xemacs-menus-p)
1152          ;; mail-mode doesn't have mode-popup-menu bound to
1153          ;; mouse-3 by default.  fix that.
1154          (if vm-popup-menu-on-mouse-3
1155              (define-key vm-mail-mode-map 'button3 'popup-mode-menu))
1156          ;; put menu on menubar also.
1157          (if (vm-menu-xemacs-global-menubar)
1158              (progn
1159                (set-buffer-menubar
1160                 (copy-sequence (vm-menu-xemacs-global-menubar)))
1161                (add-menu nil "Mail" (cdr vm-menu-mail-menu))))
1162          t )
1163         ((vm-menu-fsfemacs-menus-p)
1164          ;; I'd like to do this, but the result is a combination
1165          ;; of the Emacs and VM Mail menus glued together.
1166          ;; Poorly.
1167          ;;(define-key vm-mail-mode-map [menu-bar mail]
1168          ;;  (cons "Mail" vm-menu-fsfemacs-mail-menu))
1169          (defvar mail-mode-map)
1170          (define-key mail-mode-map [menu-bar mail]
1171            (cons "Mail" vm-menu-fsfemacs-mail-menu))
1172          (if vm-popup-menu-on-mouse-3
1173              (define-key vm-mail-mode-map [down-mouse-3]
1174                'vm-menu-popup-context-menu)))))
1175
1176 (defun vm-menu-install-menus ()
1177   (cond ((consp vm-use-menus)
1178          (vm-menu-install-vm-mode-menu)
1179          (vm-menu-install-menubar)
1180          (vm-menu-install-known-virtual-folders-menu))
1181         ((eq vm-use-menus 1)
1182          (vm-menu-install-vm-mode-menu)
1183          (vm-menu-install-menubar-item)
1184          (vm-menu-install-known-virtual-folders-menu))
1185         (t nil)))
1186
1187 (defun vm-menu-install-known-virtual-folders-menu ()
1188   (let ((folders (sort (mapcar 'car vm-virtual-folder-alist)
1189                        (function string-lessp)))
1190         (menu nil)
1191         tail
1192         ;; special string indicating tail of Virtual menu
1193         (special "-------"))
1194     (while folders
1195       (setq menu (cons (vector "    "
1196                                (list 'vm-menu-run-command
1197                                      ''vm-visit-virtual-folder (car folders))
1198                                t
1199                                (car folders))
1200                        menu)
1201             folders (cdr folders)))
1202     (and menu (setq menu (nreverse menu)
1203                     menu (nconc (list "Visit:" "---") menu)))
1204     (setq tail (vm-member special vm-menu-virtual-menu))
1205     (if (and menu tail)
1206         (progn
1207           (setcdr tail menu)
1208           (vm-menu-set-menubar-dirty-flag)
1209           (cond ((vm-menu-fsfemacs-menus-p)
1210                  (makunbound 'vm-menu-fsfemacs-virtual-menu)
1211                  (easy-menu-define vm-menu-fsfemacs-virtual-menu
1212                                       (list (make-sparse-keymap))
1213                                       nil
1214                                       vm-menu-virtual-menu)
1215                  (define-key vm-mode-menu-map [rootmenu vm vm-menubar-virtual]
1216                    (cons "Virtual" vm-menu-fsfemacs-virtual-menu))))))))
1217
1218 (defun vm-menu-install-visited-folders-menu ()
1219   (let ((folders (vm-delete-duplicates (copy-sequence vm-folder-history)))
1220         (menu nil)
1221         tail foo
1222         spool-files
1223         (i 0)
1224         ;; special string indicating tail of Folder menu
1225         (special "-------"))
1226     (while (and folders (< i 10))
1227       (setq menu (cons
1228                   (vector "    "
1229                           (cond
1230                            ((and (stringp vm-recognize-pop-maildrops)
1231                                  (string-match vm-recognize-pop-maildrops
1232                                                (car folders))
1233                                  (setq foo (vm-pop-find-name-for-spec
1234                                             (car folders))))
1235                             (list 'vm-menu-run-command
1236                                   ''vm-visit-pop-folder foo))
1237                            (t
1238                             (list 'vm-menu-run-command
1239                                   ''vm-visit-folder (car folders))))
1240                           t
1241                           (car folders))
1242                        menu)
1243             folders (cdr folders)
1244             i (1+ i)))
1245     (and menu (setq menu (nreverse menu)
1246                     menu (nconc (list "Visit:" "---") menu)))
1247     (setq spool-files (vm-spool-files)
1248           folders (cond ((and (consp spool-files)
1249                               (consp (car spool-files)))
1250                          (mapcar (function car) spool-files))
1251                         ((and (consp spool-files)
1252                               (stringp (car spool-files))
1253                               (stringp vm-primary-inbox))
1254                          (list vm-primary-inbox))
1255                         (t nil)))
1256     (if (and menu folders)
1257         (nconc menu (list "---" "---")))
1258     (while folders
1259       (setq menu (nconc menu
1260                         (list (vector "    "
1261                                       (list 'vm-menu-run-command
1262                                             ''vm-visit-folder (car folders))
1263                                       t
1264                                       (car folders))))
1265             folders (cdr folders)))
1266     (setq tail (vm-member special vm-menu-folder-menu))
1267     (if (and menu tail)
1268         (progn
1269           (setcdr tail menu)
1270           (vm-menu-set-menubar-dirty-flag)
1271           (cond ((vm-menu-fsfemacs-menus-p)
1272                  (makunbound 'vm-menu-fsfemacs-folder-menu)
1273                  (easy-menu-define vm-menu-fsfemacs-folder-menu
1274                                       (list (make-sparse-keymap))
1275                                       nil
1276                                       vm-menu-folder-menu)
1277                  (define-key vm-mode-menu-map [rootmenu vm vm-menubar-folder]
1278                    (cons "Folder" vm-menu-fsfemacs-folder-menu))))))))
1279
1280 \f
1281 ;;; Muenkel Folders menu code
1282
1283 (defvar vm-menu-hm-no-hidden-dirs t
1284   "*Hidden directories are suppressed in the folder menus, if non nil.")
1285
1286 (defvar vm-menu-hm-hidden-file-list '("^\\..*" ".*\\.~[0-9]+~"))
1287
1288 (defun vm-menu-hm-delete-folder (folder)
1289   "Query deletes a folder."
1290   (interactive "fDelete folder: ")
1291   (if (file-exists-p folder)
1292       (if (y-or-n-p (concat "Delete the folder " folder " ? "))
1293           (progn
1294             (if (file-directory-p folder)
1295                 (delete-directory folder)
1296               (delete-file folder))
1297             (message "Folder deleted.")
1298             (vm-menu-hm-make-folder-menu)
1299             (vm-menu-hm-install-menu)
1300             )
1301         (message "Aborted"))
1302     (error "Folder %s does not exist." folder)
1303     (vm-menu-hm-make-folder-menu)
1304     (vm-menu-hm-install-menu)
1305     ))
1306
1307
1308 (defun vm-menu-hm-rename-folder (folder)
1309   "Rename a folder."
1310   (interactive "fRename folder: ")
1311   (if (file-exists-p folder)
1312       (rename-file folder
1313                    (read-file-name (concat "Rename "
1314                                            folder
1315                                            " to ")
1316                                    (directory-file-name folder)
1317                                    folder))
1318     (error "Folder %s does not exist." folder))
1319   (vm-menu-hm-make-folder-menu)
1320   (vm-menu-hm-install-menu)
1321   )
1322
1323
1324 (defun vm-menu-hm-create-dir (parent-dir)
1325   "Create a subdir in PARENT-DIR."
1326   (interactive "DCreate new directory in: ")
1327   (setq parent-dir (or parent-dir vm-folder-directory))
1328   (make-directory
1329    (expand-file-name (read-file-name
1330                       (format "Create directory in %s called: "
1331                               parent-dir)
1332                       parent-dir)
1333                      vm-folder-directory)
1334    t)
1335   (vm-menu-hm-make-folder-menu)
1336   (vm-menu-hm-install-menu)
1337   )
1338
1339
1340 (defun vm-menu-hm-make-folder-menu ()
1341   "Makes a menu with the mail folders of the directory `vm-folder-directory'."
1342   (interactive)
1343   (message "Building folders menu...")
1344   (let ((folder-list (vm-menu-hm-tree-make-file-list vm-folder-directory))
1345         (inbox-list (if (listp (car vm-spool-files))
1346                         (mapcar 'car vm-spool-files)
1347                       (list vm-primary-inbox))))
1348     (setq vm-menu-folders-menu
1349           (cons "Manipulate Folders"
1350                 (list (cons "Visit Inboxes  "
1351                             (vm-menu-hm-tree-make-menu
1352                              inbox-list
1353                              'vm-visit-folder
1354                              t))
1355                       (cons "Visit Folder   "
1356                             (vm-menu-hm-tree-make-menu
1357                              folder-list
1358                              'vm-visit-folder
1359                              t
1360                              vm-menu-hm-no-hidden-dirs
1361                              vm-menu-hm-hidden-file-list))
1362                       (cons "Save Message   "
1363                             (vm-menu-hm-tree-make-menu
1364                              folder-list
1365                              'vm-save-message
1366                              t
1367                              vm-menu-hm-no-hidden-dirs
1368                              vm-menu-hm-hidden-file-list))
1369                       "----"
1370                       (cons "Delete Folder  "
1371                             (vm-menu-hm-tree-make-menu
1372                              folder-list
1373                              'vm-menu-hm-delete-folder
1374                              t
1375                              nil
1376                              nil
1377                              t
1378                              ))
1379                       (cons "Rename Folder  "
1380                             (vm-menu-hm-tree-make-menu
1381                              folder-list
1382                              'vm-menu-hm-rename-folder
1383                              t
1384                              nil
1385                              nil
1386                              t
1387                              ))
1388                       (cons "Make New Directory in..."
1389                             (vm-menu-hm-tree-make-menu
1390                              (cons (list vm-folder-directory) folder-list)
1391                              'vm-menu-hm-create-dir
1392                              t
1393                              nil
1394                              '(".*")
1395                              t
1396                              ))
1397                       "----"
1398                       ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]
1399                       ))))
1400   (message "Building folders menu... done")
1401   (vm-menu-hm-install-menu))
1402
1403 (defun vm-menu-hm-install-menu ()
1404   (cond ((vm-menu-xemacs-menus-p)
1405          (cond ((car (find-menu-item current-menubar '("VM")))
1406                 (add-menu '("VM") "Folders"
1407                           (cdr vm-menu-folders-menu) "Motion"))
1408                ((car (find-menu-item current-menubar
1409                                      '("Folder" "Manipulate Folders")))
1410                 (add-menu '("Folder") "Manipulate Folders"
1411                           (cdr vm-menu-folders-menu) "Motion"))))
1412         ((vm-menu-fsfemacs-menus-p)
1413          (easy-menu-define vm-menu-fsfemacs-folders-menu
1414                               (list (make-sparse-keymap))
1415                               nil
1416                               vm-menu-folders-menu)
1417          (define-key vm-mode-menu-map [rootmenu vm folder folders]
1418            (cons "Manipulate Folders" vm-menu-fsfemacs-folders-menu)))))
1419
1420 \f
1421 ;;; Muenkel tree-menu code
1422
1423 (defvar vm-menu-hm-tree-ls-flags "-aFLR"
1424   "*A String with the flags used in the function
1425 vm-menu-hm-tree-ls-in-temp-buffer for the ls command.
1426 Be careful if you want to change this variable.
1427 The ls command must append a / on all files which are directories.
1428 The original flags are -aFLR.")
1429
1430
1431 (defun vm-menu-hm-tree-ls-in-temp-buffer (dir temp-buffer)
1432 "List the directory DIR in the TEMP-BUFFER."
1433   (switch-to-buffer temp-buffer)
1434   (erase-buffer)
1435   (let ((process-connection-type nil))
1436     (call-process "ls" nil temp-buffer nil vm-menu-hm-tree-ls-flags dir))
1437   (goto-char (point-min))
1438   (while (search-forward "//" nil t)
1439     (replace-match "/"))
1440   (goto-char (point-min))
1441   (while (re-search-forward "\\.\\.?/\n" nil t)
1442     (replace-match ""))
1443   (goto-char (point-min)))
1444
1445
1446 (defvar vm-menu-hm-tree-temp-buffername "*tree*"
1447   "Name of the temp buffers in tree.")
1448
1449
1450 (defun vm-menu-hm-tree-make-file-list-1 (root list)
1451   (let ((filename (buffer-substring (point) (progn
1452                                               (end-of-line)
1453                                               (point)))))
1454     (while (not (string= filename ""))
1455       (setq
1456        list
1457        (append
1458         list
1459         (list
1460          (cond ((char-equal (char-after (- (point) 1)) ?/)
1461                 ;; Directory
1462                 (setq filename (substring filename 0 (1- (length filename))))
1463                 (save-excursion
1464                   (search-forward (concat root filename ":"))
1465                   (forward-line)
1466                   (vm-menu-hm-tree-make-file-list-1 (concat root filename "/")
1467                                                 (list (vm-menu-hm-tree-menu-file-truename
1468                                                        filename
1469                                                        root)))))
1470                ((char-equal (char-after (- (point) 1)) ?*)
1471                 ;; Executable
1472                 (setq filename (substring filename 0 (1- (length filename))))
1473                 (vm-menu-hm-tree-menu-file-truename filename root))
1474                (t (vm-menu-hm-tree-menu-file-truename filename root))))))
1475       (forward-line)
1476       (setq filename (buffer-substring (point) (progn
1477                                                  (end-of-line)
1478                                                  (point)))))
1479     list))
1480
1481
1482 (defun vm-menu-hm-tree-menu-file-truename (file &optional root)
1483   (file-truename (expand-file-name file root)))
1484
1485 (defun vm-menu-hm-tree-make-file-list (dir)
1486   "Makes a list with the files and subdirectories of DIR.
1487 The list looks like: ((dirname1 file1 file2)
1488                       file3
1489                       (dirname2 (dirname3 file4 file5) file6))"
1490   (save-window-excursion
1491     (setq dir (expand-file-name dir))
1492     (if (not (string= (substring dir -1) "/"))
1493         (setq dir (concat dir "/")))
1494 ;;    (while (string-match "/$" dir)
1495 ;;      (setq dir (substring dir 0 -1)))
1496     (vm-menu-hm-tree-ls-in-temp-buffer dir
1497                                  (generate-new-buffer-name
1498                                   vm-menu-hm-tree-temp-buffername))
1499     (let ((list nil))
1500       (setq list (vm-menu-hm-tree-make-file-list-1 dir nil))
1501       (kill-buffer (current-buffer))
1502       list)))
1503
1504
1505 (defun vm-menu-hm-tree-hide-file-p (filename re-hidden-file-list)
1506   "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME."
1507   (cond ((not re-hidden-file-list) nil)
1508         ((string-match (car re-hidden-file-list)
1509                        (vm-menu-hm-tree-menu-file-truename filename)))
1510         (t (vm-menu-hm-tree-hide-file-p filename (cdr re-hidden-file-list)))))
1511
1512
1513 (defun vm-menu-hm-tree-make-menu (dirlist
1514                        function
1515                        selectable
1516                        &optional
1517                        no-hidden-dirs
1518                        re-hidden-file-list
1519                        include-current-dir)
1520   "Returns a menu list.
1521 Each item of the menu list has the form
1522  [\"subdir\" (FUNCTION \"dir\") SELECTABLE].
1523 Hidden directories (with a leading point) are suppressed,
1524 if NO-HIDDEN-DIRS are non nil. Also all files which are
1525 matching a regexp in RE-HIDDEN-FILE-LIST are suppressed.
1526 If INCLUDE-CURRENT-DIR non nil, then an additional command
1527 for the current directory (.) is inserted."
1528   (let ((subdir nil)
1529         (menulist nil))
1530     (while (setq subdir (car dirlist))
1531       (setq dirlist (cdr dirlist))
1532       (cond ((and (stringp subdir)
1533                   (not (vm-menu-hm-tree-hide-file-p subdir re-hidden-file-list)))
1534              (setq menulist
1535                    (append menulist
1536                            (list
1537                             (vector (file-name-nondirectory subdir)
1538                                     (list function subdir)
1539                                     selectable)))))
1540             ((and (listp subdir)
1541                   (or (not no-hidden-dirs)
1542                       (not (char-equal
1543                             ?.
1544                             (string-to-char
1545                              (file-name-nondirectory (car subdir))))))
1546                   (setq menulist
1547                         (append
1548                          menulist
1549                          (list
1550                           (cons (file-name-nondirectory (car subdir))
1551                                 (if include-current-dir
1552                                     (cons
1553                                      (vector "."
1554                                              (list function
1555                                                    (car subdir))
1556                                              selectable)
1557                                      (vm-menu-hm-tree-make-menu (cdr subdir)
1558                                                      function
1559                                                      selectable
1560                                                      no-hidden-dirs
1561                                                      re-hidden-file-list
1562                                                      include-current-dir
1563                                                      ))
1564                                   (vm-menu-hm-tree-make-menu (cdr subdir)
1565                                                   function
1566                                                   selectable
1567                                                   no-hidden-dirs
1568                                                   re-hidden-file-list
1569                                                   ))))))))
1570             (t nil))
1571       )
1572     menulist
1573     )
1574   )
1575
1576 (provide 'vm-menu)
1577
1578 ;;; vm-menu.el ends here