vm

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