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