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