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