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

   1 ;;; vm-rfaddons.el --- a collections of various useful VM helper functions
   2 ;;
   3 ;; Copyright (C) 1999-2006 Robert Widhopf-Fenk
   4 ;;
   5 ;; Author:      Robert Widhopf-Fenk
   6 ;; Status:      Tested with XEmacs 21.4.19 & VM 7.19
   7 ;; Keywords:    VM helpers
   8 ;; X-URL:       http://www.robf.de/Hacking/elisp
   9
  10 ;;
  11 ;; This code is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 1, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26 ;; Some of the functions should be unbundled into separate packages,
  27 ;; but well I'm a lazy guy.  And some of them are not tested well.
  28 ;;
  29 ;; In order to install this package you need to byte-compile it and put
  30 ;; it into your load-path and add the following lines to the _end_ of your
  31 ;; .vm file.  It should be the _end_ in order to ensure that variable you had
  32 ;; been setting are honored!
  33 ;;
  34 ;;      (require 'vm-rfaddons)
  35 ;;      (vm-rfaddons-infect-vm)
  36 ;;
  37 ;; When using only a subset of the functions you should have a
  38 ;; look at the documentation of `vm-rfaddons-infect-vm' and modify
  39 ;; its call as desired.
  40 ;;
  41 ;; Additional packages you may need are:
  42 ;;
  43 ;; * Package: Personality Crisis for VM
  44 ;;   is a really cool package if you want to do automatic header rewriting,
  45 ;;   e.g.  if you have various mail accounts and always want to use the right
  46 ;;   from header, then check it out!
  47 ;;
  48 ;; * Package: BBDB
  49 ;;   Homepage: http://bbdb.sourceforge.net
  50 ;;
  51 ;; All other packages should be included within standard (X)Emacs
  52 ;; distributions.
  53 ;;
  54 ;; Feel free to sent me any comments or bug reports.
  55 ;;
  56 ;; As I am no active GNU Emacs user, I would be thankful for any patches to
  57 ;; make things work with GNU Emacs!
  58 ;;
  59 ;;; Code:
  60
  61 (defgroup vm nil
  62   "VM"
  63   :group 'mail)
  64
  65 (defgroup vm-rfaddons nil
  66   "Customize vm-rfaddons.el"
  67   :group 'vm)
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 (eval-when-compile
  71   (require 'vm-version)
  72   (require 'vm-message)
  73   (require 'vm-macro)
  74   (require 'vm-vars)
  75   (require 'cl)
  76   (require 'advice)
  77   (let ((feature-list '(regexp-opt bbdb bbdb-vm gnus-group)))
  78     (while feature-list
  79       (condition-case nil
  80           (require (car feature-list))
  81         (error
  82          (if (load (format "%s" (car feature-list)) t)
  83              (message "Library %s loaded!" (car feature-list))
  84            (message "Could not load feature %S.  Related functions may not work correctly!" (car feature-list)))))
  85       (setq feature-list (cdr feature-list)))))
  86
  87 (require 'sendmail)
  88
  89 (if vm-xemacs-p (require 'overlay))
  90
  91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92 (defmacro vm-rfaddons-check-option (option option-list &rest body)
  93   "Evaluate body if option is in OPTION-LIST or OPTION-LIST is nil."
  94   (list 'if (list 'member option option-list)
  95         (cons 'progn
  96               (cons (list 'setq option-list (list 'delq option option-list))
  97                     (cons (list 'message "Adding vm-rfaddons-option `%s'."
  98                                 option)
  99                           body)))))
 100
 101 ;;;###autoload
 102 (defun vm-rfaddons-infect-vm (&optional sit-for
 103                                         option-list exclude-option-list)
 104   "This function will setup the key bindings, advices and hooks
 105 necessary to use all the function of vm-rfaddons.el!
 106
 107 SIT-FOR specifies the number of seconds to display the infection message!
 108 The OPTION-LIST can be use to select individual option.
 109 The EXCLUDE-OPTION-LIST can be use to exclude individual option.
 110
 111 The following options are possible.
 112
 113 `general' options:
 114  - rf-faces: change some faces
 115
 116 `vm-mail-mode' options:
 117  - attach-save-files: bind [C-c C-a] to `vm-mime-attach-files-in-directory'
 118  - check-recipients: add `vm-mail-check-recipients' to `mail-send-hook' in
 119    order to check if the recipients headers are correct.
 120  - encode-headers: add `vm-mime-encode-headers' to `mail-send-hook' in
 121    order to encode the headers before sending.
 122  - fake-date: if enabled allows you to fake the date of an outgoing message.
 123
 124 `vm-mode' options:
 125  - save-all-attachments: in vm-mail-mode and [C-c C-s] to the function
 126    `vm-mime-save-all-attachments'
 127  - shrunken-headers: enable shrunken-headers by advising several functions
 128  - take-action-on-attachment: bind [.] to `vm-mime-take-action-on-attachment'
 129
 130 Other EXPERIMENTAL options:
 131  - auto-save-all-attachments: add `vm-mime-auto-save-all-attachments' to
 132    `vm-select-new-message-hook' for automatic saving of attachments and define
 133    an advice for `vm-set-deleted-flag-of' in order to automatically delete
 134    the files corresponding to MIME objects of type message/external-body when
 135    deleting the message.
 136  - return-receipt-to
 137
 138 If you want to use only a subset of the options then call
 139 `vm-rfaddons-infect-vm' like this:
 140         (vm-rfaddons-infect-vm 2 '(general vm-mail-mode shrunken-headers)
 141                                  '(fake-date))
 142 This will enable all `general' and `vm-mail-mode' options plus the
 143 `shrunken-headers' option, but it will exclude the `fake-date' option of the
 144 `vm-mail-mode' options.
 145
 146 or do the binding and advising on your own."
 147   (interactive "")
 148
 149   (if (eq option-list 'all)
 150       (setq option-list (list 'general 'vm-mail-mode 'vm-mode
 151                               'auto-save-all-attachments
 152                               'auto-delete-message-external-body))
 153     (if (eq option-list t)
 154         (setq option-list (list 'vm-mail-mode 'vm-mode))))
 155
 156   (when (member 'general option-list)
 157     (setq option-list (append '(rf-faces)
 158                               option-list))
 159     (setq option-list (delq 'general option-list)))
 160
 161   (when (member 'vm-mail-mode option-list)
 162     (setq option-list (append '(attach-save-files
 163                                 check-recipients
 164                                 check-for-empty-subject
 165                                 encode-headers
 166                                 clean-subject
 167                                 fake-date
 168                                 open-line)
 169                               option-list))
 170     (setq option-list (delq 'vm-mail-mode option-list)))
 171
 172   (when (member 'vm-mode option-list)
 173     (setq option-list (append '(
 174                                 save-all-attachments
 175                                 shrunken-headers
 176                                 take-action-on-attachment)
 177                               option-list))
 178     (setq option-list (delq 'vm-mode option-list)))
 179
 180   (while exclude-option-list
 181     (if (member (car exclude-option-list) option-list)
 182         (setq option-list (delq (car exclude-option-list) option-list))
 183       (message "VM-RFADDONS: The option `%s' was not excluded, maybe it is unknown!"
 184                (car exclude-option-list))
 185       (ding)
 186       (sit-for 3))
 187     (setq exclude-option-list (cdr exclude-option-list)))
 188
 189   ;; general ----------------------------------------------------------------
 190   ;; install my choice of faces
 191   (vm-rfaddons-check-option
 192    'rf-faces option-list
 193    (vm-install-rf-faces))
 194
 195   ;; vm-mail-mode -----------------------------------------------------------
 196   (vm-rfaddons-check-option
 197    'attach-save-files option-list
 198    (define-key vm-mail-mode-map "\C-c\C-a" 'vm-mime-attach-files-in-directory))
 199
 200   ;; check recipients headers for errors before sending
 201   (vm-rfaddons-check-option
 202    'check-recipients option-list
 203    (add-hook 'mail-send-hook 'vm-mail-check-recipients))
 204
 205   ;; check if the subjectline is empty
 206   (vm-rfaddons-check-option
 207    'check-for-empty-subject option-list
 208    (add-hook 'vm-mail-send-hook 'vm-mail-check-for-empty-subject))
 209
 210   ;; encode headers before sending
 211   (vm-rfaddons-check-option
 212    'encode-headers option-list
 213    (add-hook 'mail-send-hook 'vm-mime-encode-headers))
 214
 215   ;; This allows us to fake a date by advising vm-mail-mode-insert-date-maybe
 216   (vm-rfaddons-check-option
 217    'fake-date option-list
 218    (defadvice vm-mail-mode-insert-date-maybe (around vm-fake-date activate)
 219      "Do not change an existing date if `vm-mail-mode-fake-date-p' is t."
 220      (if (not (and vm-mail-mode-fake-date-p
 221                    (vm-mail-mode-get-header-contents "Date:")))
 222          ad-do-it)))
 223
 224   (vm-rfaddons-check-option
 225    'open-line option-list
 226    (add-hook 'vm-mail-mode-hook 'vm-mail-mode-install-open-line))
 227
 228   (vm-rfaddons-check-option
 229    'clean-subject option-list
 230    (add-hook 'vm-mail-mode-hook 'vm-mail-subject-cleanup))
 231
 232   ;; vm-mode -----------------------------------------------------------
 233
 234   ;; Shrunken header handlers
 235   (vm-rfaddons-check-option
 236    'shrunken-headers option-list
 237    (if (not (boundp 'vm-always-use-presentation-buffer))
 238        (message "Shrunken-headers do NOT work in standard VM!")
 239      ;; We would corrupt the folder buffer for messages which are
 240      ;; not displayed by a presentation buffer, thus we must ensure
 241      ;; that a presentation buffer is used.  The visibility-widget
 242      ;; would cause "*"s to be inserted into the folder buffer.
 243      (setq vm-always-use-presentation-buffer t)
 244      (defadvice vm-preview-current-message
 245        (after vm-shrunken-headers-pcm activate)
 246        "Shrink headers when previewing a message."
 247        (vm-shrunken-headers))
 248      (defadvice vm-expose-hidden-headers
 249        (after vm-shrunken-headers-ehh activate)
 250        "Shrink headers when viewing hidden headers."
 251        (vm-shrunken-headers))
 252      (define-key vm-mode-map "T" 'vm-shrunken-headers-toggle)))
 253
 254   ;; take action on attachment binding
 255   (vm-rfaddons-check-option
 256    'take-action-on-attachment option-list
 257    (define-key vm-mode-map "."  'vm-mime-take-action-on-attachment))
 258
 259   (vm-rfaddons-check-option
 260    'save-all-attachments option-list
 261    (define-key vm-mode-map "\C-c\C-s" 'vm-mime-save-all-attachments))
 262
 263   ;; other experimental options ---------------------------------------------
 264   ;; Now take care of automatic saving of attachments
 265   (vm-rfaddons-check-option
 266    'auto-save-all-attachments option-list
 267    ;; In order to reflect MIME type changes when `vm-mime-delete-after-saving'
 268    ;; is t we preview the message again.
 269    (defadvice vm-mime-send-body-to-file
 270      (after vm-do-preview-again activate)
 271      (if vm-mime-delete-after-saving
 272          (vm-preview-current-message)))
 273    (add-hook 'vm-select-new-message-hook 'vm-mime-auto-save-all-attachments))
 274
 275    (vm-rfaddons-check-option
 276     'auto-delete-message-external-body option-list
 277    ;; and their deletion when deleting a unfiled message,
 278    ;; this is probably a problem, since actually we should delete it
 279    ;; only if there remains no reference to it!!!!
 280    (defadvice vm-set-deleted-flag-of
 281      (before vm-mime-auto-save-all-attachments activate)
 282      (if (and (eq (ad-get-arg 1) 'expunged)
 283               (not (vm-filed-flag (ad-get-arg 0))))
 284          (vm-mime-auto-save-all-attachments-delete-external (ad-get-arg 0)))))
 285
 286    (vm-rfaddons-check-option
 287     'return-receipt-to option-list
 288     (add-hook 'vm-select-message-hook 'vm-handle-return-receipt))
 289
 290    (when option-list
 291     (message "VM-RFADDONS: The following options are unknown: %s" option-list)
 292     (ding)
 293     (sit-for 3))
 294
 295   (message "VM-RFADDONS: VM is now infected. Please report bugs to Robert Widhopf-Fenk!")
 296   (sit-for (or sit-for 2)))
 297
 298 (defun rf-vm-su-labels (m)
 299   "This version does some sanity checking."
 300   (let ((labels (vm-label-string-of m)))
 301     (if (and labels (stringp labels))
 302         labels
 303       (setq labels (vm-labels-of m))
 304       (if (and labels (listp labels))
 305           (vm-set-label-string-of
 306            m
 307            (setq labels (mapconcat 'identity labels ",")))
 308         (vm-set-label-string-of m "")
 309         (setq labels "")))
 310     labels))
 311
 312 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 313 (defvar vm-reply-include-presentation nil)
 314
 315 ;;;###autoload
 316 (defun vm-reply-include-presentation (count &optional to-all)
 317   "Include presentation instead of text.
 318 This does only work with my modified VM, i.e. a hacked `vm-yank-message'."
 319   (interactive "p")
 320   (vm-follow-summary-cursor)
 321   (vm-select-folder-buffer)
 322   (vm-check-for-killed-summary)
 323   (vm-error-if-folder-empty)
 324   (if (null vm-presentation-buffer)
 325       (if to-all
 326           (vm-followup-include-text count)
 327         (vm-reply-include-text count))
 328     (let ((vm-reply-include-presentation t))
 329       (vm-do-reply to-all t count))))
 330
 331 ;;;###autoload
 332 (defun vm-followup-include-presentation (count)
 333   "Include presentation instead of text.
 334 This does not work when replying to multiple messages."
 335   (interactive "p")
 336   (vm-reply-include-presentation count t))
 337
 338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 339 ;;;###autoload
 340 (defun vm-do-fcc-before-mime-encode ()
 341   "The name says it all.
 342 Sometimes you may want to save a message unencoded, specifically not to waste
 343 storage for attachments which are stored on disk anyway."
 344   (interactive)
 345   (save-excursion
 346     (goto-char (point-min))
 347     (re-search-forward (regexp-quote mail-header-separator) (point-max))
 348     (delete-region (match-beginning 0) (match-end 0))
 349     (let ((header-end (point-marker)))
 350       (mail-do-fcc header-end)
 351       (goto-char header-end)
 352       (insert mail-header-separator))))
 353
 354 (defcustom vm-do-fcc-before-mime-encode nil
 355   "*Non-nil means to FCC before encoding."
 356   :type 'boolean
 357   :group 'vm-rfaddons)
 358
 359 (defadvice vm-mime-encode-composition
 360   (before do-fcc-before-mime-encode activate)
 361   "FCC before encoding attachments if `vm-do-fcc-before-mime-encode' is t."
 362   (if vm-do-fcc-before-mime-encode
 363       (vm-do-fcc-before-mime-encode)))
 364
 365 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 366
 367 (defcustom vm-fill-paragraphs-containing-long-lines-faster nil
 368   "*Do faster filling of long lines with code borrowed from Gnus.
 369 This is essentially faster than VMs functions."
 370   :type 'boolean
 371   :group 'vm-rfaddons)
 372
 373 (defvar vm-unfill-paragraphs-containing-long-lines-faster nil
 374   "Set by calling `vm-unfill-paragraphs-containing-long-lines'.")
 375
 376 (defcustom vm-fill-long-lines-in-reply-column 70
 377   "*Fill lines in replies up to this column."
 378   :type 'integer
 379   :group 'vm-rfaddons)
 380
 381 (defadvice vm-fill-paragraphs-containing-long-lines
 382   (around vm-rfaddons-better-filling activate)
 383   "Do better filling if longlines.el is present otherwise if
 384 `vm-fill-paragraphs-containing-long-lines-faster' is 't do faster
 385 filling than VMs code."
 386   (if (eq (ad-get-arg 0) 'window-width)
 387       (ad-set-arg 0 (- (window-width (get-buffer-window (current-buffer))) 1)))
 388   (cond
 389    ;; use long lines when present
 390    ((locate-library "longlines")
 391     (require 'overlay)
 392     (defvar fill-nobreak-predicate nil)
 393     (defvar undo-in-progress nil)
 394     (defvar longlines-mode-hook nil)
 395     (defvar longlines-mode-on-hook nil)
 396     (defvar longlines-mode-off-hook nil)
 397     (unless (functionp 'replace-regexp-in-string)
 398       (defun replace-regexp-in-string (regexp rep string
 399                                               &optional fixedcase literal)
 400         (vm-replace-in-string string regexp rep literal)))
 401     (unless (functionp 'line-end-position)
 402       (defun line-end-position ()
 403         (save-excursion (end-of-line) (point))))
 404     (unless (functionp 'line-beginning-position)
 405       (defun line-beginning-position (&optional n)
 406         (save-excursion
 407           (if n (forward-line n))
 408           (beginning-of-line)
 409           (point)))
 410       (unless (functionp 'replace-regexp-in-string)
 411         (defun replace-regexp-in-string (regexp rep string
 412                                                 &optional fixedcase literal)
 413           (vm-replace-in-string string regexp rep literal))))
 414     (require 'longlines)
 415     (vm-fill-paragraphs-containing-long-lines-by-longlines
 416      (ad-get-arg 0) (ad-get-arg 1) (ad-get-arg 2)))
 417    ((eq t vm-fill-paragraphs-containing-long-lines-faster)
 418     (vm-fill-paragraphs-containing-long-lines-faster
 419      (ad-get-arg 0) (ad-get-arg 1) (ad-get-arg 2)))
 420    (t
 421     ad-do-it)))
 422
 423 ;;;###autoload
 424 (defun vm-fill-long-lines-in-reply ()
 425   (interactive)
 426   (rf-vm-fill-paragraphs-containing-long-lines-faster
 427    vm-fill-long-lines-in-reply-column
 428    (save-excursion
 429      (goto-char (point-min))
 430      (re-search-forward
 431       (regexp-quote mail-header-separator) (point-max))
 432      (forward-line 1)
 433      (point))
 434    (point-max))
 435   nil)
 436
 437 ;;;###autoload
 438 (defun vm-fill-paragraphs-containing-long-lines-toggle ()
 439   (interactive)
 440   (let ((fp vm-fill-paragraphs-containing-long-lines-faster))
 441     (setq vm-fill-paragraphs-containing-long-lines-faster
 442           (cond ((eq fp nil)
 443                  (setq vm-fill-paragraphs-containing-long-lines
 444                        vm-fill-long-lines-in-reply-column))
 445                 ((numberp fp)
 446                  t)
 447                 (t
 448                  (setq vm-fill-paragraphs-containing-long-lines nil)))))
 449
 450   (message "Paragraph-filling %s!"
 451            (if vm-fill-paragraphs-containing-long-lines-faster
 452                (if (numberp vm-fill-paragraphs-containing-long-lines-faster)
 453                    (format "for rows longer than %d chars"
 454                            vm-fill-paragraphs-containing-long-lines-faster)
 455                  "enabled in fast mode")
 456              "disabled")))
 457
 458 ;;;###autoload
 459 (defun vm-unfill-paragraphs-containing-long-lines-faster ()
 460   "Sometimes filling long lines is the wrong thing!
 461 Call this function, if you want to see the message unfilled."
 462   (interactive)
 463   (let ((vm-unfill-paragraphs-containing-long-lines-faster t))
 464     (vm-select-folder-buffer)
 465     (vm-preview-current-message)))
 466
 467 ;;;###autoload
 468 (defun vm-fill-paragraphs-containing-long-lines-faster (width start end)
 469   (if (not vm-unfill-paragraphs-containing-long-lines-faster)
 470       (vm-save-restriction
 471        (widen)
 472        (or (markerp end) (setq end (vm-marker end)))
 473        (rf-vm-fill-paragraphs-containing-long-lines-faster width start end))
 474     nil))
 475
 476 (defun rf-vm-fill-paragraphs-containing-long-lines-faster (width start end)
 477   (interactive (list vm-paragraph-fill-column (point-min) (point-max)))
 478   (save-excursion
 479     (let ((buffer-read-only nil)
 480           (fill-column width)
 481           (filladapt-fill-column-forward-fuzz 0)
 482           (filladapt-mode t)
 483           (abbrev-mode nil)
 484           (filled 0)
 485           (message (if (car vm-message-pointer)
 486                        (vm-su-subject (car vm-message-pointer))
 487                      (buffer-name))))
 488
 489       ;; we need a marker for the end since this position might change
 490       (goto-char end) (setq end (point-marker))
 491       (goto-char start)
 492
 493       (message "Filling message `%s' to column %d!" message fill-column)
 494
 495       ;; this should speed up things!
 496       (buffer-disable-undo)
 497       (condition-case nil
 498           (while (< (point) end)
 499             (end-of-line)
 500             (when (> (current-column) fill-column)
 501               (setq filled (1+ filled))
 502               (filladapt-fill-paragraph 'fill-paragraph nil))
 503             (forward-line 1))
 504         (error nil)
 505         (quit nil))
 506       (buffer-enable-undo)
 507
 508       (if (> filled 0)
 509           (message "Filled %s line%s in message `%s'!"
 510                    (if (> filled 1) (format "%d" filled) "one")
 511                    (if (> filled 1) "s" "")
 512                    message)
 513         (message "Nothing to fill!")))))
 514
 515 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 516 ;;;###autoload
 517 (defun vm-fill-paragraphs-containing-long-lines-by-longlines (width start end)
 518   "Uses `longlines.el' for filling."
 519   (let ((buffer-read-only nil)
 520         (fill-column width))
 521     (save-excursion
 522       (vm-save-restriction
 523        ;; longlines-wrap-region contains a (forward-line -1) which is causing
 524        ;; wrapping of headers which is wrong, so we restrict it here!
 525        (narrow-to-region start end)
 526        (longlines-decode-region start end) ; make linebreaks hard
 527        (longlines-wrap-region start end)  ; wrap, adding soft linebreaks
 528        (widen)))))
 529
 530 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 531 (defcustom vm-spamassassin-strip-report "spamassassin -d"
 532   "*Shell command used to strip spamassassin-reports from a message."
 533   :type 'string
 534   :group 'vm-rfaddons)
 535
 536 (defun vm-strip-spamassassin-report ()
 537   "Strips spamassassin-reports from a message."
 538   (interactive)
 539   (save-window-excursion
 540     (let ((vm-frame-per-edit nil))
 541       (vm-edit-message)
 542       (shell-command-on-region (point-min) (point-max)
 543                                vm-spamassassin-strip-report
 544                                (current-buffer)
 545                                t)
 546       (vm-edit-message-end))))
 547
 548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 549 (defvar vm-switch-to-folder-history nil)
 550
 551 ;;;###autoload
 552 (defun vm-switch-to-folder (folder-name)
 553 "Switch to another opened VM folder and rearrange windows as with a scroll."
 554   (interactive (list
 555                 (let ((fl (vm-folder-list))
 556                       (f vm-switch-to-folder-history) d)
 557                   (if (member major-mode
 558                               '(vm-mode vm-presentation-mode
 559                                         vm-summary-mode))
 560                       (save-excursion
 561                         (vm-select-folder-buffer)
 562                         (setq fl (delete (buffer-name) fl))))
 563                   (while f
 564                     (setq d (car f) f (cdr f))
 565                     (if (member d fl)
 566                         (setq f nil)))
 567                   (completing-read
 568                    (format "Foldername%s: " (if d (format " (%s)" d) ""))
 569                    (mapcar (lambda (f) (list f)) (vm-folder-list))
 570                    nil t nil
 571                    'vm-switch-to-folder-history
 572                    d))))
 573
 574   (switch-to-buffer folder-name)
 575   (vm-select-folder-buffer)
 576   (vm-summarize)
 577   (let ((this-command 'vm-scroll-backward))
 578     (vm-display nil nil '(vm-scroll-forward vm-scroll-backward)
 579                 (list this-command 'reading-message))
 580     (vm-update-summary-and-mode-line)))
 581
 582 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 583 (defcustom vm-rmail-mode nil
 584   "*Non-nil means up/down of modes listed in `vm-rmail-mode-list' do cursor movement.
 585 Use `vm-rmail-toggle' to switch between normal and this mode."
 586   :type 'boolean
 587   :group 'vm-rfaddons)
 588
 589 (defcustom vm-rmail-mode-list
 590   '(vm-mode vm-presentation-mode vm-virtual-mode)
 591   "*Mode to activate `vm-rmail-mode' in."
 592   :type '(repeat (const vm-mode)
 593                  (const vm-presentation-mode)
 594                  (const vm-virtual-mode)
 595                  (const vm-summary-mode))
 596   :group 'vm-rfaddons)
 597
 598 (defun vm-rmail-toggle (&optional arg)
 599   (interactive)
 600   (cond ((eq nil arg)
 601          (setq vm-rmail-mode (not vm-rmail-mode)))
 602         ((=  1 arg)
 603          (setq vm-rmail-mode t))
 604         ((= -1 arg)
 605          (setq vm-rmail-mode nil))
 606         (t
 607          (setq vm-rmail-mode (not vm-rmail-mode))))
 608   (message (if vm-rmail-mode "Rmail cursor mode" "VM cursor mode")))
 609
 610 (defun vm-rmail-up ()
 611   (interactive)
 612   (cond ((and vm-rmail-mode (member major-mode vm-rmail-mode-list))
 613          (next-line -1))
 614         (t
 615          (vm-next-message -1)
 616          (vm-display nil nil '(rf-vm-rmail-up vm-previous-message)
 617                      (list this-command)))))
 618
 619 (defun vm-rmail-down ()
 620   (interactive)
 621   (cond ((and vm-rmail-mode (member major-mode vm-rmail-mode-list))
 622          (next-line 1))
 623         (t
 624          (vm-next-message 1)
 625          (vm-display nil nil '(rf-vm-rmail-up vm-next-message)
 626                      (list this-command)))))
 627
 628 (defun vm-do-with-message (count function vm-display)
 629   (vm-follow-summary-cursor)
 630   (save-excursion
 631     (vm-select-folder-buffer)
 632     (let ((mlist (vm-select-marked-or-prefixed-messages count)))
 633       (while mlist
 634         (funcall function (car mlist))
 635         (vm-mark-for-summary-update (car mlist) t)
 636         (setq mlist (cdr mlist))))
 637     (vm-display nil nil (append vm-display '(vm-do-with-message))
 638                 (list this-command))
 639     (vm-update-summary-and-mode-line)))
 640
 641 (defun vm-toggle-mark (count &optional m)
 642   (interactive "p")
 643   (vm-do-with-message
 644    count
 645    (lambda (m) (vm-set-mark-of m (not (vm-mark-of m))))
 646    '(vm-toggle-mark vm-mark-message marking-message)))
 647
 648 (defun vm-toggle-deleted (count &optional m)
 649   (interactive "p")
 650   (vm-do-with-message
 651    count
 652    (lambda (m) (vm-set-deleted-flag m (not (vm-deleted-flag m))))
 653    '(vm-toggle-deleted vm-delete-message vm-delete-message-backward)))
 654
 655 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 656 (defcustom vm-mail-subject-prefix-replacements
 657   '(("\\(\\(re\\|aw\\|antw\\)\\(\\[[0-9]+\\]\\)?:[ \t]*\\)+" . "Re: ")
 658     ("\\(\\(fo\\|wg\\)\\(\\[[0-9]+\\]\\)?:[ \t]*\\)+" . "Fo: "))
 659   "*List of subject prefixes which should be replaced.
 660 Matching will be done case insentivily."
 661   :group 'vm-rfaddons
 662   :type '(repeat (cons (regexp :tag "Regexp")
 663                        (string :tag "Replacement"))))
 664
 665 (defcustom vm-mail-subject-number-reply nil
 666   "*Non-nil means, add a number [N] after the reply prefix.
 667 The number reflects the number of references."
 668   :group 'vm-rfaddons
 669   :type '(choice
 670           (const :tag "on" t)
 671           (const :tag "off" nil)))
 672
 673 (defun vm-mail-subject-cleanup ()
 674   "Do some subject line clean up.
 675 - Replace subject prefixes according to `vm-replace-subject-prefixes'.
 676 - Add a number after replies is `vm-mail-subject-number-reply' is t.
 677
 678 You might add this function to `vm-mail-mode-hook' in order to clean up the
 679 Subject header."
 680   (interactive)
 681   (save-excursion
 682     ;; cleanup
 683     (goto-char (point-min))
 684     (re-search-forward (regexp-quote mail-header-separator) (point-max))
 685     (let ((case-fold-search t)
 686           (rpl vm-mail-subject-prefix-replacements))
 687       (while rpl
 688         (if (re-search-backward (concat "^Subject:[ \t]*" (caar rpl))
 689                                 (point-min) t)
 690             (replace-match (concat "Subject: " (cdar rpl))))
 691         (setq rpl (cdr rpl))))
 692
 693     ;; add number to replys
 694     (let (refs (start 0) end (count 0))
 695       (when (and vm-mail-subject-number-reply vm-reply-list
 696                  (setq refs  (vm-mail-mode-get-header-contents "References:")))
 697         (while (string-match "<[^<>]+>" refs start)
 698           (setq count (1+ count)
 699                 start (match-end 0)))
 700         (when (> count 1)
 701           (mail-position-on-field "Subject" t)
 702           (setq end (point))
 703           (if (re-search-backward "^Subject:" (point-min) t)
 704               (setq start (point))
 705             (error "Could not find end of Subject header start!"))
 706           (goto-char start)
 707           (if (not (re-search-forward (regexp-quote vm-reply-subject-prefix)
 708                                       end t))
 709               (error "Cound not find vm-reply-subject-prefix `%s' in header!"
 710                      vm-reply-subject-prefix)
 711             (goto-char (match-end 0))
 712             (skip-chars-backward ": \t")
 713             (insert (format "[%d]" count))))))))
 714
 715 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 716 (defun vm-mime-set-8bit-composition-charset (charset &optional buffer-local)
 717   "*Set `vm-mime-8bit-composition-charset' to CHARSET.
 718 With the optional BUFFER-LOCAL prefix arg, this only affects the current
 719 buffer."
 720   (interactive (list (completing-read "Composition charset: "
 721                                       vm-mime-charset-completion-alist
 722                                       nil t)
 723                      current-prefix-arg))
 724   (if (or vm-xemacs-mule-p vm-fsfemacs-p)
 725       (error "vm-mime-8bit-composition-charset has no effect in XEmacs/MULE"))
 726   (if buffer-local
 727       (set (make-local-variable 'vm-mime-8bit-composition-charset) charset)
 728     (setq vm-mime-8bit-composition-charset charset)))
 729
 730 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 731 (defun bbdb/vm-set-virtual-folder-alist ()
 732   "Create a `vm-virtual-folder-alist' according to the records in the bbdb.
 733 For each record that has a 'vm-virtual' attribute, add or modify the
 734 corresponding BBDB-VM-VIRTUAL element of the `vm-virtual-folder-alist'.
 735
 736   (BBDB-VM-VIRTUAL ((vm-primary-inbox)
 737                     (author-or-recipient BBDB-RECORD-NET-REGEXP)))
 738
 739 The element gets added to the 'element-name' sublist of the
 740 `vm-virtual-folder-alist'."
 741   (interactive)
 742   (let (notes-field  email-regexp folder selector)
 743     (dolist (record (bbdb-records))
 744       (setq notes-field (bbdb-record-raw-notes record))
 745       (when (and (listp notes-field)
 746                  (setq folder (cdr (assq 'vm-virtual notes-field))))
 747         (setq email-regexp (mapconcat '(lambda (addr)
 748                                          (regexp-quote addr))
 749                                       (bbdb-record-net record) "\\|"))
 750         (unless (zerop (length email-regexp))
 751           (setq folder (or (assoc folder vm-virtual-folder-alist)
 752                            (car
 753                             (setq vm-virtual-folder-alist
 754                                   (nconc (list (list folder
 755                                                      (list (list vm-primary-inbox)
 756                                                            (list 'author-or-recipient))))
 757                                                vm-virtual-folder-alist))))
 758                 folder (cadr folder)
 759                 selector (assoc 'author-or-recipient folder))
 760
 761           (if (cdr selector)
 762               (if (not (string-match (regexp-quote email-regexp)
 763                                      (cadr selector)))
 764                   (setcdr selector (list (concat (cadr selector) "\\|"
 765                                                  email-regexp))))
 766             (nconc selector (list email-regexp)))))
 767       )
 768     ))
 769
 770 (defun vm-virtual-find-selector (selector-spec type)
 771   "Return the first selector of TYPE in SELECTOR-SPEC."
 772   (let ((s (assoc type selector-spec)))
 773     (unless s
 774       (while (and (not s) selector-spec)
 775         (setq s (and (listp (car selector-spec))
 776                      (vm-virtual-find-selector (car selector-spec) type))
 777               selector-spec (cdr selector-spec))))
 778     s))
 779
 780 (defcustom bbdb/vm-virtual-folder-alist-by-mail-alias-alist nil
 781   "*A list of (ALIAS . FOLDER-NAME) pairs, which map an alias to a folder."
 782   :group 'vm-rfaddons
 783   :type '(repeat (cons :tag "Mapping Definition"
 784                        (regexp :tag "Alias")
 785                        (string :tag "Folder Name"))))
 786
 787 (defun bbdb/vm-set-virtual-folder-alist-by-mail-alias ()
 788   "Create a `vm-virtual-folder-alist' according to the records in the bbdb.
 789 For each record check wheather its alias is in the variable
 790 `bbdb/vm-virtual-folder-alist-by-mail-alias-alist' and then
 791 add/modify the corresponding VM-VIRTUAL element of the
 792 `vm-virtual-folder-alist'.
 793
 794   (BBDB-VM-VIRTUAL ((vm-primary-inbox)
 795                     (author-or-recipient BBDB-RECORD-NET-REGEXP)))
 796
 797 The element gets added to the 'element-name' sublist of the
 798 `vm-virtual-folder-alist'."
 799   (interactive)
 800   (let (notes-field email-regexp mail-aliases folder selector)
 801     (dolist (record (bbdb-records))
 802       (setq notes-field (bbdb-record-raw-notes record))
 803       (when (and (listp notes-field)
 804                  (setq mail-aliases (cdr (assq 'mail-alias notes-field)))
 805                  (setq mail-aliases (bbdb-split mail-aliases ",")))
 806         (setq folder nil)
 807         (while mail-aliases
 808           (setq folder
 809                 (assoc (car mail-aliases)
 810                        bbdb/vm-virtual-folder-alist-by-mail-alias-alist))
 811
 812           (when (and folder
 813                      (setq folder (cdr folder)
 814                            email-regexp (mapconcat '(lambda (addr)
 815                                                       (regexp-quote addr))
 816                                                    (bbdb-record-net record)
 817                                                    "\\|"))
 818                      (> (length email-regexp) 0))
 819             (setq folder (or (assoc folder vm-virtual-folder-alist)
 820                              (car
 821                               (setq vm-virtual-folder-alist
 822                                     (nconc
 823                                      (list
 824                                       (list folder
 825                                             (list (list vm-primary-inbox)
 826                                                   (list 'author-or-recipient))
 827                                             ))
 828                                      vm-virtual-folder-alist))))
 829                   folder (cadr folder)
 830                   selector (vm-virtual-find-selector folder
 831                                                      'author-or-recipient))
 832             (unless selector
 833               (nconc (cdr folder) (list (list 'author-or-recipient))))
 834             (if (cdr selector)
 835                 (if (not (string-match (regexp-quote email-regexp)
 836                                        (cadr selector)))
 837                     (setcdr selector (list (concat (cadr selector) "\\|"
 838                                                    email-regexp))))
 839               (nconc selector (list email-regexp))))
 840           (setq mail-aliases (cdr mail-aliases)))
 841         ))))
 842
 843 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 844 (defcustom vm-handle-return-receipt-mode 'edit
 845   "*Tells `vm-handle-return-receipt' how to handle return receipts.
 846 One can choose between 'ask, 'auto, 'edit or an expression which is evaluated
 847 and which should return t if the return receipts should be sent."
 848   :group 'vm-rfaddons
 849   :type '(choice (const :tag "Edit" edit)
 850                  (const :tag "Ask" ask)
 851                  (const :tag "Auto" auto)))
 852
 853 (defcustom vm-handle-return-receipt-peek 500
 854   "*Number of characters from the original message body to be returned."
 855   :group 'vm-rfaddons
 856   :type '(integer))
 857
 858 (defun vm-handle-return-receipt ()
 859   "Generate a reply to the current message if it requests a return receipt
 860 and has not been replied so far!
 861 See the variable `vm-handle-return-receipt-mode' for customization."
 862   (interactive)
 863   (save-excursion
 864     (vm-select-folder-buffer)
 865     (let* ((msg (car vm-message-pointer))
 866            (sender (vm-get-header-contents msg  "Return-Receipt-To:"))
 867            (mail-signature nil)
 868            (mode (and sender
 869                       (cond ((equal 'ask vm-handle-return-receipt-mode)
 870                              (y-or-n-p "Send a return receipt? "))
 871                             ((symbolp vm-handle-return-receipt-mode)
 872                              vm-handle-return-receipt-mode)
 873                             (t
 874                              (eval vm-handle-return-receipt-mode)))))
 875            (vm-mutable-frames (if (eq mode 'edit) vm-mutable-frames nil))
 876            (vm-mail-mode-hook nil)
 877            (vm-mode-hook nil)
 878            message)
 879       (when (and mode (not (vm-replied-flag msg)))
 880         (vm-reply 1)
 881         (vm-mail-mode-remove-header "Return-Receipt-To:")
 882         (vm-mail-mode-remove-header "To:")
 883         (goto-char (point-min))
 884         (insert "To: " sender "\n")
 885         (mail-text)
 886         (delete-region (point) (point-max))
 887         (insert
 888          (format
 889           "Your mail has been received on %s."
 890           (current-time-string)))
 891         (save-restriction
 892           (save-excursion
 893           (set-buffer (vm-buffer-of msg))
 894           (widen)
 895           (setq message
 896               (buffer-substring
 897                (vm-vheaders-of msg)
 898                (let ((tp (+ vm-handle-return-receipt-peek
 899                             (marker-position
 900                              (vm-text-of msg))))
 901                      (ep (marker-position
 902                           (vm-end-of msg))))
 903                  (if (< tp ep) tp ep))
 904                ))))
 905         (insert "\n-----------------------------------------------------------------------------\n"
 906                 message)
 907         (if (re-search-backward "^\\s-+.*" (point-min) t)
 908             (replace-match ""))
 909         (insert "[...]\n")
 910         (if (not (eq mode 'edit))
 911             (vm-mail-send-and-exit nil))
 912         )
 913       )))
 914
 915 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 916 (defun vm-mime-find-type-of-message/external-body (layout)
 917   (save-excursion
 918     (vm-select-folder-buffer)
 919     (save-restriction
 920       (set-buffer (marker-buffer (vm-mm-layout-body-start layout)))
 921       (widen)
 922       (goto-char (vm-mm-layout-body-start layout))
 923       (if (not (re-search-forward "Content-Type: \"?\\([^ ;\" \n\t]+\\)\"?;?"
 924                                   (vm-mm-layout-body-end layout)
 925                                   t))
 926           (error "No `Content-Type' header found in: %s"
 927                  (buffer-substring (vm-mm-layout-body-start layout)
 928                                    (vm-mm-layout-body-end layout)))
 929         (match-string 1)))))
 930
 931 ;; This is a hack in order to get the right MIME button
 932 ;(defadvice vm-mime-set-extent-glyph-for-type
 933 ;  (around vm-message/external-body-glyph activate)
 934 ;  (if (and (boundp 'real-mime-type)
 935 ;          (string= (ad-get-arg 1) "message/external-body"))
 936 ;      (ad-set-arg 1 real-mime-type))
 937 ;  ad-do-it)
 938
 939 ;;;###autoload
 940 (defun vm-mime-display-button-message/external-body (layout)
 941   "Return a button usable for viewing message/external-body MIME parts.
 942 When you apply `vm-mime-send-body-to-file' with `vm-mime-delete-after-saving'
 943 set to t one will get theses message/external-body parts which point
 944 to the external file.
 945 In order to view these we search for the right viewer hopefully listed
 946 in `vm-mime-external-content-types-alist' and invoke it as it would
 947 have happened before saving.  Otherwise we display the contents as text/plain.
 948 Probably we should be more clever here in order to fake a layout if internal
 949 displaying is possible ...
 950
 951 But nevertheless this allows for keeping folders smaller without
 952 loosing basic functionality when using `vm-mime-auto-save-all-attachments'."
 953   (let ((buffer-read-only nil)
 954         (real-mime-type (vm-mime-find-type-of-message/external-body layout)))
 955     (vm-mime-insert-button
 956      (vm-replace-in-string
 957       (format " external: %s %s"
 958               (if (vm-mime-get-parameter layout "name")
 959                   (file-name-nondirectory (vm-mime-get-parameter layout "name"))
 960                 "")
 961               (let ((tmplayout (copy-tree layout t))
 962                     format)
 963                 (aset tmplayout 0 (list real-mime-type))
 964                 (setq format (vm-mime-find-format-for-layout tmplayout))
 965                 (setq format (vm-replace-in-string format "^%-[0-9]+.[0-9]+"
 966                                                 "%-15.15" t))
 967                 (vm-mime-sprintf format tmplayout)))
 968       "save to a file\\]"
 969       "display as text]")
 970      (function
 971       (lambda (xlayout)
 972         (setq layout (if vm-xemacs-p
 973                          (vm-extent-property xlayout 'vm-mime-layout)
 974                        (overlay-get xlayout 'vm-mime-layout)))
 975         (let* ((type (vm-mime-find-type-of-message/external-body layout))
 976                (viewer (vm-mime-find-external-viewer type))
 977                (filename (vm-mime-get-parameter layout "name")))
 978           (if (car viewer)
 979               (progn
 980                 (message "Viewing %s with %s" filename (car viewer))
 981                 (start-process (format "Viewing %s" filename)
 982                                nil
 983                                (car viewer)
 984                                filename))
 985             (let ((buffer-read-only nil)
 986                   (converter (assoc type vm-mime-type-converter-alist)))
 987               (if vm-xemacs-p
 988                   (delete-region (extent-start-position xlayout)
 989                                  (extent-end-position xlayout))
 990                 (delete-region (overlay-start xlayout) (overlay-end xlayout)))
 991
 992               (if converter
 993                   (shell-command (concat (caddr converter) " < '" filename "'")
 994                                  1)
 995                 (message "Could not find viewer for type %s!" type)
 996                 (insert-file filename))))
 997           )))
 998      layout
 999       nil)))
1000
1001 ;;;###autoload
1002 ;(defun vm-mime-display-internal-message/external-body (layout)
1003 ;  "Display the text of the message/external-body MIME part."
1004 ;  (vm-mime-display-internal-text/plain layout))
1005
1006 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1007 (defcustom vm-mime-all-attachments-directory nil
1008     "*Directory to where the attachments should go or come from."
1009  :group 'vm-rfaddons
1010  :type '(choice (directory :tag "Directory:")
1011                 (const :tag "Use `vm-mime-attachment-save-directory'" nil)))
1012
1013 (defvar vm-mime-save-all-attachments-history nil
1014   "Directory history to where the attachments should go.")
1015
1016 (defvar vm-mime-attach-files-in-directory-regexps-history nil
1017   "Regexp history for matching files.")
1018
1019 (defcustom vm-mime-attach-files-in-directory-default-type nil
1020   "*The default MIME-type for attached files.
1021 If set to nil you will be asked for the type if it cannot be guessed.
1022 For guessing mime-types we use `vm-mime-attachment-auto-type-alist'."
1023   :group 'vm-rfaddons
1024   :type '(choice (const :tag "Ask" nil)
1025                  (string "application/octet-stream")))
1026
1027 (defcustom vm-mime-attach-files-in-directory-default-charset 'guess
1028   "*The default charset used for attached files of type `text'.
1029 If set to nil you will be asked for the charset.
1030 If set to 'guess it will be determined by `vm-determine-proper-charset', but
1031 this may take some time, since the file needs to be visited."
1032   :group 'vm-rfaddons
1033   :type '(choice (const :tag "Ask" nil)
1034                  (const :tag "Guess" guess)))
1035
1036 (defcustom vm-mime-save-all-attachments-types
1037   (append
1038    '("application" "x-unknown" "application/x-gzip")
1039    (mapcar (lambda (a) (car a))
1040            vm-mime-external-content-types-alist))
1041   "*List of MIME types which should be saved."
1042     :group 'vm-rfaddons
1043     :type '(repeat (string :tag "MIME type" nil)))
1044
1045 (defcustom vm-mime-save-all-attachments-types-exceptions
1046   '("text")
1047   "*List of MIME types which should not be saved."
1048   :group 'vm-rfaddons
1049   :type '(repeat (string :tag "MIME type" nil)))
1050
1051 (defcustom vm-mime-delete-all-attachments-types
1052   (append
1053    '("application" "x-unknown" "application/x-gzip")
1054    (mapcar (lambda (a) (car a))
1055            vm-mime-external-content-types-alist))
1056   "*List of MIME types which should be deleted."
1057     :group 'vm-rfaddons
1058     :type '(repeat (string :tag "MIME type" nil)))
1059
1060 (defcustom vm-mime-delete-all-attachments-types-exceptions
1061   '("text")
1062   "*List of MIME types which should not be deleted."
1063   :group 'vm-rfaddons
1064   :type '(repeat (string :tag "MIME type" nil)))
1065
1066 (defvar vm-mime-auto-save-all-attachments-avoid-recursion nil
1067   "For internal use.")
1068
1069 (defun vm-mime-is-type-valid (type types-alist type-exceptions)
1070   (catch 'done
1071     (let ((list type-exceptions)
1072           (matched nil))
1073       (while list
1074         (if (vm-mime-types-match (car list) type)
1075             (throw 'done nil)
1076           (setq list (cdr list))))
1077       (setq list types-alist)
1078       (while (and list (not matched))
1079         (if (vm-mime-types-match (car list) type)
1080             (setq matched t)
1081           (setq list (cdr list))))
1082       matched )))
1083
1084 ;;;###autoload
1085 (defun vm-mime-attach-files-in-directory (directory &optional regexp)
1086   "Attach all files in DIRECTORY matching REGEXP.
1087 The optional argument MATCH might specify a regexp matching all files
1088 which should be attached, when empty all files will be attached.
1089
1090 When called with a prefix arg it will do a literal match instead of a regexp
1091 match."
1092   (interactive
1093    (flet ((substitute-in-file-name (file) file))
1094      (let ((file (vm-read-file-name
1095                   "Attach files matching regexp: "
1096                   (or vm-mime-all-attachments-directory
1097                       vm-mime-attachment-save-directory
1098                       default-directory)
1099                   (or vm-mime-all-attachments-directory
1100                       vm-mime-attachment-save-directory
1101                       default-directory)
1102                   nil nil
1103                   vm-mime-attach-files-in-directory-regexps-history)))
1104        (list (file-name-directory file)
1105              (file-name-nondirectory file)))))
1106
1107   (setq vm-mime-all-attachments-directory directory)
1108
1109   (message "Attaching files matching `%s' from directory %s " regexp directory)
1110
1111   (if current-prefix-arg
1112       (setq regexp (concat "^" (regexp-quote regexp) "$")))
1113
1114   (let ((files (directory-files directory t regexp nil))
1115         file type charset)
1116     (if (null files)
1117         (error "No matching files!")
1118       (while files
1119         (setq file (car files))
1120         (if (file-directory-p file)
1121             nil ;; should we add recursion here?
1122           (setq type (or (vm-mime-default-type-from-filename file)
1123                          vm-mime-attach-files-in-directory-default-type))
1124           (message "Attaching file %s with type %s ..." file type)
1125           (if (null type)
1126               (let ((default-type (or (vm-mime-default-type-from-filename file)
1127                                       "application/octet-stream")))
1128                 (setq type (completing-read
1129                             (format "Content type for %s (default %s): "
1130                                     (file-name-nondirectory file)
1131                                     default-type)
1132                             vm-mime-type-completion-alist)
1133                       type (if (> (length type) 0) type default-type))))
1134           (if (not (vm-mime-types-match "text" type)) nil
1135             (setq charset vm-mime-attach-files-in-directory-default-charset)
1136             (cond ((eq 'guess charset)
1137                    (save-excursion
1138                      (let ((b (get-file-buffer file)))
1139                        (set-buffer (or b (find-file-noselect file t t)))
1140                        (setq charset (vm-determine-proper-charset (point-min)
1141                                                                   (point-max)))
1142                        (if (null b) (kill-buffer (current-buffer))))))
1143                   ((null charset)
1144                    (setq charset
1145                          (completing-read
1146                           (format "Character set for %s (default US-ASCII): "
1147                                   file)
1148                           vm-mime-charset-completion-alist)
1149                          charset (if (> (length charset) 0) charset)))))
1150           (vm-mime-attach-file file type charset))
1151         (setq files (cdr files))))))
1152
1153 (defcustom vm-mime-auto-save-all-attachments-subdir
1154   nil
1155   "*Subdirectory where to save the attachments of a message.
1156 This variable might be set to a string, a function or anything which evaluates
1157 to a string.  If set to nil we use a concatenation of the from, subject and
1158 date header as subdir for the attachments."
1159   :group 'vm-rfaddons
1160   :type '(choice (directory :tag "Directory")
1161                  (string :tag "No Subdir" "")
1162                  (function :tag "Function")
1163                  (sexp :tag "sexp")))
1164
1165 (defun vm-mime-auto-save-all-attachments-subdir (msg)
1166   "Return a subdir for the attachments of MSG.
1167 This will be done according to `vm-mime-auto-save-all-attachments-subdir'."
1168   (setq msg (vm-real-message-of msg))
1169   (when (not (string-match (regexp-quote (vm-su-full-name msg))
1170                            (vm-get-header-contents msg "From:")))
1171     (backtrace)
1172     (if (y-or-n-p (format "Is this wrong? %s <> %s "
1173                          (vm-su-full-name msg)
1174                          (vm-get-header-contents msg "From:")))
1175         (error "Yes it is wrong!")))
1176
1177   (cond ((functionp vm-mime-auto-save-all-attachments-subdir)
1178          (funcall vm-mime-auto-save-all-attachments-subdir msg))
1179         ((stringp vm-mime-auto-save-all-attachments-subdir)
1180          (vm-summary-sprintf vm-mime-auto-save-all-attachments-subdir msg))
1181         ((null vm-mime-auto-save-all-attachments-subdir)
1182          (let (;; for the folder
1183                (basedir (buffer-file-name (vm-buffer-of msg)))
1184                ;; for the message
1185                (subdir (concat
1186                         "/"
1187                         (format "%04s.%02s.%02s-%s"
1188                                 (vm-su-year msg)
1189                                 (vm-su-month-number msg)
1190                                 (vm-su-monthday msg)
1191                                 (vm-su-hour msg))
1192                         "--"
1193                         (vm-decode-mime-encoded-words-in-string
1194                          (or (vm-su-full-name msg)
1195                              "unknown"))
1196                         "--"
1197                         (vm-decode-mime-encoded-words-in-string
1198                          (vm-su-subject msg)))))
1199
1200            (if (and basedir vm-folder-directory
1201                     (string-match
1202                      (concat "^" (expand-file-name vm-folder-directory))
1203                      basedir))
1204                (setq basedir (replace-match "" nil nil basedir)))
1205
1206            (setq subdir (vm-replace-in-string subdir "\\s-\\s-+" " " t))
1207            (setq subdir (vm-replace-in-string subdir "[^A-Za-z0-9\241-_-]+" "_" t))
1208            (setq subdir (vm-replace-in-string subdir "?_-?_" "-" nil))
1209            (setq subdir (vm-replace-in-string subdir "^_+" "" t))
1210            (setq subdir (vm-replace-in-string subdir "_+$" "" t))
1211            (concat basedir "/" subdir)))
1212         (t
1213          (eval vm-mime-auto-save-all-attachments-subdir))))
1214
1215 (defun vm-mime-auto-save-all-attachments-path (msg)
1216   "Create a path for storing the attachments of MSG."
1217   (let ((subdir (vm-mime-auto-save-all-attachments-subdir
1218                  (vm-real-message-of msg))))
1219     (if (not vm-mime-attachment-save-directory)
1220         (error "Set `vm-mime-attachment-save-directory' for autosaving of attachments!")
1221       (if subdir
1222           (if (string-match "/$" vm-mime-attachment-save-directory)
1223               (concat vm-mime-attachment-save-directory subdir)
1224             (concat vm-mime-attachment-save-directory "/" subdir))
1225         vm-mime-attachment-save-directory))))
1226
1227 ;;;###autoload
1228 (defun vm-mime-auto-save-all-attachments (&optional count)
1229   "Save all attachments to a subdirectory.
1230 Root directory for saving is `vm-mime-attachment-save-directory'.
1231
1232 You might add this to `vm-select-new-message-hook' in order to automatically
1233 save attachments.
1234
1235     (add-hook 'vm-select-new-message-hook 'vm-mime-auto-save-all-attachments)
1236 "
1237   (interactive "P")
1238
1239   (if vm-mime-auto-save-all-attachments-avoid-recursion
1240       nil
1241     (let ((vm-mime-auto-save-all-attachments-avoid-recursion t))
1242       (vm-check-for-killed-folder)
1243       (vm-select-folder-buffer)
1244       (vm-check-for-killed-summary)
1245
1246       (vm-mime-save-all-attachments
1247        count
1248        'vm-mime-auto-save-all-attachments-path)
1249
1250       (when (interactive-p)
1251         (vm-discard-cached-data)
1252         (vm-preview-current-message)))))
1253
1254 ;;;###autoload
1255 (defun vm-mime-auto-save-all-attachments-delete-external (msg)
1256   "Deletes the external attachments created by `vm-mime-save-all-attachments'.
1257 You may want to use this function in order to get rid of the external files
1258 when deleting a message.
1259
1260 See the advice in `vm-rfaddons-infect-vm'."
1261   (interactive "")
1262   (vm-check-for-killed-folder)
1263   (vm-select-folder-buffer)
1264   (vm-check-for-killed-summary)
1265   (setq msg (or msg (car vm-message-pointer)))
1266   (if msg
1267       (let ((o (vm-mm-layout msg))
1268             (no 0)
1269             parts layout file type)
1270
1271         (if (eq 'none o)
1272             nil;; this is no mime message
1273           (setq type (car (vm-mm-layout-type o)))
1274
1275           (cond ((or (vm-mime-types-match "multipart/alternative" type)
1276                      (vm-mime-types-match "multipart/mixed" type))
1277                  (setq parts (copy-sequence (vm-mm-layout-parts o))))
1278                 (t (setq parts (list o))))
1279
1280           (while parts
1281             (if (vm-mime-composite-type-p
1282                  (car (vm-mm-layout-type (car parts))))
1283                 (setq parts (nconc (copy-sequence
1284                                     (vm-mm-layout-parts
1285                                      (car parts)))
1286                                    (cdr parts))))
1287
1288             (setq layout (car parts))
1289             (if layout
1290                 (setq type (car (vm-mm-layout-type layout))))
1291
1292             (if (not (string= type "message/external-body"))
1293                 nil
1294               (setq file (vm-mime-get-parameter layout "name"))
1295               (if (and file (file-exists-p file))
1296                   (progn (delete-file file)
1297                          (setq no (+ 1 no)))))
1298             (setq parts (cdr parts))))
1299
1300         (if (> no 0)
1301             (message "%s file%s deleted."
1302                      (if (= no 1) "One" no)
1303                      (if (= no 1) "" "s")))
1304
1305         (if (and file
1306                  (file-name-directory file)
1307                  (file-exists-p (file-name-directory file))
1308                  ;; is the directory empty?
1309                  (let ((files (directory-files (file-name-directory file))))
1310                    (and files (= 2 (length files)))))
1311             (delete-directory (file-name-directory file))))))
1312
1313 (defun vm-mime-action-on-all-attachments (count action
1314                                                 &optional include exclude
1315                                                 mlist
1316                                                 quiet)
1317   "On the next COUNT or marked messages call the function ACTION on those mime
1318 parts which have a filename or the disposition attachment or match with their type
1319 to INCLUDE but not to EXCLUDE (which are lists of mime types).
1320
1321 If QUIET is true no messages are generated.
1322
1323 ACTION will get called with four arguments: MSG LAYOUT TYPE FILENAME."
1324   (unless mlist
1325     (or count (setq count 1))
1326     (vm-check-for-killed-folder)
1327     (vm-select-folder-buffer)
1328     (vm-error-if-folder-empty))
1329
1330   (let ((mlist (or mlist (vm-select-marked-or-prefixed-messages count))))
1331     (save-excursion
1332       (while mlist
1333         (let (parts layout filename type disposition o)
1334           (setq o (vm-mm-layout (car mlist)))
1335           (when (stringp o)
1336             (setq o 'none)
1337             (backtrace (get-buffer-create "*backtrace*"))
1338             (message "There is a bug, see *backtrace* for details"))
1339           (if (eq 'none o)
1340               nil;; this is no mime message
1341             (setq type (car (vm-mm-layout-type o)))
1342
1343             (cond ((or (vm-mime-types-match "multipart/alternative" type)
1344                        (vm-mime-types-match "multipart/mixed" type)
1345                        (vm-mime-types-match "multipart/report" type)
1346                        (vm-mime-types-match "message/rfc822" type)
1347                        )
1348                    (setq parts (copy-sequence (vm-mm-layout-parts o))))
1349                   (t (setq parts (list o))))
1350
1351             (while parts
1352               (if (vm-mime-composite-type-p
1353                    (car (vm-mm-layout-type (car parts))))
1354                   (setq parts (nconc (copy-sequence
1355                                       (vm-mm-layout-parts
1356                                        (car parts)))
1357                                      (cdr parts))))
1358
1359               (setq layout (car parts)
1360                     type (car (vm-mm-layout-type layout))
1361                     disposition (car (vm-mm-layout-disposition layout))
1362                     filename (or (vm-mime-get-disposition-parameter layout "filename")
1363                                  (vm-mime-get-disposition-parameter layout "name")
1364                                  (vm-mime-get-disposition-parameter layout "filename*")
1365                                  (vm-mime-get-disposition-parameter layout "name*")))
1366
1367               (cond ((or filename
1368                          (and disposition (string= disposition "attachment"))
1369                          (and (not (vm-mime-types-match "message/external-body" type))
1370                               include
1371                               (vm-mime-is-type-valid type include exclude)))
1372                      (when (not quiet)
1373                        (message "Action on part type=%s filename=%s disposition=%s!"
1374                                 type filename disposition))
1375                      (funcall action (car mlist) layout type filename))
1376                     ((not quiet)
1377                      (message "No action on part type=%s filename=%s disposition=%s!"
1378                               type filename disposition)))
1379               (setq parts (cdr parts)))))
1380         (setq mlist (cdr mlist))))))
1381
1382 ;;;###autoload
1383 (defun vm-mime-delete-all-attachments (&optional count)
1384   (interactive "p")
1385   (vm-check-for-killed-summary)
1386   (if (interactive-p) (vm-follow-summary-cursor))
1387
1388   (vm-mime-action-on-all-attachments
1389    count
1390    (lambda (msg layout type file)
1391      (message "Deleting `%s%s" type (if file (format " (%s)" file) ""))
1392      (vm-mime-discard-layout-contents layout))
1393    vm-mime-delete-all-attachments-types
1394    vm-mime-delete-all-attachments-types-exceptions)
1395
1396   (when (interactive-p)
1397     (vm-discard-cached-data)
1398     (vm-preview-current-message)))
1399
1400 ;;;###autoload
1401 (defun vm-mime-save-all-attachments (&optional count
1402                                                directory
1403                                                no-delete-after-saving)
1404   "Save all MIME-attachments to DIRECTORY.
1405 When directory does not exist it will be created."
1406   (interactive
1407    (list current-prefix-arg
1408          (vm-read-file-name
1409           "Attachment directory: "
1410           (or vm-mime-all-attachments-directory
1411               vm-mime-attachment-save-directory
1412               default-directory)
1413           (or vm-mime-all-attachments-directory
1414               vm-mime-attachment-save-directory
1415               default-directory)
1416           nil nil
1417           vm-mime-save-all-attachments-history)))
1418
1419   (vm-check-for-killed-summary)
1420   (if (interactive-p) (vm-follow-summary-cursor))
1421
1422   (let ((no 0))
1423     (vm-mime-action-on-all-attachments
1424      count
1425      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed BEGIN
1426      (lambda (msg layout type file)
1427        (let ((directory (if (functionp directory)
1428                             (funcall directory msg)
1429                           directory)))
1430          (setq file (if file
1431                         (expand-file-name (file-name-nondirectory file) directory)
1432                       (vm-read-file-name
1433                        (format "Save %s to file: " type)
1434                        (or directory
1435                            vm-mime-all-attachments-directory
1436                            vm-mime-attachment-save-directory)
1437                        (or directory
1438                            vm-mime-all-attachments-directory
1439                            vm-mime-attachment-save-directory)
1440                        nil nil
1441                        vm-mime-save-all-attachments-history)
1442                       ))
1443
1444          (if (and file (file-exists-p file))
1445              (if (y-or-n-p (format "Overwrite `%s'? " file))
1446                  (delete-file file)
1447                (setq file nil)))
1448
1449          (when file
1450            (message "Saving `%s%s" type (if file (format " (%s)" file) ""))
1451            (make-directory (file-name-directory file) t)
1452            (vm-mime-send-body-to-file layout file file)
1453            (if vm-mime-delete-after-saving
1454                (let ((vm-mime-confirm-delete nil))
1455                  (vm-mime-discard-layout-contents layout
1456                                                   (expand-file-name file))))
1457            (setq no (+ 1 no)))))
1458      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END
1459      ;; attachment filters
1460      vm-mime-save-all-attachments-types
1461      vm-mime-save-all-attachments-types-exceptions)
1462
1463     (when (interactive-p)
1464       (vm-discard-cached-data)
1465       (vm-preview-current-message))
1466
1467     (if (> no 0)
1468         (message "%d attachment%s saved." no (if (= no 1) "" "s"))
1469       (message "No attachments saved!"))))
1470
1471 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1472 ;;;###autoload
1473 (defun vm-mail-check-recipients ()
1474   "Check if the recipients are specified correctly.
1475 Actually it checks only if there are any missing commas or the like in the
1476 headers."
1477   (interactive)
1478   (let ((header-list '("To:" "CC:" "BCC:"
1479                        "Resent-To:" "Resent-CC:" "Resent-BCC:"))
1480         (contents nil)
1481         (errors nil))
1482     (while header-list
1483       (setq contents (vm-mail-mode-get-header-contents (car header-list)))
1484       (if (and contents (string-match "@[^,\"]*@" contents))
1485           (setq errors (vm-replace-in-string
1486                         (format "Missing separator in %s \"%s\"!  "
1487                                 (car header-list)
1488                                 (match-string 0 contents))
1489                         "[\n\t ]+" " ")))
1490       (setq header-list (cdr header-list)))
1491     (if errors
1492         (error errors))))
1493
1494
1495 (defcustom vm-mail-prompt-if-subject-empty t
1496   "*Prompt for a subject when empty."
1497   :group 'vm-rfaddons
1498   :type '(boolean))
1499
1500 ;;;###autoload
1501 (defun vm-mail-check-for-empty-subject ()
1502   "Check if the subject line is empty and issue an error if so."
1503   (interactive)
1504   (let (subject)
1505     (setq subject (vm-mail-mode-get-header-contents "Subject:"))
1506     (if (or (not subject) (string-match "^[ \t]*$" subject))
1507         (if (not vm-mail-prompt-if-subject-empty)
1508             (error "Empty subject")
1509           (mail-position-on-field "Subject")
1510           (insert (read-string "Subject: "))))))
1511
1512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1513 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1514 (defface vm-shrunken-headers-face
1515   '((t (:background "gray")))
1516   "Used for marking shrunken headers."
1517   :group 'vm-faces)
1518
1519 (defvar vm-shrunken-headers-keymap
1520   (let ((map (if vm-xemacs-p (make-keymap) (copy-keymap vm-mode-map))))
1521     (define-key map [(return)]   'vm-shrunken-headers-toggle-this)
1522     (if vm-xemacs-p
1523         (define-key map [(button2)]  'vm-shrunken-headers-toggle-this-mouse)
1524       (define-key map [(mouse-2)]  'vm-shrunken-headers-toggle-this-mouse))
1525     map)
1526   "*Keymap used for shrunken-headers glyphs.")
1527
1528 ;;;###autoload
1529 (defun vm-shrunken-headers-toggle ()
1530   "Toggle display of shrunken headers."
1531   (interactive)
1532   (vm-shrunken-headers 'toggle))
1533
1534 ;;;###autoload
1535 (defun vm-shrunken-headers-toggle-this-mouse (&optional event)
1536   "Toggle display of shrunken headers!"
1537   (interactive "e")
1538   (mouse-set-point event)
1539   (end-of-line)
1540   (vm-shrunken-headers-toggle-this))
1541
1542 ;;;###autoload
1543 (defun vm-shrunken-headers-toggle-this-widget (widget &rest event)
1544   (goto-char (widget-get widget :to))
1545   (end-of-line)
1546   (vm-shrunken-headers-toggle-this))
1547
1548 ;;;###autoload
1549 (defun vm-shrunken-headers-toggle-this ()
1550   "Toggle display of shrunken headers!"
1551   (interactive)
1552
1553   (save-excursion
1554     (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer))
1555         (set-buffer (symbol-value 'vm-mail-buffer)))
1556     (if vm-presentation-buffer
1557         (set-buffer vm-presentation-buffer))
1558     (let ((o (or (car (vm-shrunken-headers-get-overlays (point)))
1559                  (car (vm-shrunken-headers-get-overlays
1560                        (save-excursion (end-of-line)
1561                                        (forward-char 1)
1562                                        (point)))))))
1563       (save-restriction
1564         (narrow-to-region (- (overlay-start o) 7) (overlay-end o))
1565         (vm-shrunken-headers 'toggle)
1566         (widen)))))
1567
1568 (defun vm-shrunken-headers-get-overlays (start &optional end)
1569   (let ((o-list (if end
1570                     (overlays-in start end)
1571                   (overlays-at start))))
1572     (setq o-list (mapcar (lambda (o)
1573                            (if (overlay-get o 'vm-shrunken-headers)
1574                                o
1575                              nil))
1576                          o-list)
1577           o-list (delete nil o-list))))
1578
1579 ;;;###autoload
1580 (defun vm-shrunken-headers (&optional toggle)
1581   "Hide or show headers which occupy more than one line.
1582 Well, one might do it more precisely with only some headers,
1583 but it is sufficient for me!
1584
1585 If the optional argument TOGGLE, then hiding is toggled.
1586
1587 The face used for the visible hidden regions is `vm-shrunken-headers-face' and
1588 the keymap used within that region is `vm-shrunken-headers-keymap'."
1589   (interactive "P")
1590
1591   (save-excursion
1592     (let (headers-start headers-end start end o shrunken)
1593       (if (equal major-mode 'vm-summary-mode)
1594           (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer))
1595               (set-buffer (symbol-value 'vm-mail-buffer))))
1596       (if (equal major-mode 'vm-mode)
1597           (if vm-presentation-buffer
1598               (set-buffer vm-presentation-buffer)))
1599
1600       ;; We cannot use the default functions (vm-headers-of, ...) since
1601       ;; we might also work within a presentation buffer.
1602       (goto-char (point-min))
1603       (setq headers-start (point-min)
1604             headers-end (or (re-search-forward "\n\n" (point-max) t)
1605                             (point-max)))
1606
1607       (cond (toggle
1608              (setq shrunken (vm-shrunken-headers-get-overlays
1609                              headers-start headers-end))
1610              (while shrunken
1611                (setq o (car shrunken))
1612                (let ((w (overlay-get o 'vm-shrunken-headers-widget)))
1613                  (widget-toggle-action w))
1614                (overlay-put o 'invisible (not (overlay-get o 'invisible)))
1615                (setq shrunken (cdr shrunken))))
1616             (t
1617              (goto-char headers-start)
1618              (while (re-search-forward "^\\(\\s-+.*\n\\)+" headers-end t)
1619                (setq start (match-beginning 0) end (match-end 0))
1620                (setq o (vm-shrunken-headers-get-overlays start end))
1621                (if o
1622                    (setq o (car o))
1623                  (setq o (make-overlay (1- start) end))
1624                  (overlay-put o 'face 'vm-shrunken-headers-face)
1625                  (overlay-put o 'mouse-face 'highlight)
1626                  (overlay-put o 'local-map vm-shrunken-headers-keymap)
1627                  (overlay-put o 'priority 10000)
1628                  ;; make a new overlay for the invisibility, the other one we
1629                  ;; made before is just for highlighting and key-bindings ...
1630                  (setq o (make-overlay start end))
1631                  (overlay-put o 'vm-shrunken-headers t)
1632                  (goto-char (1- start))
1633                  (overlay-put o 'start-closed nil)
1634                  (overlay-put o 'vm-shrunken-headers-widget
1635                               (widget-create 'visibility
1636                                              :action
1637                                       'vm-shrunken-headers-toggle-this-widget))
1638                  (overlay-put o 'invisible t)))))
1639       (goto-char (point-min)))))
1640
1641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1642 (defcustom vm-assimilate-html-command "striptags"
1643   "*Command/function which should be called for stripping tags.
1644
1645 When this is a string, then it is a command which is feed with the
1646 html and which should return the text.
1647 Otherwise it should be a Lisp function which performs the stripping of
1648 the tags.
1649
1650 I prefer to use lynx for this job:
1651
1652 #!/bin/tcsh
1653
1654 tmpfile=/tmp/$USER-stripttags.html
1655 cat > $tmpfile
1656 lynx -force_html -dump $tmpfile
1657 rm $tmpfile"
1658   :group 'vm-rfaddons
1659   :type '(string))
1660
1661 (defcustom vm-assimilate-html-mixed t
1662   "*Non-nil values cause messages to be assimilated as text/mixed.
1663 Otherwise they will be assimilated into a text/alternative message."
1664   :group 'vm-rfaddons
1665   :type '(boolean))
1666
1667 ;;;###autoload
1668 (defun vm-assimilate-html-message (&optional plain)
1669   "Try to assimilate a message which is only in html format.
1670 When called with a prefix argument then it will replace the message
1671 with the PLAIN text version otherwise it will create a text/mixed or
1672 text/alternative message depending on the value of the variable
1673 `vm-assimilate-html-mixed'."
1674   (interactive "P")
1675
1676   (let ((vm-frame-per-edit nil)
1677         (boundary (concat (vm-mime-make-multipart-boundary)))
1678         (case-fold-search t)
1679         (qp-encoded nil)
1680         body start end charset)
1681
1682     (vm-edit-message)
1683     (goto-char (point-min))
1684     (goto-char (re-search-forward "\n\n"))
1685
1686     (if (re-search-backward "^Content-Type:\\s-*\\(text/html\\)\\(.*\n?\\(^\\s-.*\\)*\\)$"
1687                             (point-min) t)
1688         (progn (setq charset (buffer-substring (match-beginning 2)
1689                                                (match-end 2)))
1690                (if plain
1691                    (progn (delete-region (match-beginning 1) (match-end 1))
1692                           (goto-char (match-beginning 1))
1693                           (insert "text/plain"))
1694                  (progn (delete-region (match-beginning 1) (match-end 2))
1695                         (goto-char (match-beginning 1))
1696                         (insert "multipart/"
1697                                 (if vm-assimilate-html-mixed "mixed"
1698                                   "alternative") ";\n"
1699                                   "  boundary=\"" boundary "\""))))
1700       (progn
1701         (kill-this-buffer)
1702         (error "This message seems to be no HTML only message!")))
1703
1704     (goto-char (point-min))
1705     (goto-char (re-search-forward "\n\n"))
1706     (setq qp-encoded (re-search-backward "^Content-Transfer-Encoding: quoted-printable"
1707                                          (point-min) t))
1708
1709     (goto-char (re-search-forward "\n\n"))
1710     (if plain
1711         (progn (setq body (point)
1712                      start (point))
1713                (goto-char (point-max))
1714                (setq end (point)))
1715       (progn (insert "--" boundary "\n"
1716                      "Content-Type: text/plain" charset "\n"
1717                      "Content-Transfer-Encoding: 8bit\n\n")
1718              (setq body (point))
1719
1720              (insert "\n--" boundary "\n"
1721                      "Content-Type: text/html" charset "\n"
1722                      "Content-Transfer-Encoding: 8bit\n\n")
1723                (setq start (point-marker))
1724                (goto-char (point-max))
1725                (setq end (point-marker))
1726                (insert "--" boundary "--\n")))
1727
1728     (if qp-encoded (vm-mime-qp-decode-region start end))
1729
1730     (goto-char body)
1731     (if (stringp vm-assimilate-html-command)
1732         (call-process-region start end vm-assimilate-html-command
1733                              plain t)
1734       (funcall vm-assimilate-html-command start end plain))
1735     (vm-edit-message-end)
1736     ))
1737
1738 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1739 ;; Original Authors:  Edwin Huffstutler & John Reynolds
1740
1741 (defcustom vm-mail-mode-citation-kill-regexp-alist
1742   (list
1743    ;; empty lines multi quoted
1744    (cons (concat "^\\(" vm-included-text-prefix "[|{}>:;][^\n]*\n\\)+")
1745          "[...]\n")
1746    ;; empty quoted starting/ending lines
1747    (cons (concat "^\\([^|{}>:;]+.*\\)\n"
1748                  vm-included-text-prefix "[|{}>:;]*$")
1749          "\\1")
1750    (cons (concat "^" vm-included-text-prefix "[|{}>:;]*\n"
1751                  "\\([^|{}>:;]\\)")
1752          "\\1")
1753    ;; empty quoted multi lines
1754    (cons (concat "^" vm-included-text-prefix "[|{}>:;]*\\s-*\n\\("
1755                  vm-included-text-prefix "[|{}>:;]*\\s-*\n\\)+")
1756          (concat vm-included-text-prefix "\n"))
1757    ;; empty lines
1758    (cons "\n\n\n+"
1759          "\n\n")
1760    ;; signature & -----Ursprüngliche Nachricht-----
1761    (cons (concat "^" vm-included-text-prefix "--[^\n]*\n"
1762                  "\\(" vm-included-text-prefix "[^\n]*\n\\)+")
1763          "\n")
1764    (cons (concat "^" vm-included-text-prefix "________[^\n]*\n"
1765                  "\\(" vm-included-text-prefix "[^\n]*\n\\)+")
1766          "\n")
1767    )
1768   "*Regexp replacement pairs for cleaning of replies."
1769   :group 'vm-rfaddons
1770   :type '(repeat (cons :tag "Kill Definition"
1771                        (regexp :tag "Regexp")
1772                        (string :tag "Replacement"))))
1773
1774 (defun vm-mail-mode-citation-clean-up (&optional s e)
1775   "Remove doubly-cited text and extra lines in a mail message."
1776   (interactive)
1777   (if (region-exists-p)
1778       (setq s (point)
1779             e (mark)))
1780   (save-excursion
1781     (mail-text)
1782     (let ((re-alist vm-mail-mode-citation-kill-regexp-alist)
1783           (pmin (point))
1784           re subst)
1785
1786       (while re-alist
1787         (goto-char pmin)
1788         (setq re (caar re-alist)
1789               subst (cdar re-alist))
1790         (while (re-search-forward re (point-max) t)
1791           (replace-match subst))
1792         (setq re-alist (cdr re-alist))))))
1793
1794 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1795 ;;;###autoload
1796 (defun vm-summary-function-S (MSG)
1797   "Return the size of a message in bytes, kilobytes or megabytes.
1798 You may add this to the summary line by \"%US\".
1799 Argument MSG is a message pointer."
1800   (let ((size (- (point-max) (point-min))))
1801     (cond
1802      ((< size 1024)
1803       (format "%d" size))
1804      ((< size 1048576)
1805       (setq size (/ size 1024))
1806       (format "%dK" size))
1807      (t
1808       (setq size (/ size 1048576))
1809       (format "%dM" size)))))
1810
1811
1812 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1813 (defcustom vm-summary-attachment-indicator "$"
1814   "*Indicator shown for messages containing an attachments."
1815   :group 'vm-rfaddons
1816   :type 'string)
1817
1818 (defcustom vm-summary-attachment-label nil
1819   "*Label added to messages containing an attachments."
1820   :group 'vm-rfaddons
1821   :type '(choice (string) (const :tag "No Label" nil)))
1822
1823 (defcustom vm-mime-summary-attachment-label-types nil
1824   "*List of MIME types which should be listed as attachment.
1825 Mime parts with a disposition of attachment or a filename/name disposition
1826 parameter will be automatically considered as attachment."
1827   :group 'vm-rfaddons
1828   :type '(repeat (string :tag "MIME type" nil)))
1829
1830 (defcustom vm-mime-summary-attachment-label-types-exceptions
1831   nil
1832   "*List of MIME types which should not be listed as attachment."
1833   :group 'vm-rfaddons
1834   :type '(repeat (string :tag "MIME type" nil)))
1835
1836 ;;;###autoload
1837 (defun vm-summary-function-A (msg)
1838   "Indicate if there are attachments in a message.
1839 The summary displays a `vm-summary-attachment-indicator', wich is a $ by
1840 default.  In order to get this working, add an \"%1UA\" to your
1841 `vm-summary-format' and call `vm-fix-my-summary!!!'.
1842
1843 As an sideeffect a label can be added to new messages.  Setting
1844 `vm-summary-attachment-label' to a string (the label) enables this.
1845 If you just want the label, then set `vm-summary-attachment-indicator' to nil
1846 and add an \"%0UA\" to your `vm-summary-format'."
1847   (let ((attachments 0))
1848     (setq msg (vm-real-message-of msg))
1849     (vm-mime-action-on-all-attachments
1850      nil
1851      (lambda (msg layout type file)
1852        (setq attachments (1+ attachments)))
1853      vm-mime-summary-attachment-label-types
1854      vm-mime-summary-attachment-label-types-exceptions
1855      (list msg)
1856      t)
1857
1858     (if (= attachments 0 )
1859         ""
1860       (if (and (vm-new-flag msg)
1861                vm-summary-attachment-label
1862                (or (not (vm-labels-of msg))
1863                    (not (member vm-summary-attachment-label
1864                                 (vm-labels-of msg)))))
1865           (vm-set-labels msg (append (list vm-summary-attachment-label)
1866                                      (vm-labels-of msg))))
1867       (or vm-summary-attachment-indicator ""))))
1868
1869 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1870 ;;;###autoload
1871 (defun vm-delete-quit ()
1872   "Delete mails and quit.  Expunge only if it's not the primary inbox!"
1873   (interactive)
1874   (save-excursion
1875     (vm-select-folder-buffer)
1876     (if (and buffer-file-name
1877              (string-match (regexp-quote vm-primary-inbox) buffer-file-name))
1878         (message "No auto-expunge for folder `%s'!" buffer-file-name)
1879       (condition-case nil
1880           (vm-expunge-folder)
1881         (error nil)))
1882     (vm-quit)))
1883
1884 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1885 ;;;###autoload
1886 (defun vm-mail-mode-install-open-line ()
1887   "Install the open-line hooks for `vm-mail-mode'.
1888 Add this to `vm-mail-mode-hook'."
1889   (make-local-hook 'before-change-functions)
1890   (make-local-hook 'after-change-functions)
1891   (add-hook 'before-change-functions 'vm-mail-mode-open-line nil t)
1892   (add-hook 'after-change-functions 'vm-mail-mode-open-line nil t))
1893
1894 (defvar vm-mail-mode-open-line nil
1895   "Flag used by `vm-mail-mode-open-line'.")
1896
1897 (defun vm-mail-mode-open-line (start end &optional length)
1898   "Opens a line when inserting into the region of a reply.
1899
1900 Insert newlines before and after an insert where necessary and does a cleanup
1901 of empty lines which have been quoted."
1902   (if (= start end)
1903       (save-excursion
1904         (beginning-of-line)
1905         (setq vm-mail-mode-open-line
1906               (if (and (eq this-command 'self-insert-command)
1907                        (looking-at (concat "^"
1908                                            (regexp-quote
1909                                             vm-included-text-prefix))))
1910                   (if (< (point) start) (point) start))))
1911     (if (and length (= length 0) vm-mail-mode-open-line)
1912         (let (start-mark end-mark)
1913           (save-excursion
1914             (if (< vm-mail-mode-open-line start)
1915                 (progn
1916                   (insert "\n\n" vm-included-text-prefix)
1917                   (setq end-mark (point-marker))
1918                   (goto-char start)
1919                   (setq start-mark (point-marker))
1920                   (insert "\n\n"))
1921               (if (looking-at (concat "\\("
1922                                       (regexp-quote vm-included-text-prefix)
1923                                       "\\)+[ \t]*\n"))
1924                   (replace-match ""))
1925               (insert "\n\n")
1926               (setq end-mark (point-marker))
1927               (goto-char start)
1928               (setq start-mark (point-marker))
1929               (insert "\n"))
1930
1931             ;; clean leading and trailing garbage
1932             (let ((iq (concat "^" (regexp-quote vm-included-text-prefix)
1933                               "[> \t]*\n")))
1934               (save-excursion
1935                 (goto-char start-mark)
1936                 (beginning-of-line)
1937                 (while (looking-at "^$") (forward-line -1))
1938 ;                (message "1%s<" (buffer-substring (point) (save-excursion (end-of-line) (point))))
1939                 (while (looking-at iq)
1940                   (replace-match "")
1941                   (forward-line -1))
1942                 (goto-char end-mark)
1943                 (beginning-of-line)
1944                 (while (looking-at "^$") (forward-line 1))
1945 ;                (message "3%s<" (buffer-substring (point) (save-excursion (end-of-line) (point))))
1946                 (while (looking-at iq)
1947                   (replace-match "")))))
1948
1949           (setq vm-mail-mode-open-line nil)))))
1950
1951 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1952 (defcustom vm-mail-mode-elide-reply-region "[...]\n"
1953   "*String which is used as replacement for elided text."
1954   :group 'vm-rfaddons
1955   :type '(string))
1956
1957 ;;;###autoload
1958 (defun vm-mail-mode-elide-reply-region (b e)
1959   "Replace marked region or current line with `vm-mail-elide-reply-region'.
1960 B and E are the beginning and end of the marked region or the current line."
1961   (interactive (if (mark)
1962                    (if (< (mark) (point))
1963                        (list (mark) (point))
1964                      (list (point) (mark)))
1965                  (list (save-excursion (beginning-of-line) (point))
1966                        (save-excursion (end-of-line) (point)))))
1967   (if (eobp) (insert "\n"))
1968   (if (mark) (delete-region b e) (delete-region b (+ 1 e)))
1969   (insert vm-mail-mode-elide-reply-region))
1970
1971 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1972 ;;;###autoload
1973 (defun vm-save-everything ()
1974   "Save all VM folder buffers, BBDB and newsrc if GNUS is started."
1975   (interactive)
1976   (save-excursion
1977     (let ((folders (vm-folder-list)))
1978       (while folders
1979         (set-buffer (car folders))
1980         (message "Saving <%S>" (car folders))
1981         (vm-save-folder)
1982         (setq folders (cdr folders))))
1983     (if (fboundp 'bbdb-save-db)
1984         (bbdb-save-db)))
1985   (if (fboundp 'gnus-group-save-newsrc)
1986       (gnus-group-save-newsrc)))
1987
1988 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1989 ;;;###autoload
1990 (defun vm-get-all-new-mail ()
1991   "Get mail for all opened VM folders."
1992   (interactive)
1993   (save-excursion
1994     (let ((buffers (buffer-list)))
1995       (while buffers
1996         (set-buffer (car buffers))
1997         (if (eq major-mode 'vm-mode)
1998             (vm-get-new-mail))
1999         (setq buffers (cdr buffers))))))
2000
2001 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2002 ;;;###autoload
2003 (defun vm-save-message-preview (file)
2004   "Save preview of a message in FILE.
2005 It saves the decoded message and not the raw message like `vm-save-message'!"
2006   (interactive
2007    ;; protect value of last-command
2008    (let ((last-command last-command)
2009          (this-command this-command)
2010          filename)
2011      (vm-follow-summary-cursor)
2012      (vm-select-folder-buffer)
2013      (setq filename
2014       (vm-read-file-name
2015        (if vm-last-written-file
2016            (format "Write text to file: (default %s) "
2017                    vm-last-written-file)
2018          "Write text to file: ")
2019        nil vm-last-written-file nil))
2020      (if (and (file-exists-p filename)
2021               (not (yes-or-no-p (format "Overwrite '%s'? " filename))))
2022          (error "Aborting `vm-save-message-preview'."))
2023      (list filename)))
2024     (save-excursion
2025       (vm-follow-summary-cursor)
2026       (vm-select-folder-buffer)
2027       (vm-check-for-killed-summary)
2028       (vm-error-if-folder-empty)
2029
2030       (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer))
2031           (set-buffer (symbol-value 'vm-mail-buffer))
2032         (if vm-presentation-buffer
2033             (set-buffer vm-presentation-buffer)))
2034       (write-region (point-min) (point-max) file)))
2035
2036 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2037 ;; Subject: Re: How to Delete an attachment?
2038 ;; Newsgroups: gnu.emacs.vm.info
2039 ;; Date: 05 Oct 1999 11:09:19 -0400
2040 ;; Organization: Road Runner
2041 ;; From: Dave Bakhash
2042 (defun vm-mime-take-action-on-attachment (action)
2043   "Do something with the MIME attachment at point."
2044   (interactive
2045    (list (vm-read-string "action: "
2046                          '("save-to-file"
2047                            "delete"
2048                            "display-as-ascii"
2049                            "pipe-to-command")
2050                          nil)))
2051   (vm-mime-run-display-function-at-point
2052    (cond ((string= action "save-to-file")
2053           'vm-mime-send-body-to-file)
2054          ((string= action "display-as-ascii")
2055           'vm-mime-display-body-as-text)
2056          ((string= action "delete")
2057           (vm-delete-mime-object))
2058          ((string= action "pipe-to-command")
2059           'vm-mime-pipe-body-to-queried-command-discard-output))))
2060
2061 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2062 ;; Subject: RE: How to configure for more obvious 'auto decode' attachement.
2063 ;; Newsgroups: gnu.emacs.vm.info
2064 ;; Date: Mon, 20 Sep 1999 21:48:37 GMT
2065 ;; Organization: Deja.com - Share what you know. Learn what you don't.
2066 ;; From: rmirani
2067 (defcustom vm-mime-display-internal-multipart/mixed-separater
2068   "\n----------------------------------------------------------------------\n"
2069   "*The separator which is inserted between the parts of a multipart message."
2070   :group 'vm-rfaddons
2071   :type '(choice (string :tag "Separator")
2072                  (const :tag "No Separator" nil)))
2073
2074 ;;;###autoload
2075 (defun vm-mime-display-internal-multipart/mixed (layout)
2076   "A replacement for VMs default function adding separators.
2077 LAYOUT specifies the layout."
2078
2079   (let ((part-list (vm-mm-layout-parts layout)))
2080     (while part-list
2081       (let ((cur (car part-list)))
2082         (vm-decode-mime-layout cur)
2083         (setq part-list (cdr part-list))
2084         (cond
2085          ((and part-list
2086                (not (vm-mime-should-display-button cur nil))
2087                (vm-mime-should-display-button (car part-list) nil))
2088           ;; do nothing
2089           )
2090          ((and part-list
2091                (not (vm-mime-should-display-button cur nil))
2092                (not (vm-mime-should-display-button (car part-list) nil))
2093                vm-mime-display-internal-multipart/mixed-separater)
2094           (insert vm-mime-display-internal-multipart/mixed-separater)))))
2095     t))
2096
2097 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2098 ;;;###autoload
2099 (defun vm-assimilate-outlook-message ()
2100   "Assimilate a message which has been forwarded by MS Outlook.
2101 You will need vm-pine.el in order to get this work."
2102   (interactive)
2103   (vm-continue-postponed-message t)
2104   (let ((pm (point-max)))
2105     (goto-char (point-min))
2106     (if (re-search-forward "^.*\\(-----Urspr[u]ngliche Nachricht-----\\|-----Original Message-----\\)\n" pm)
2107         (delete-region 1 (match-end 0)))
2108     ;; remove the quotes from the forwarded message
2109     (while (re-search-forward "^> ?" pm t)
2110       (replace-match ""))
2111     (goto-char (point-min))
2112     ;; rewrite headers
2113     (while (re-search-forward "^\\(Von\\|From\\):[ \t]*\\(.+\\) *\\[\\(SMTP\\|mailto\\):\\(.+\\)\\].*" pm t)
2114       (replace-match "From: \\2 <\\4>"))
2115     (while (re-search-forward "^\\(Gesendet[^:]*\\|Sent\\):[ \t]*\\(...\\).*, \\([0-9]+\\)\\. \\(...\\)[a-z]+[ \t]*\\(.*\\)" pm t)
2116       (replace-match "Date: \\3 \\4 \\5"))
2117     (while (re-search-forward "^\\(An\\|To\\):[ \t]*\\(.*\\)$" pm t)
2118       (replace-match "To: \\2"))
2119     (while (re-search-forward "^\\(Betreff\\|Subject\\):[ \t]*\\(.*\\)$" pm t)
2120       (replace-match "Subject: \\2"))
2121     (goto-char (point-min))
2122     ;; insert mail header separator
2123     (re-search-forward "^$" pm)
2124     (goto-char (match-end 0))
2125     (insert mail-header-separator "\n")
2126     ;; and put it back into the source folder
2127     (vm-postpone-message)))
2128
2129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2130 ;; Highlighting faces
2131 ;;;###autoload
2132 (defun vm-install-rf-faces ()
2133   (make-face 'message-url)
2134
2135   (custom-set-faces
2136    '(message-url
2137      ((t (:foreground "blue" :bold t))))
2138    '(message-headers
2139      ((t (:foreground "blue" :bold t))))
2140    '(message-cited-text
2141      ((t (:foreground "red3"))))
2142    '(message-header-contents
2143      ((((type x)) (:foreground "green3"))))
2144    '(message-highlighted-header-contents
2145      ((((type x)) (:bold t))
2146        (t (:bold t)))))
2147
2148   (setq vm-highlight-url-face 'message-url))
2149
2150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2151 ;; Well I like to have a different comment style a provided as default.
2152 ;; I'd like to have blank lines also prefixed by a comment char.
2153 ;; I overwrite the standard function by a slightly different version.
2154 ;;;###autoload
2155 (defun vm-mail-mode-comment-region (beg end &optional arg)
2156   "Comment or uncomment each line in the region BEG to END.
2157 With just a non-nil prefix ARG, uncomment each line in region.
2158 Numeric prefix arg ARG means use ARG comment characters.
2159 If ARG is negative, delete that many comment characters instead.
2160 Comments are terminated on each line, even for syntax in which newline does
2161 not end the comment.  Blank lines do not get comments."
2162   ;; if someone wants it to only put a comment-start at the beginning and
2163   ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x
2164   ;; is easy enough.  No option is made here for other than commenting
2165   ;; every line.
2166   (interactive "r\nP")
2167   (or comment-start (error "No comment syntax is defined"))
2168   (if (> beg end) (let (mid) (setq mid beg beg end end mid)))
2169   (save-excursion
2170     (save-restriction
2171       (let ((cs comment-start) (ce comment-end)
2172             numarg)
2173         (if (consp arg) (setq numarg t)
2174           (setq numarg (prefix-numeric-value arg))
2175           ;; For positive arg > 1, replicate the comment delims now,
2176           ;; then insert the replicated strings just once.
2177           (while (> numarg 1)
2178             (setq cs (concat cs comment-start)
2179                   ce (concat ce comment-end))
2180             (setq numarg (1- numarg))))
2181         ;; Loop over all lines from BEG to END.
2182         (narrow-to-region beg end)
2183         (goto-char beg)
2184         (while (not (eobp))
2185           (if (or (eq numarg t) (< numarg 0))
2186               (progn
2187                 ;; Delete comment start from beginning of line.
2188                 (if (eq numarg t)
2189                     (while (looking-at (regexp-quote cs))
2190                       (delete-char (length cs)))
2191                   (let ((count numarg))
2192                     (while (and (> 1 (setq count (1+ count)))
2193                                 (looking-at (regexp-quote cs)))
2194                       (delete-char (length cs)))))
2195                 ;; Delete comment end from end of line.
2196                 (if (string= "" ce)
2197                     nil
2198                   (if (eq numarg t)
2199                       (progn
2200                         (end-of-line)
2201                         ;; This is questionable if comment-end ends in
2202                         ;; whitespace.  That is pretty brain-damaged,
2203                         ;; though.
2204                         (skip-chars-backward " \t")
2205                         (if (and (>= (- (point) (point-min)) (length ce))
2206                                  (save-excursion
2207                                    (backward-char (length ce))
2208                                    (looking-at (regexp-quote ce))))
2209                             (delete-char (- (length ce)))))
2210                     (let ((count numarg))
2211                       (while (> 1 (setq count (1+ count)))
2212                         (end-of-line)
2213                         ;; This is questionable if comment-end ends in
2214                         ;; whitespace.  That is pretty brain-damaged though
2215                         (skip-chars-backward " \t")
2216                         (save-excursion
2217                           (backward-char (length ce))
2218                           (if (looking-at (regexp-quote ce))
2219                               (delete-char (length ce))))))))
2220                 (forward-line 1))
2221             ;; Insert at beginning and at end.
2222             (progn
2223               (insert cs)
2224               (if (string= "" ce) ()
2225                 (end-of-line)
2226                 (insert ce)))
2227             (search-forward "\n" nil 'move)))))))
2228
2229
2230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2231 ;; Sometimes it's handy to fake a date.
2232 ;; I overwrite the standard function by a slightly different version.
2233 (defcustom vm-mail-mode-fake-date-p t
2234   "*Non-nil means `vm-mail-mode-insert-date-maybe' will not overwrite a existing date header."
2235   :group 'vm-rfaddons
2236   :type '(boolean))
2237
2238
2239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2240 (defun vm-isearch-presentation ()
2241   "Switched to the presentation or preview buffer and starts isearch."
2242   (interactive)
2243   (vm-select-folder-buffer)
2244   (let ((target (or vm-presentation-buffer (current-buffer))))
2245     (if (get-buffer-window-list target)
2246         (select-window (car (get-buffer-window-list target)))
2247       (switch-to-buffer target)))
2248   (isearch-forward))
2249
2250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2251 (defcustom vm-delete-message-action "vm-next-message"
2252   "Forward to next (unread) message after deletion")
2253
2254 ;;;###autoload
2255 (defun vm-delete-message-action (&optional arg)
2256   "Delete current message and perform some action after it, e.g. move to next.
2257 Call it with a prefix ARG to change the action."
2258   (interactive "P")
2259   (when (and (listp arg) (not (null arg)))
2260     (setq vm-delete-message-action
2261           (completing-read "After delete: "
2262                            '(("vm-rmail-up")
2263                              ("vm-rmail-down")
2264                              ("vm-previous-message")
2265                              ("vm-next-message")
2266                              ("vm-previous-unread-message")
2267                              ("vm-next-unread-message")
2268                              ("nothing"))))
2269     (message "action after delete is %S" vm-delete-message-action))
2270   (vm-toggle-deleted (prefix-numeric-value arg))
2271   (let ((fun (intern vm-delete-message-action)))
2272     (if (functionp fun)
2273         (call-interactively fun))))
2274
2275 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2276 (defvar vm-smtp-server-online-p-cache nil
2277   "Alist of cached (server online-status) entries.")
2278
2279 (defun vm-smtp-server-online-p (&optional host port)
2280   "Opens SMTP connection to see if the server HOST on PORT is online.
2281 Results are cached in `smtp-server-online-p-cache' for non interactive
2282 calls."
2283   (interactive)
2284   (save-excursion
2285     (let (online-p server hp)
2286       (if (null host)
2287           (setq server (if (functionp 'esmtpmail-via-smtp-server)
2288                            (esmtpmail-via-smtp-server)
2289                          (smtpmail-via-smtp-server))
2290                 host   (car server)
2291                 port   (cadr server)))
2292       (setq port (or port 25)
2293             hp (format "%s:%s" host port))
2294
2295       (if (interactive-p)
2296           (setq vm-smtp-server-online-p-cache nil))
2297
2298       (if (assoc hp vm-smtp-server-online-p-cache)
2299           ;; take cache content
2300           (setq online-p (cadr (assoc hp vm-smtp-server-online-p-cache))
2301                 hp (concat hp " (cached)"))
2302         ;; do the check
2303         (let* ((n (format " *SMTP server check %s:%s *" host port))
2304                (buf (get-buffer n))
2305                (stream nil))
2306           (if buf (kill-buffer buf))
2307
2308           (condition-case err
2309               (progn
2310                 (setq stream (open-network-stream n n host port))
2311                 (setq online-p t))
2312             (error
2313              (message (cadr err))
2314              (if (and (get-buffer n)
2315                       (< 0 (length (save-excursion
2316                                      (set-buffer (get-buffer n))
2317                                      (buffer-substring (point-min) (point-max))))))
2318                  (pop-to-buffer n))))
2319           (if stream (delete-process stream))
2320           (when (setq buf (get-buffer n))
2321             (set-buffer buf)
2322             (message "%S" (buffer-substring (point-min) (point-max)))
2323             (goto-char (point-min))
2324             (when (re-search-forward
2325                    "gethostbyname: Resource temporarily unavailable"
2326                    (point-max) t)
2327               (setq online-p nil))))
2328
2329         ;; add to cache for further lookups
2330         (add-to-list 'vm-smtp-server-online-p-cache (list hp online-p)))
2331
2332       (if (interactive-p)
2333           (message "SMTP server %s is %s" hp
2334                    (if online-p "online" "offline")))
2335       online-p)))
2336
2337 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2338 (defun vm-mail-send-or-feed-it ()
2339   "Sends a message if the SMTP server is online, queues it otherwise."
2340   (if (not (vm-smtp-server-online-p))
2341       (feedmail-send-it)
2342     (if (functionp 'esmtpmail-send-it)
2343         (esmtpmail-send-it)
2344       (smtpmail-send-it))))
2345
2346 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2347 (provide 'vm-rfaddons)
2348
2349 ;;; vm-rfaddons.el ends here