vm

   1 ;; -*- mode: Emacs-Lisp; mode: rainbow; -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;; This program is free software: you can redistribute it and/or modify  ;;
   5 ;; it under the terms of the version 3 of the GNU General Public License ;;
   6 ;; as published by the Free Software Foundation.                         ;;
   7 ;;                                                                       ;;
   8 ;; This program is distributed in the hope that it will be useful, but   ;;
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of            ;;
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      ;;
  11 ;; General Public License for more details.                              ;;
  12 ;;                                                                       ;;
  13 ;; You should have received a copy of the GNU General Public License     ;;
  14 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.  ;;
  15 ;;                                                                       ;;
  16 ;; Written by and Copyright (C) Francois Fleuret                         ;;
  17 ;; Contact <francois@fleuret.org> for comments & bug reports             ;;
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;; A fast indexed / search in mbox
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; This is one of my own things, check my web page to get it
  24
  25 (when (ff/load-or-alert "~/sources/gpl/mymail/mymail-vm.el")
  26
  27   (define-key vm-summary-mode-map "\\" 'mymail/vm-visit-folder)
  28   (define-key global-map [S-f7] 'mymail/vm-visit-folder)
  29   (setq mymail/default-search-request "today"
  30         mymail/default-additional-search-requests "!s ^\\[SPAM\\],!s \\] STATUS,")
  31   (add-to-list 'recentf-exclude "/tmp/mymail-vm-.*\.mbox")
  32 )
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35
  36 ;; Store and restore the window configuration
  37
  38 (defadvice vm (before ff/store-window-configuration nil activate)
  39   (unless (boundp 'ff/window-configuration-before-vm)
  40     (setq ff/window-configuration-before-vm (current-window-configuration)))
  41   )
  42
  43 (defadvice vm-quit (after ff/restore-window-configuration nil activate)
  44   (when (boundp 'ff/window-configuration-before-vm)
  45     (set-window-configuration ff/window-configuration-before-vm)
  46     (makunbound 'ff/window-configuration-before-vm)
  47     )
  48 )
  49
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51
  52 (setq-default vm-summary-show-threads t)
  53
  54 ;; (setq vm-preview-lines nil)
  55
  56 ;; (setq vm-auto-displayed-mime-content-types '("text"));; "multipart"));; "image/xpm"
  57
  58 (setq vm-mime-thumbnail-max-geometry nil)
  59
  60 (setq vm-auto-displayed-mime-content-types '(
  61                                              "text"
  62                                              ;; "image/jpeg"
  63                                              ;; "image/png"
  64                                              "multipart"
  65                                              "message/rfc822"
  66                                              ))
  67
  68
  69 (setq
  70       ;; browse-url-mozilla-program "iceweasel"
  71       ;; mail-complete-style nil
  72       ;; mail-from-style nil
  73       ;; vm-coding-system-priorities '(utf-8)
  74       ;; vm-highlighted-header-regexp "From:\\|Subject:\\|Cc:\\|To:\\|Bcc:\\|Reply-To:"
  75       ;; vm-included-text-attribution-format "\nOn %w, %m %d, at %H, you wrote:\n\n"
  76       ;; vm-jump-to-new-messages nil
  77       ;; vm-mime-7bit-composition-charset "latin-1"
  78       ;; vm-mime-8bit-composition-charset "utf-8"
  79       ;; vm-preview-read-messages t
  80       ;; vm-summary-format " %*%A %-3.3m %2d %5US %I%UA  %s\n"
  81       ;; vm-summary-uninteresting-senders-arrow "->"
  82       ;; vm-summary-uninteresting-senders-arrow "►"
  83       ;; vm-summary-uninteresting-senders-arrow "➔"
  84       ;; vm-summary-uninteresting-senders-arrow "➤"
  85       bbdb-send-mail-style 'vm
  86       bbdb/mail-auto-create-p nil
  87       mail-signature t
  88       mail-specify-envelope-from t
  89       vm-auto-folder-case-fold-search t
  90       vm-auto-get-new-mail t
  91       vm-circular-folders nil
  92       vm-confirm-new-folders t
  93       vm-delete-after-archiving t
  94       vm-delete-after-saving t
  95       vm-forwarding-digest-type "mime"
  96       vm-forwarding-subject-format "(forwarded from %F) %s"
  97       vm-frame-per-folder nil
  98       vm-frame-per-summary nil
  99       vm-highlighted-header-regexp "From:\\|Subject:\\|Reply-To:"
 100       vm-in-reply-to-format nil
 101       vm-included-text-attribution-format "\nOn %w, %m %d, %y (%h), %F wrote:\n\n"
 102       vm-included-text-prefix " > "
 103       vm-keep-sent-messages nil
 104       vm-mime-8bit-composition-charset "iso-8859-1"
 105       vm-mime-attachment-save-directory "~/misc/attachments"
 106       vm-mime-yank-attachments nil
 107       vm-mutable-frames nil
 108       vm-mutable-windows t
 109       vm-netscape-program browse-url-mozilla-program
 110       vm-preview-lines nil
 111       vm-reply-subject-prefix "Re: "
 112       vm-skip-deleted-messages nil
 113       vm-skip-read-messages nil
 114       vm-startup-message-displayed t
 115       vm-startup-with-summary t
 116       vm-summary-arrow "> "
 117       vm-summary-format " %*%a %-3.3m %2d %5US %I%UA  %s\n"
 118       vm-summary-thread-indent-level 1
 119       vm-summary-uninteresting-senders-arrow ">"
 120       vm-use-menus nil
 121       vm-use-toolbar nil
 122       vm-use-toolbar nil
 123       )
 124
 125 ;; (add-to-list 'vm-visible-headers "From " t)
 126 (add-to-list 'vm-visible-headers "Reply-To:" t)
 127 ;; (add-to-list 'vm-visible-headers "X-Mailer:" t)
 128 ;; (add-to-list 'vm-visible-headers "X-from-in-bbdb:" t)
 129 ;; (add-to-list 'vm-visible-headers "Return-Path:")
 130
 131 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 132 ;; Mime-related stuff
 133
 134 (setq
 135
 136  vm-infer-mime-types t
 137  vm-mime-use-image-strips nil
 138  vm-mime-base64-decoder-program "base64"
 139  vm-mime-base64-decoder-switches '("-d")
 140  vm-mime-base64-encoder-program "base64"
 141  vm-mime-base64-encoder-switches '()
 142
 143  vm-mime-internal-content-types '(
 144                                   "multipart"
 145                                   "text"
 146                                   ;; "plain text"
 147                                   ;; "plain text/utf8"
 148                                   "image/xpm"
 149                                   )
 150
 151  ;; To force it to be converted to plain text
 152  ;; vm-mime-internal-content-type-exceptions '("text/html")
 153
 154  vm-mime-external-content-types-alist  '(
 155                                          ("application/x-dvi"      "xdvi")
 156                                          ("image/postscript"       "gv")
 157                                          ("application/pdf"        "xpdf")
 158                                          ("application/postscript" "gv")
 159                                          ("image"                  "pho")
 160                                          ("video"                  "mplayer")
 161                                          ;; ("text/html"              "firefox")
 162                                          ;; ("application/pdf"        "epdfview")
 163                                          )
 164
 165  )
 166
 167 (require 'vm-rfaddons)
 168
 169 ;; The two following lines deal with windows-1252 buggy encoding
 170
 171 ;;**;; ;; First, don't display iso-8859-1 as-is in default face
 172 ;;**;; (delete "iso-8859-1" vm-mime-default-face-charsets)
 173 ;;**;; ;; Then substitute windows-1252 for iso-8859-1
 174 ;;**;; (add-to-list 'vm-mime-mule-charset-to-coding-alist '("iso-8859-1" windows-1252))
 175
 176 ;; (setq vm-mime-default-face-charsets t)
 177
 178 ;; (add-to-list 'vm-mime-default-face-charsets  "utf-8")
 179
 180 ;; (add-to-list 'vm-mime-default-face-charsets "iso-8859-1")
 181 ;; (add-to-list 'vm-mime-default-face-charsets "Windows-1251")
 182 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-non-7bits-in-headers)
 183
 184 (add-hook 'vm-mail-send-hook 'vm-mime-encode-headers)
 185 (add-hook 'vm-mail-send-hook 'vm-mail-check-recipients)
 186 (add-hook 'vm-reply-hook (lambda () (set-buffer-modified-p nil)))
 187
 188 (add-to-list 'vm-mime-attachment-auto-type-alist '(".*" . "application/octet-stream") t)
 189
 190 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "cat"))
 191 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "lynx -nolist -force_html -dump -stdin"))
 192
 193 ;; (add-to-list 'vm-mime-type-converter-alist
 194 ;; '("text/html" "text/plain"
 195 ;; "w3m -cols 75 -graph -dump -T text/html"
 196 ;; ))
 197
 198 ;; (add-to-list 'vm-mime-type-converter-alist
 199              ;; '("text/html" "text/plain"
 200                ;; "html2text -style pretty -nobs"
 201                ;; ))
 202
 203 ;; (add-to-list 'vm-mime-type-converter-alist
 204              ;; '("text/html" "text/plain"
 205                ;; "html2text.sh"
 206                ;; ))
 207
 208 (add-to-list 'vm-mime-type-converter-alist
 209              '("image" "image/xpm"
 210                "/usr/bin/convert -geometry 640x480 - xpm:-"))
 211
 212 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 213
 214 ;; (defun ff/vm-remove-properties () (interactive)
 215 ;; (save-excursion
 216 ;; (goto-char (point-min))
 217 ;; (re-search-forward (concat "^" mail-header-separator "$"))
 218 ;; (set-text-properties (point) (point-max) nil)
 219 ;; )
 220 ;; )
 221
 222 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-properties)
 223
 224 ;; (defun ff/vm-mime-save-all-files (&optional delete)
 225   ;; "Save all the mail attachments. With delete argument, remove
 226 ;; the attachement from mail."
 227   ;; (interactive "P")
 228   ;; (let ((vm-mime-delete-after-saving delete))
 229     ;; (while (and (vm-mime-reader-map-save-file)
 230                 ;; (condition-case nil (vm-move-to-next-button 1)
 231                   ;; (error nil)))))
 232   ;; )
 233
 234 (defun ff/vm-mime-save-file (&optional delete)
 235   "Save the current attachement. With delete argument, remove the
 236 attachement from mail."
 237   (interactive "P")
 238   (let ((vm-mime-delete-after-saving delete))
 239     (vm-mime-reader-map-save-file))
 240   (condition-case nil (vm-move-to-next-button 1) (error (message "No more attachment"))))
 241
 242 ;; (define-key vm-summary-mode-map [(r)] 'vm-reply-include-text)
 243 ;; (define-key vm-summary-mode-map [(R)] 'vm-followup-include-text)
 244
 245 (define-key vm-summary-mode-map [(control o)] 'ff/vm-mime-save-file)
 246
 247 (define-key vm-summary-mode-map [(control t)]
 248   (lambda () (interactive)
 249     (vm-toggle-threads-display)
 250     (unless vm-summary-show-threads
 251       (vm-sort-messages "date"))))
 252
 253 (defun ff/vm-select-thread-for-next-command () (interactive)
 254   (vm-mark-thread-subtree)
 255   (vm-next-command-uses-marks))
 256
 257 (define-key vm-summary-mode-map "T" 'ff/vm-select-thread-for-next-command)
 258
 259 (defun ff/vm-attach-file-or-dir
 260   (&optional dir)
 261   "Attaches the file or recursively the content of the directory with
 262 `vm-mime-attach-file'."
 263   (interactive "fFile or directory: ")
 264
 265   (save-excursion
 266     (goto-char (point-max))
 267     (insert "\n")
 268     (if (file-regular-p dir)
 269         (vm-mime-attach-file dir (vm-mime-default-type-from-filename dir))
 270       (if (file-directory-p dir)
 271           (mapcar
 272            (lambda (x)
 273              (when (not (string-match "^\\." (car x)))
 274                (ff/vm-attach-file-or-dir
 275                 (concat dir
 276                         (unless (string-match "/$" dir) "/")
 277                         (car x)))))
 278            (directory-files-and-attributes dir)
 279            )
 280
 281         (error "Can attach only files and directories")
 282         ))))
 283
 284 (define-key vm-mail-mode-map [(control c) (control a)] 'ff/vm-attach-file-or-dir)
 285
 286 ;; Found no other way to avoid displaying the icones
 287 (load "vm-mime")
 288 (defun vm-mime-set-image-stamp-for-type (e type))
 289
 290 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 291 ;; Summary stuff
 292
 293 (defun vm-summary-function-A (message)
 294   (let* ((from (vm-su-from message)))
 295     (if (string-match vm-summary-uninteresting-senders from)
 296         (concat vm-summary-uninteresting-senders-arrow " " (ff/explicit-name (vm-su-to message)))
 297       (ff/explicit-name from))))
 298
 299 (defun vm-summary-function-S (&optional message)
 300   (let ((s (string-to-int (vm-su-byte-count message))))
 301     (if (> s 32768)
 302         (propertize (concat (int-to-string (/ s 1024)) "k")
 303                     'face 'italic
 304                     )
 305       "")))
 306
 307 (defun ff/vm-delete-and-go-down () (interactive)
 308   ;; (vm-goto-message)
 309   (vm-delete-message 1)
 310   (condition-case nil (vm-next-message-no-skip 1) (error nil)))
 311
 312 (defun ff/vm-expunge-folder ()
 313   (unless vm-folder-read-only (vm-expunge-folder)))
 314
 315 (add-hook 'vm-quit-hook 'ff/vm-expunge-folder)
 316 (add-hook 'vm-quit-hook 'bbdb-save-db)
 317 (add-hook 'vm-retrieved-spooled-mail-hook 'display-time-update)
 318
 319 (ff/configure-faces '((ff/summary-highlight-face :background "yellow"
 320                                                  ;; :weight 'bold
 321                                                  )))
 322
 323 (setq vm-summary-highlight-face 'ff/summary-highlight-face)
 324
 325 (define-key vm-summary-mode-map [(K)] 'ff/vm-delete-and-go-down)
 326
 327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 328 ;; Activate the required modes and authorize the commenting
 329
 330 (defun ff/prepare-mail-mode ()
 331   (bbdb-define-all-aliases)
 332   (flyspell-mode)
 333   (auto-fill-mode)
 334   (mail-abbrevs-setup)
 335   (yas/minor-mode)
 336
 337   ;; (setq fill-paragraph-function 'mail-mode-fill-paragraph)
 338
 339   ;; Since I set the comment prefix, I have to tell the filling
 340   ;; functions not to use it
 341
 342   ;; ******************* removed Aug 23
 343   ;; (setq fill-paragraph-handle-comment nil)
 344   ;; ;; (when message-yank-prefix
 345   (set (make-local-variable 'comment-start) vm-included-text-prefix)
 346   ;; (set (make-local-variable 'comment-start-skip)
 347   ;; (concat "^\\(" (regexp-quote vm-included-text-prefix) "\\)"))
 348   ;; ;; )
 349   )
 350
 351 (add-hook 'mail-mode-hook 'ff/prepare-mail-mode)
 352 ;; (add-hook 'mail-mode-hook 'orgtbl-mode)
 353
 354 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 355 ;; To have a slightly darker background for headers
 356
 357 (ff/configure-faces
 358  ;; '((ff/mail-header-face :background "#c8c8ff"))
 359  '((ff/mail-header-face :background "#f0f0f0"))
 360  ;; '((ff/mail-header-face :foreground "blue4"))
 361  )
 362
 363 (defun ff/colorize-headers () (interactive)
 364   (let ((inhibit-read-only t))
 365     (save-excursion
 366       (goto-char (point-min))
 367       (while (vm-match-header)
 368         (goto-char (vm-matched-header-end)))
 369       (add-text-properties
 370        ;; (vm-matched-header-contents-start)
 371        ;; (vm-matched-header-contents-end)
 372        (point-min)
 373        (point-at-bol)
 374        '(face ff/mail-header-face)
 375        )
 376       )))
 377
 378 (defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
 379   (ff/colorize-headers))
 380
 381 (defun ff/highlight-important-words ()
 382   (let ((inhibit-read-only t))
 383     (save-excursion
 384       (goto-char (point-min))
 385       (while (re-search-forward "Fleuret" nil t)
 386         (message "%d-%d"  (match-beginning 0) (match-end 0))
 387         ;; (add-text-properties (match-beginning 0) (match-end 0)
 388                              ;; '(face (:background "red"))
 389                              ;; )
 390         ))
 391     ))
 392
 393 ;; (add-hook 'vm-select-message-hook 'ff/highlight-important-words)
 394
 395 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 396 ;; I want to have a file associated to every mail I am writing
 397
 398 (defcustom ff/vm-mail-draft-directory "~/"
 399   "Where to save mail drafts with VM")
 400
 401 (defun ff/associate-file-to-vm-mail-buffer ()
 402   "Associate the current buffer to a file whose name is built from the current time."
 403   (unless (buffer-file-name)
 404     (set-visited-file-name (format
 405                             "%s/mail-%s"
 406                             ff/vm-mail-draft-directory
 407                             (format-time-string
 408                              "%04Y%02m%02d-%02H%02M%02S"
 409                              (current-time))))
 410     (set-buffer-modified-p nil)))
 411
 412 (add-hook 'mail-setup-hook 'ff/associate-file-to-vm-mail-buffer)
 413
 414 (defun ff/mail-header-field (field) (interactive)
 415   "Grab the value of a certain field from the mail header."
 416   (let ((s "no-subject"))
 417     (save-excursion
 418       (goto-char (point-min))
 419       (let ((l (re-search-forward (concat "^" mail-header-separator "$") nil t)))
 420         (when l
 421           (goto-char (point-min))
 422           (when (re-search-forward (concat "^" field ": ") l t nil)
 423             (setq s (buffer-substring-no-properties (point) (point-at-eol))))
 424           )
 425         )
 426       )
 427     s))
 428
 429 (defun ff/dissociate-file-from-vm-mail-buffer ()
 430   "Save the file under a new name and set the associated file to nil."
 431   (let ((bn (buffer-file-name)))
 432     (when bn
 433       (set-visited-file-name
 434        (concat (file-name-directory bn)
 435                "sent-"
 436                (file-name-nondirectory bn)
 437                "-"
 438                (replace-regexp-in-string "[^a-zA-Z0-9]+" "_"
 439                                          (ff/mail-header-field "Subject"))
 440                ))
 441       (save-buffer)
 442       (set-visited-file-name nil))
 443     )
 444   )
 445
 446 (defun ff/find-file-in-vm-mail-mode (filename) (interactive)
 447   ;; No easy way to activate vm-mail-mode, so we create such a
 448   ;; buffer, erase its content and insert the file
 449   (vm-compose-mail)
 450   (when (file-exists-p filename)
 451     (erase-buffer)
 452     (insert-file filename))
 453   (set-visited-file-name filename)
 454   (set-buffer-modified-p nil)
 455   ;; (run-hooks find-file-hooks)
 456   (when (functionp 'alarm-vc-check) (alarm-vc-check))
 457   ;; Move the cursor at a convenient location
 458   (when (re-search-forward (concat "^" mail-header-separator "$") nil t)
 459     (if (re-search-forward "^-- $" nil t)
 460         (previous-line 1)
 461       (next-line 1))
 462     (end-of-line))
 463   )
 464
 465 ;; All this mess to activate the vm-mail-mode when loading a file
 466 ;; looking like a mail draft. Did I miss something ?
 467
 468 (defadvice find-file (around ff/find-file-or-mail
 469                              (filename &optional wildcards)
 470                              activate)
 471
 472   (interactive "FFind file: \np")
 473
 474   (if (string-match "^\\(mail\\|sent\\)-[^/]+$"
 475                     (file-name-nondirectory filename))
 476
 477       (if (find-buffer-visiting filename)
 478           (switch-to-buffer (find-buffer-visiting filename))
 479         (ff/find-file-in-vm-mail-mode filename))
 480     ad-do-it
 481     ))
 482
 483 (setq ff/vm-mail-draft-directory "~/private/drafts")
 484
 485 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 486 ;; Check there are no missing attachment (the idea comes from
 487 ;; http://home.cc.gatech.edu/eaganj/MailApp) and no leading "From"
 488 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 489
 490 (defcustom ff/check-vm-attachement-regexp "attach"
 491   "*A mail whose body matches this regular expression should contain
 492 an attachment")
 493
 494 (defun ff/check-vm-attachment ()
 495   (when (save-excursion
 496           (goto-char (point-min))
 497           (and (re-search-forward "\\[ATTACHMENT" nil t)
 498                (not (get-text-property (point) 'vm-mime-object))))
 499     (error "Buggy attachment"))
 500
 501   (if (and
 502        (save-excursion (goto-char (point-min))
 503                        (re-search-forward ff/check-vm-attachement-regexp nil t))
 504        (not (save-excursion (goto-char (point-min))
 505                             (re-search-forward "\\[ATTACHMENT" nil t)))
 506        (not (y-or-n-p "An attachment seems to be missing, send message ? ")))
 507       (error "You refer to an unexisting attachment."))
 508
 509   )
 510
 511 (defun ff/check-no-prolematic-dest ()
 512   "Check that there are no \">,[^\ $]\" in the header"
 513   (let ((s "no-subject"))
 514     (save-excursion
 515       (goto-char (point-min))
 516       (let ((end-header (re-search-forward (concat "^" mail-header-separator "$") nil t)))
 517         (when end-header
 518           (goto-char (point-min))
 519           (re-search-forward ">,[^\ ]" end-header t nil)
 520           )
 521         )
 522       )
 523     s))
 524
 525
 526 ;; You can not have a line starting with "From:" in a pure text
 527 ;; mail. The smtp server would add a leading character to prevent it.
 528
 529 (defun ff/check-no-leading-from ()
 530   (and (let ((case-fold-search nil))
 531          (save-excursion
 532            (goto-char (point-min))
 533            (re-search-forward (concat "^" mail-header-separator "$"))
 534            (re-search-forward "^From " nil t)))
 535        (not (y-or-n-p "There is a leading ``From '', send message ? "))
 536        (error "There is a leading ``From ''.")))
 537
 538 ;; An attempt at limiting excess wording in sent mails
 539
 540 (defface ff/strong-words
 541   '((t (:background "red")))
 542   "The face to highlight upper caps, exclamation marks and such.")
 543
 544 (defun ff/max-in-a-row (overlay regexp max)
 545   (let ((case-fold-search nil))
 546     (save-excursion
 547       (goto-char (point-min))
 548       (re-search-forward (concat "^" mail-header-separator "$"))
 549       (when (and (re-search-forward regexp nil t nil)
 550                  (>= (- (match-end 0) (match-beginning 0)) max))
 551         (move-overlay overlay (match-beginning 0) (match-end 0))
 552         t))))
 553
 554 (defun ff/check-no-excess-wording () (interactive)
 555   (let ((overlay (make-overlay 0 0)))
 556     (overlay-put overlay 'face 'media/current-tune-face)
 557     (let ((err (and
 558                 (or (ff/max-in-a-row overlay "[A-Z\?\!][A-Z\?\! ]+[A-Z\?\!]" 6)
 559                     (ff/max-in-a-row overlay "[\?\!]+" 2)
 560                     )
 561                 (not (y-or-n-p "That does not look good. Send message ? ")))))
 562       (delete-overlay overlay)
 563       (when err (error "Good idea. Chill out a bit.")))
 564     ))
 565
 566 (defun ff/check-badly-encoded-address () (interactive)
 567   (let (bodysep bad-adr)
 568     (save-excursion
 569       (goto-char (point-min))
 570       (search-forward mail-header-separator)
 571       (setq bodysep (vm-marker (match-beginning 0)))
 572       (goto-char (point-min))
 573       (setq bad-adr (re-search-forward "[^<a-zA-Z_0-9\-\. \n\t]+[^ \n]*@" nil t))
 574       (when (and bad-adr (< bad-adr bodysep))
 575         (error "There is an invalid address in the header (%s)"
 576                (match-string 0)))))
 577   )
 578
 579 (add-hook 'vm-mail-send-hook 'ff/check-vm-attachment)
 580 (add-hook 'vm-mail-send-hook 'ff/check-no-leading-from)
 581 (add-hook 'vm-mail-send-hook 'ff/check-no-excess-wording)
 582 (add-hook 'vm-mail-send-hook 'flyspell-mode-off)
 583
 584 (defadvice vm-mail-send-and-exit (before ff/switch-flyspell-off nil activate)
 585   (flyspell-mode-off))
 586
 587 ;; Append so that it happens after the mime encoding
 588 ;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
 589
 590 ;; Append this hook so that it runs after all other checks
 591 (add-hook 'vm-mail-send-hook 'ff/dissociate-file-from-vm-mail-buffer t)
 592
 593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 594 ;; If we can, encrypt!
 595
 596 (add-hook 'vm-mode-hook 'mc-install-read-mode)
 597 (add-hook 'vm-summary-mode-hook 'mc-install-read-mode)
 598 (add-hook 'vm-virtual-mode-hook 'mc-install-read-mode)
 599 (add-hook 'vm-mail-mode-hook 'mc-install-write-mode)
 600 (add-hook 'vm-presentation-mode-hook 'mc-install-read-mode)
 601
 602 ;; (defun ff/encrypt-mail-if-possible () (interactive)
 603   ;; (condition-case nil (mc-encrypt-message)
 604     ;; (error nil)))
 605
 606 ;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)
 607
 608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 609 ;; Composing a mail
 610
 611 ;; Move through important points in the mail ("To:" field, "Subject:"
 612 ;; field and the end of the body)
 613
 614 (defun ff/goto-next-mail-field () (interactive)
 615   (let ((field (save-excursion
 616                  (end-of-line)
 617                  (re-search-backward
 618                   (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
 619                  (match-string 1))))
 620
 621     (cond ((string= field "To: ")
 622            (expand-abbrev)
 623            (re-search-forward "Subject: ")
 624            (end-of-line))
 625
 626           ((string= field "Subject: ")
 627            (re-search-forward (concat "^" mail-header-separator "$"))
 628            (if (re-search-forward "^-- $" nil t)
 629                (previous-line 1)
 630              (next-line 1))
 631            (end-of-line))
 632
 633           (t (beginning-of-buffer)
 634              (re-search-forward "^To: ")
 635              (end-of-line)
 636              (re-search-forward "^[a-zA-Z\-]*: ")
 637              (beginning-of-line)
 638              (backward-char)))))
 639
 640 ;; (define-key vm-mail-mode-map [(control tab)] 'ff/goto-next-mail-field)
 641 (define-key vm-mail-mode-map [(iso-lefttab)] 'ff/goto-next-mail-field)
 642 ;; (define-key vm-mail-mode-map [(shift iso-lefttab)] 'mail-mode-smart-tab)
 643 (define-key vm-mail-mode-map [(shift iso-lefttab)] 'bbdb-complete-name)
 644
 645 ;; The definition of "\t" is forced through a hook defined in
 646 ;; vm-init.el, so I add mine. This is ugly.
 647
 648 (add-hook 'mail-setup-hook
 649           '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
 650           t)
 651
 652 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
 653
 654 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
 655
 656 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 657 ;; I rarely edit two mails at the same time, and it makes sense to
 658 ;; come back to the one currently being edited with the same function
 659
 660 (defun ff/first-buffer-in-mode (l m)
 661   (if l
 662       (if (eq (save-excursion
 663                 (set-buffer (car l)) major-mode) m)
 664           (car l)
 665         (ff/first-buffer-in-mode (cdr l) m))))
 666
 667 (defun ff/compose-mail (&optional force-new)
 668   "Cycles through an existing buffers with major mode `mail-mode',
 669 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
 670 is t."
 671   (interactive "P")
 672   (when (eq major-mode 'mail-mode) (bury-buffer))
 673   (let ((buf (and (not force-new)
 674                   (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
 675     (if buf (switch-to-buffer buf)
 676       (vm-compose-mail))))
 677
 678 (define-key global-map [(control x) (m)] 'ff/compose-mail)
 679
 680 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 681 ;; bbdb
 682
 683 (load "bbdb")
 684 (load "bbdb-hooks")
 685
 686 (when (load "bbdb-vm" t)
 687
 688   (defun ff/mail-aliases-from-bbdb ()
 689     "Creates automatically mail aliases from the bbdb records. For
 690 instance, someone in bbdb named \"Paul Smith\" would generate an alias
 691 'pm'. Does not replace existing aliases."
 692     (interactive)
 693     (let* ((records (bbdb-records)))
 694       (while records
 695         (let* ((record (car records))
 696                (name (concat (elt record 0) " " (elt record 1)))
 697                (email (car (elt record 6)))
 698                (alias (downcase (replace-regexp-in-string
 699                                  "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
 700           (if (and email
 701                    (> (length alias) 1)
 702                    ;; Do not overwrite an existing alias
 703                    (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
 704               (define-mail-abbrev alias email))
 705           (setq records (cdr records))))))
 706
 707   (when (>= emacs-major-version 22)
 708     (bbdb-insinuate-vm)
 709     (ff/mail-aliases-from-bbdb)
 710     )
 711   )
 712
 713 (defun ff/pipe-to-tmp () (interactive)
 714   (let ((link "/tmp/attach")
 715         (dir (format-time-string "/tmp/attach-%Y%m%d-%H%M%S" (current-time))))
 716     (mkdir dir)
 717     (when (file-symlink-p link) (delete-file link))
 718     (unless (file-exists-p link)
 719       (make-symbolic-link dir "/tmp/attach" 1))
 720     (vm-pipe-message-to-command (concat "munpack -C " dir))
 721     (message "Wrote files to %s" dir)
 722     )
 723   )
 724
 725 (defun ff/make-nonexisting-filename (filename)
 726   (let ((root filename)
 727         (extension "")
 728         (result filename))
 729     (when (file-exists-p result)
 730       (when (string-match "^\\(.*\\)\\(\\.[^\\.]*\\)$" filename)
 731         (setq root (match-string 1 filename)
 732               extension (match-string 2 filename)))
 733       (let ((n 0))
 734         (while (file-exists-p (setq result (format "%s_%03d%s" root n extension)))
 735           (setq n (+ n 1)))))
 736     result))
 737
 738 (defun ff/vm-mime-save-all-attachments (&optional count
 739                                                directory
 740                                                no-delete-after-saving)
 741   "Save all attachments in the next COUNT messages or marked
 742 messages.  For the purpose of this function, an \"attachment\" is
 743 a mime part part which has \"attachment\" as its disposition or
 744 simply has an associated filename.  Any mime types that match
 745 `vm-mime-savable-types' but not `vm-mime-savable-type-exceptions'
 746 are also included.
 747
 748 The attachments are saved to the specified DIRECTORY.  The
 749 variables `vm-all-attachments-directory' or
 750 `vm-mime-attachment-save-directory' can be used to set the
 751 default location.  When directory does not exist it will be
 752 created."
 753   (interactive
 754    (list current-prefix-arg
 755          (vm-read-file-name
 756           "Attachment directory: "
 757           (or vm-mime-all-attachments-directory
 758               vm-mime-attachment-save-directory
 759               default-directory)
 760           (or vm-mime-all-attachments-directory
 761               vm-mime-attachment-save-directory
 762               default-directory)
 763           nil nil
 764           vm-mime-save-all-attachments-history)))
 765
 766   (vm-check-for-killed-summary)
 767   (if (interactive-p) (vm-follow-summary-cursor))
 768
 769   (let ((n 0))
 770     (vm-mime-action-on-all-attachments
 771      count
 772      ;; the action to be performed BEGIN
 773      (lambda (msg layout type file)
 774        (let ((directory (if (functionp directory)
 775                             (funcall directory msg)
 776                           directory)))
 777          (setq file
 778                (if file
 779                    (expand-file-name (file-name-nondirectory file) directory)
 780                  (vm-read-file-name
 781                   (format "Save %s to file: " type)
 782                   (or directory
 783                       vm-mime-all-attachments-directory
 784                       vm-mime-attachment-save-directory)
 785                   (or directory
 786                       vm-mime-all-attachments-directory
 787                       vm-mime-attachment-save-directory)
 788                   nil nil
 789                   vm-mime-save-all-attachments-history)
 790                  ))
 791
 792          (setq file (ff/make-nonexisting-filename file))
 793
 794          (when file
 795            (message "Saving `%s%s" type (if file (format " (%s)" file) ""))
 796            (make-directory (file-name-directory file) t)
 797            (vm-mime-send-body-to-file layout file file)
 798            (if vm-mime-delete-after-saving
 799                (let ((vm-mime-confirm-delete nil))
 800                  (vm-mime-discard-layout-contents
 801                   layout (expand-file-name file))))
 802            (setq n (+ 1 n)))))
 803      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END
 804      ;; attachment filters
 805      vm-mime-savable-types
 806      vm-mime-savable-type-exceptions)
 807
 808     (when (interactive-p)
 809       (vm-discard-cached-data)
 810       (vm-preview-current-message))
 811
 812     (if (> n 0)
 813         (message "%d attachment%s saved" n (if (= n 1) "" "s"))
 814       (message "No attachments to be saved!"))))
 815
 816 (define-key vm-summary-mode-map [(control c) (control s)] 'ff/vm-mime-save-all-attachments)