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
 166 (add-hook 'vm-mail-send-hook 'vm-mime-encode-headers)
 167 (add-hook 'vm-mail-send-hook 'vm-mail-check-recipients)
 168 (add-hook 'vm-reply-hook (lambda () (set-buffer-modified-p nil)))
 169
 170 (add-to-list 'vm-mime-attachment-auto-type-alist '(".*" . "application/octet-stream") t)
 171
 172 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "cat"))
 173 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "lynx -nolist -force_html -dump -stdin"))
 174
 175 ;; (add-to-list 'vm-mime-type-converter-alist
 176 ;; '("text/html" "text/plain"
 177 ;; "w3m -cols 75 -graph -dump -T text/html"
 178 ;; ))
 179
 180 ;; (add-to-list 'vm-mime-type-converter-alist
 181              ;; '("text/html" "text/plain"
 182                ;; "html2text -style pretty -nobs"
 183                ;; ))
 184
 185 ;; (add-to-list 'vm-mime-type-converter-alist
 186              ;; '("text/html" "text/plain"
 187                ;; "html2text.sh"
 188                ;; ))
 189
 190 (add-to-list 'vm-mime-type-converter-alist
 191              '("image" "image/xpm"
 192                "/usr/bin/convert -geometry 640x480 - xpm:-"))
 193
 194 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 195
 196 ;; (defun ff/vm-remove-properties () (interactive)
 197 ;; (save-excursion
 198 ;; (goto-char (point-min))
 199 ;; (re-search-forward (concat "^" mail-header-separator "$"))
 200 ;; (set-text-properties (point) (point-max) nil)
 201 ;; )
 202 ;; )
 203
 204 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-properties)
 205
 206 ;; (defun ff/vm-mime-save-all-files (&optional delete)
 207   ;; "Save all the mail attachments. With delete argument, remove
 208 ;; the attachement from mail."
 209   ;; (interactive "P")
 210   ;; (let ((vm-mime-delete-after-saving delete))
 211     ;; (while (and (vm-mime-reader-map-save-file)
 212                 ;; (condition-case nil (vm-move-to-next-button 1)
 213                   ;; (error nil)))))
 214   ;; )
 215
 216 (defun ff/vm-mime-save-file (&optional delete)
 217   "Save the current attachement. With delete argument, remove the
 218 attachement from mail."
 219   (interactive "P")
 220   (let ((vm-mime-delete-after-saving delete))
 221     (vm-mime-reader-map-save-file))
 222   (condition-case nil (vm-move-to-next-button 1) (error (message "No more attachment"))))
 223
 224 ;; (define-key vm-summary-mode-map [(r)] 'vm-reply-include-text)
 225 ;; (define-key vm-summary-mode-map [(R)] 'vm-followup-include-text)
 226
 227 (define-key vm-summary-mode-map [(control o)] 'ff/vm-mime-save-file)
 228
 229 (define-key vm-summary-mode-map [(control t)]
 230   (lambda () (interactive)
 231     (vm-toggle-threads-display)
 232     (unless vm-summary-show-threads
 233       (vm-sort-messages "date"))))
 234
 235 (defun ff/vm-select-thread-for-next-command () (interactive)
 236   (vm-mark-thread-subtree)
 237   (vm-next-command-uses-marks))
 238
 239 (define-key vm-summary-mode-map "T" 'ff/vm-select-thread-for-next-command)
 240
 241 (defun ff/vm-attach-file-or-dir
 242   (&optional dir)
 243   "Attaches the file or recursively the content of the directory with
 244 `vm-mime-attach-file'."
 245   (interactive "fFile or directory: ")
 246
 247   (save-excursion
 248     (goto-char (point-max))
 249     (insert "\n")
 250     (if (file-regular-p dir)
 251         (vm-mime-attach-file dir (vm-mime-default-type-from-filename dir))
 252       (if (file-directory-p dir)
 253           (mapcar
 254            (lambda (x)
 255              (when (not (string-match "^\\." (car x)))
 256                (ff/vm-attach-file-or-dir
 257                 (concat dir
 258                         (unless (string-match "/$" dir) "/")
 259                         (car x)))))
 260            (directory-files-and-attributes dir)
 261            )
 262
 263         (error "Can attach only files and directories")
 264         ))))
 265
 266 (define-key vm-mail-mode-map [(control c) (control a)] 'ff/vm-attach-file-or-dir)
 267
 268 ;; Found no other way to avoid displaying the icones
 269 (load "vm-mime")
 270 (defun vm-mime-set-image-stamp-for-type (e type))
 271
 272 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 273 ;; Summary stuff
 274
 275 (defun vm-summary-function-A (message)
 276   (let* ((from (vm-su-from message)))
 277     (if (string-match vm-summary-uninteresting-senders from)
 278         (concat vm-summary-uninteresting-senders-arrow " " (ff/explicit-name (vm-su-to message)))
 279       (ff/explicit-name from))))
 280
 281 (defun vm-summary-function-S (&optional message)
 282   (let ((s (string-to-int (vm-su-byte-count message))))
 283     (if (> s 32768)
 284         (propertize (concat (int-to-string (/ s 1024)) "k")
 285                     'face 'italic
 286                     )
 287       "")))
 288
 289 (defun ff/vm-delete-and-go-down () (interactive)
 290   ;; (vm-goto-message)
 291   (vm-delete-message 1)
 292   (condition-case nil (vm-next-message-no-skip 1) (error nil)))
 293
 294 (defun ff/vm-expunge-folder ()
 295   (unless vm-folder-read-only (vm-expunge-folder)))
 296
 297 (add-hook 'vm-quit-hook 'ff/vm-expunge-folder)
 298 (add-hook 'vm-quit-hook 'bbdb-save-db)
 299 (add-hook 'vm-retrieved-spooled-mail-hook 'display-time-update)
 300
 301 (ff/configure-faces '((ff/summary-highlight-face :background "yellow"
 302                                                  ;; :weight 'bold
 303                                                  )))
 304
 305 (setq vm-summary-highlight-face 'ff/summary-highlight-face)
 306
 307 (define-key vm-summary-mode-map [(K)] 'ff/vm-delete-and-go-down)
 308
 309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 310 ;; Activate the required modes and authorize the commenting
 311
 312 (defun ff/prepare-mail-mode ()
 313   (bbdb-define-all-aliases)
 314   (flyspell-mode)
 315   (auto-fill-mode)
 316   (mail-abbrevs-setup)
 317   (yas/minor-mode)
 318
 319   ;; (setq fill-paragraph-function 'mail-mode-fill-paragraph)
 320
 321   ;; Since I set the comment prefix, I have to tell the filling
 322   ;; functions not to use it
 323
 324   ;; ******************* removed Aug 23
 325   ;; (setq fill-paragraph-handle-comment nil)
 326   ;; ;; (when message-yank-prefix
 327   (set (make-local-variable 'comment-start) vm-included-text-prefix)
 328   ;; (set (make-local-variable 'comment-start-skip)
 329   ;; (concat "^\\(" (regexp-quote vm-included-text-prefix) "\\)"))
 330   ;; ;; )
 331   )
 332
 333 (add-hook 'mail-mode-hook 'ff/prepare-mail-mode)
 334 ;; (add-hook 'mail-mode-hook 'orgtbl-mode)
 335
 336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 337 ;; To have a slightly darker background for headers
 338
 339 (ff/configure-faces
 340  ;; '((ff/mail-header-face :background "#c8c8ff"))
 341  '((ff/mail-header-face :background "#f0f0f0"))
 342  ;; '((ff/mail-header-face :foreground "blue4"))
 343  )
 344
 345 (defun ff/colorize-headers () (interactive)
 346   (let ((inhibit-read-only t))
 347     (save-excursion
 348       (goto-char (point-min))
 349       (while (vm-match-header)
 350         (goto-char (vm-matched-header-end)))
 351       (add-text-properties
 352        ;; (vm-matched-header-contents-start)
 353        ;; (vm-matched-header-contents-end)
 354        (point-min)
 355        (point-at-bol)
 356        '(face ff/mail-header-face)
 357        )
 358       )))
 359
 360 (defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
 361   (ff/colorize-headers))
 362
 363 (defun ff/highlight-important-words ()
 364   (let ((inhibit-read-only t))
 365     (save-excursion
 366       (goto-char (point-min))
 367       (while (re-search-forward "Fleuret" nil t)
 368         (message "%d-%d"  (match-beginning 0) (match-end 0))
 369         ;; (add-text-properties (match-beginning 0) (match-end 0)
 370                              ;; '(face (:background "red"))
 371                              ;; )
 372         ))
 373     ))
 374
 375 ;; (add-hook 'vm-select-message-hook 'ff/highlight-important-words)
 376
 377 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 378 ;; I want to have a file associated to every mail I am writing
 379
 380 (defcustom ff/vm-mail-draft-directory "~/"
 381   "Where to save mail drafts with VM")
 382
 383 (defun ff/associate-file-to-vm-mail-buffer ()
 384   "Associate the current buffer to a file whose name is built from the current time."
 385   (unless (buffer-file-name)
 386     (set-visited-file-name (format
 387                             "%s/mail-%s"
 388                             ff/vm-mail-draft-directory
 389                             (format-time-string
 390                              "%04Y%02m%02d-%02H%02M%02S"
 391                              (current-time))))
 392     (set-buffer-modified-p nil)))
 393
 394 (add-hook 'mail-setup-hook 'ff/associate-file-to-vm-mail-buffer)
 395
 396 (defun ff/mail-header-field (field) (interactive)
 397   "Grab the value of a certain field from the mail header."
 398   (let ((s "no-subject"))
 399     (save-excursion
 400       (goto-char (point-min))
 401       (let ((l (re-search-forward (concat "^" mail-header-separator "$") nil t)))
 402         (when l
 403           (goto-char (point-min))
 404           (when (re-search-forward (concat "^" field ": ") l t nil)
 405             (setq s (buffer-substring-no-properties (point) (point-at-eol))))
 406           )
 407         )
 408       )
 409     s))
 410
 411 (defun ff/dissociate-file-from-vm-mail-buffer ()
 412   "Save the file under a new name and set the associated file to nil."
 413   (let ((bn (buffer-file-name)))
 414     (when bn
 415       (set-visited-file-name
 416        (concat (file-name-directory bn)
 417                "sent-"
 418                (file-name-nondirectory bn)
 419                "-"
 420                (replace-regexp-in-string "[^a-zA-Z0-9]+" "_"
 421                                          (ff/mail-header-field "Subject"))
 422                ))
 423       (save-buffer)
 424       (set-visited-file-name nil))
 425     )
 426   )
 427
 428 (defun ff/find-file-in-vm-mail-mode (filename) (interactive)
 429   ;; No easy way to activate vm-mail-mode, so we create such a
 430   ;; buffer, erase its content and insert the file
 431   (vm-compose-mail)
 432   (when (file-exists-p filename)
 433     (erase-buffer)
 434     (insert-file filename))
 435   (set-visited-file-name filename)
 436   (set-buffer-modified-p nil)
 437   ;; (run-hooks find-file-hooks)
 438   (when (functionp 'alarm-vc-check) (alarm-vc-check))
 439   ;; Move the cursor at a convenient location
 440   (when (re-search-forward (concat "^" mail-header-separator "$") nil t)
 441     (if (re-search-forward "^-- $" nil t)
 442         (previous-line 1)
 443       (next-line 1))
 444     (end-of-line))
 445   )
 446
 447 ;; All this mess to activate the vm-mail-mode when loading a file
 448 ;; looking like a mail draft. Did I miss something ?
 449
 450 (defadvice find-file (around ff/find-file-or-mail
 451                              (filename &optional wildcards)
 452                              activate)
 453
 454   (interactive "FFind file: \np")
 455
 456   (if (string-match "^\\(mail\\|sent\\)-[^/]+$"
 457                     (file-name-nondirectory filename))
 458
 459       (if (find-buffer-visiting filename)
 460           (switch-to-buffer (find-buffer-visiting filename))
 461         (ff/find-file-in-vm-mail-mode filename))
 462     ad-do-it
 463     ))
 464
 465 (setq ff/vm-mail-draft-directory "~/private/drafts")
 466
 467 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 468 ;; Check there are no missing attachment (the idea comes from
 469 ;; http://home.cc.gatech.edu/eaganj/MailApp) and no leading "From"
 470 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 471
 472 (defcustom ff/check-vm-attachement-regexp "attach"
 473   "*A mail whose body matches this regular expression should contain
 474 an attachment")
 475
 476 (defun ff/check-vm-attachment ()
 477   (when (save-excursion
 478           (goto-char (point-min))
 479           (and (re-search-forward "\\[ATTACHMENT" nil t)
 480                (not (get-text-property (point) 'vm-mime-object))))
 481     (error "Buggy attachment"))
 482
 483   (if (and
 484        (save-excursion (goto-char (point-min))
 485                        (re-search-forward ff/check-vm-attachement-regexp nil t))
 486        (not (save-excursion (goto-char (point-min))
 487                             (re-search-forward "\\[ATTACHMENT" nil t)))
 488        (not (y-or-n-p "An attachment seems to be missing, send message ? ")))
 489       (error "You refer to an unexisting attachment."))
 490
 491   )
 492
 493 (defun ff/check-no-prolematic-dest ()
 494   "Check that there are no \">,[^\ $]\" in the header"
 495   (let ((s "no-subject"))
 496     (save-excursion
 497       (goto-char (point-min))
 498       (let ((end-header (re-search-forward (concat "^" mail-header-separator "$") nil t)))
 499         (when end-header
 500           (goto-char (point-min))
 501           (re-search-forward ">,[^\ ]" end-header t nil)
 502           )
 503         )
 504       )
 505     s))
 506
 507
 508 ;; You can not have a line starting with "From:" in a pure text
 509 ;; mail. The smtp server would add a leading character to prevent it.
 510
 511 (defun ff/check-no-leading-from ()
 512   (and (let ((case-fold-search nil))
 513          (save-excursion
 514            (goto-char (point-min))
 515            (re-search-forward (concat "^" mail-header-separator "$"))
 516            (re-search-forward "^From " nil t)))
 517        (not (y-or-n-p "There is a leading ``From '', send message ? "))
 518        (error "There is a leading ``From ''.")))
 519
 520 ;; An attempt at limiting excess wording in sent mails
 521
 522 (defface ff/strong-words
 523   '((t (:background "red")))
 524   "The face to highlight upper caps, exclamation marks and such.")
 525
 526 (defun ff/max-in-a-row (overlay regexp max)
 527   (let ((case-fold-search nil))
 528     (save-excursion
 529       (goto-char (point-min))
 530       (re-search-forward (concat "^" mail-header-separator "$"))
 531       (when (and (re-search-forward regexp nil t nil)
 532                  (>= (- (match-end 0) (match-beginning 0)) max))
 533         (move-overlay overlay (match-beginning 0) (match-end 0))
 534         t))))
 535
 536 (defun ff/check-no-excess-wording () (interactive)
 537   (let ((overlay (make-overlay 0 0)))
 538     (overlay-put overlay 'face 'media/current-tune-face)
 539     (let ((err (and
 540                 (or (ff/max-in-a-row overlay "[A-Z\?\!][A-Z\?\! ]+[A-Z\?\!]" 6)
 541                     (ff/max-in-a-row overlay "[\?\!]+" 2)
 542                     )
 543                 (not (y-or-n-p "That does not look good. Send message ? ")))))
 544       (delete-overlay overlay)
 545       (when err (error "Good idea. Chill out a bit.")))
 546     ))
 547
 548 (defun ff/check-badly-encoded-address () (interactive)
 549   (let (bodysep bad-adr)
 550     (save-excursion
 551       (goto-char (point-min))
 552       (search-forward mail-header-separator)
 553       (setq bodysep (vm-marker (match-beginning 0)))
 554       (goto-char (point-min))
 555       (setq bad-adr (re-search-forward "[^<a-zA-Z_0-9\-\. \n\t]+[^ \n]*@" nil t))
 556       (when (and bad-adr (< bad-adr bodysep))
 557         (error "There is an invalid address in the header (%s)"
 558                (match-string 0)))))
 559   )
 560
 561 (add-hook 'vm-mail-send-hook 'ff/check-vm-attachment)
 562 (add-hook 'vm-mail-send-hook 'ff/check-no-leading-from)
 563 (add-hook 'vm-mail-send-hook 'ff/check-no-excess-wording)
 564 (add-hook 'vm-mail-send-hook 'flyspell-mode-off)
 565
 566 (defadvice vm-mail-send-and-exit (before ff/switch-flyspell-off nil activate)
 567   (flyspell-mode-off))
 568
 569 ;; Append so that it happens after the mime encoding
 570 ;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
 571
 572 ;; Append this hook so that it runs after all other checks
 573 (add-hook 'vm-mail-send-hook 'ff/dissociate-file-from-vm-mail-buffer t)
 574
 575 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 576 ;; If we can, encrypt!
 577
 578 (add-hook 'vm-mode-hook 'mc-install-read-mode)
 579 (add-hook 'vm-summary-mode-hook 'mc-install-read-mode)
 580 (add-hook 'vm-virtual-mode-hook 'mc-install-read-mode)
 581 (add-hook 'vm-mail-mode-hook 'mc-install-write-mode)
 582 (add-hook 'vm-presentation-mode-hook 'mc-install-read-mode)
 583
 584 ;; (defun ff/encrypt-mail-if-possible () (interactive)
 585   ;; (condition-case nil (mc-encrypt-message)
 586     ;; (error nil)))
 587
 588 ;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)
 589
 590 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 591 ;; Composing a mail
 592
 593 ;; Move through important points in the mail ("To:" field, "Subject:"
 594 ;; field and the end of the body)
 595
 596 (defun ff/goto-next-mail-field () (interactive)
 597   (let ((field (save-excursion
 598                  (end-of-line)
 599                  (re-search-backward
 600                   (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
 601                  (match-string 1))))
 602
 603     (cond ((string= field "To: ")
 604            (expand-abbrev)
 605            (re-search-forward "Subject: ")
 606            (end-of-line))
 607
 608           ((string= field "Subject: ")
 609            (re-search-forward (concat "^" mail-header-separator "$"))
 610            (if (re-search-forward "^-- $" nil t)
 611                (previous-line 1)
 612              (next-line 1))
 613            (end-of-line))
 614
 615           (t (beginning-of-buffer)
 616              (re-search-forward "^To: ")
 617              (end-of-line)
 618              (re-search-forward "^[a-zA-Z\-]*: ")
 619              (beginning-of-line)
 620              (backward-char)))))
 621
 622 ;; (define-key vm-mail-mode-map [(control tab)] 'ff/goto-next-mail-field)
 623 (define-key vm-mail-mode-map [(iso-lefttab)] 'ff/goto-next-mail-field)
 624 ;; (define-key vm-mail-mode-map [(shift iso-lefttab)] 'mail-mode-smart-tab)
 625 (define-key vm-mail-mode-map [(shift iso-lefttab)] 'bbdb-complete-name)
 626
 627 ;; The definition of "\t" is forced through a hook defined in
 628 ;; vm-init.el, so I add mine. This is ugly.
 629
 630 (add-hook 'mail-setup-hook
 631           '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
 632           t)
 633
 634 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
 635
 636 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
 637
 638 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 639 ;; I rarely edit two mails at the same time, and it makes sense to
 640 ;; come back to the one currently being edited with the same function
 641
 642 (defun ff/first-buffer-in-mode (l m)
 643   (if l
 644       (if (eq (save-excursion
 645                 (set-buffer (car l)) major-mode) m)
 646           (car l)
 647         (ff/first-buffer-in-mode (cdr l) m))))
 648
 649 (defun ff/compose-mail (&optional force-new)
 650   "Cycles through an existing buffers with major mode `mail-mode',
 651 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
 652 is t."
 653   (interactive "P")
 654   (when (eq major-mode 'mail-mode) (bury-buffer))
 655   (let ((buf (and (not force-new)
 656                   (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
 657     (if buf (switch-to-buffer buf)
 658       (vm-compose-mail))))
 659
 660 (define-key global-map [(control x) (m)] 'ff/compose-mail)
 661
 662 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 663 ;; bbdb
 664
 665 (load "bbdb")
 666 (load "bbdb-hooks")
 667
 668 (when (load "bbdb-vm" t)
 669
 670   (defun ff/mail-aliases-from-bbdb ()
 671     "Creates automatically mail aliases from the bbdb records. For
 672 instance, someone in bbdb named \"Paul Smith\" would generate an alias
 673 'pm'. Does not replace existing aliases."
 674     (interactive)
 675     (let* ((records (bbdb-records)))
 676       (while records
 677         (let* ((record (car records))
 678                (name (concat (elt record 0) " " (elt record 1)))
 679                (email (car (elt record 6)))
 680                (alias (downcase (replace-regexp-in-string
 681                                  "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
 682           (if (and email
 683                    (> (length alias) 1)
 684                    ;; Do not overwrite an existing alias
 685                    (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
 686               (define-mail-abbrev alias email))
 687           (setq records (cdr records))))))
 688
 689   (when (>= emacs-major-version 22)
 690     (bbdb-insinuate-vm)
 691     (ff/mail-aliases-from-bbdb))
 692   )
 693
 694 (defun ff/pipe-to-tmp () (interactive)
 695   (let ((link "/tmp/attach")
 696         (dir (format-time-string "/tmp/attach-%Y%m%d-%H%M%S" (current-time))))
 697     (mkdir dir)
 698     (when (file-symlink-p link) (delete-file link))
 699     (unless (file-exists-p link)
 700       (make-symbolic-link dir "/tmp/attach" 1))
 701     (vm-pipe-message-to-command (concat "munpack -C " dir))
 702     (message "Wrote files to %s" dir)
 703     )
 704   )
 705
 706 (defun ff/make-nonexisting-filename (filename)
 707   (let ((root filename)
 708         (extension "")
 709         (result filename))
 710     (when (file-exists-p result)
 711       (when (string-match "^\\(.*\\)\\(\\.[^\\.]*\\)$" filename)
 712         (setq root (match-string 1 filename)
 713               extension (match-string 2 filename)))
 714       (let ((n 0))
 715         (while (file-exists-p (setq result (format "%s_%03d%s" root n extension)))
 716           (setq n (+ n 1)))))
 717     result))
 718
 719 (defun ff/vm-mime-save-all-attachments (&optional count
 720                                                directory
 721                                                no-delete-after-saving)
 722   "Save all attachments in the next COUNT messages or marked
 723 messages.  For the purpose of this function, an \"attachment\" is
 724 a mime part part which has \"attachment\" as its disposition or
 725 simply has an associated filename.  Any mime types that match
 726 `vm-mime-savable-types' but not `vm-mime-savable-type-exceptions'
 727 are also included.
 728
 729 The attachments are saved to the specified DIRECTORY.  The
 730 variables `vm-all-attachments-directory' or
 731 `vm-mime-attachment-save-directory' can be used to set the
 732 default location.  When directory does not exist it will be
 733 created."
 734   (interactive
 735    (list current-prefix-arg
 736          (vm-read-file-name
 737           "Attachment directory: "
 738           (or vm-mime-all-attachments-directory
 739               vm-mime-attachment-save-directory
 740               default-directory)
 741           (or vm-mime-all-attachments-directory
 742               vm-mime-attachment-save-directory
 743               default-directory)
 744           nil nil
 745           vm-mime-save-all-attachments-history)))
 746
 747   (vm-check-for-killed-summary)
 748   (if (interactive-p) (vm-follow-summary-cursor))
 749
 750   (let ((n 0))
 751     (vm-mime-action-on-all-attachments
 752      count
 753      ;; the action to be performed BEGIN
 754      (lambda (msg layout type file)
 755        (let ((directory (if (functionp directory)
 756                             (funcall directory msg)
 757                           directory)))
 758          (setq file
 759                (if file
 760                    (expand-file-name (file-name-nondirectory file) directory)
 761                  (vm-read-file-name
 762                   (format "Save %s to file: " type)
 763                   (or directory
 764                       vm-mime-all-attachments-directory
 765                       vm-mime-attachment-save-directory)
 766                   (or directory
 767                       vm-mime-all-attachments-directory
 768                       vm-mime-attachment-save-directory)
 769                   nil nil
 770                   vm-mime-save-all-attachments-history)
 771                  ))
 772
 773          (setq file (ff/make-nonexisting-filename file))
 774
 775          (when file
 776            (message "Saving `%s%s" type (if file (format " (%s)" file) ""))
 777            (make-directory (file-name-directory file) t)
 778            (vm-mime-send-body-to-file layout file file)
 779            (if vm-mime-delete-after-saving
 780                (let ((vm-mime-confirm-delete nil))
 781                  (vm-mime-discard-layout-contents
 782                   layout (expand-file-name file))))
 783            (setq n (+ 1 n)))))
 784      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END
 785      ;; attachment filters
 786      vm-mime-savable-types
 787      vm-mime-savable-type-exceptions)
 788
 789     (when (interactive-p)
 790       (vm-discard-cached-data)
 791       (vm-preview-current-message))
 792
 793     (if (> n 0)
 794         (message "%d attachment%s saved" n (if (= n 1) "" "s"))
 795       (message "No attachments to be saved!"))))
 796
 797 (define-key vm-summary-mode-map [(control c) (control s)] 'ff/vm-mime-save-all-attachments)