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 (defun ff/kill-to-signature () (interactive)
 646        (save-excursion
 647          (delete-region
 648           (point)
 649           (progn
 650             (search-forward-regexp "^-- *$")
 651             (- (match-beginning 0) 1))
 652           )
 653          )
 654        )
 655
 656 (define-key vm-mail-mode-map [(control c) (k)] 'ff/kill-to-signature)
 657
 658 ;; The definition of "\t" is forced through a hook defined in
 659 ;; vm-init.el, so I add mine. This is ugly.
 660
 661 (add-hook 'mail-setup-hook
 662           '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
 663           t)
 664
 665 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
 666
 667 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
 668
 669 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 670 ;; I rarely edit two mails at the same time, and it makes sense to
 671 ;; come back to the one currently being edited with the same function
 672
 673 (defun ff/first-buffer-in-mode (l m)
 674   (if l
 675       (if (eq
 676            ;; (save-excursion (set-buffer (car l)) major-mode)
 677            (with-current-buffer (car l) major-mode)
 678            m)
 679           (car l)
 680         (ff/first-buffer-in-mode (cdr l) m))))
 681
 682 (defun ff/compose-mail (&optional force-new)
 683   "Cycles through existing buffers with major mode `mail-mode',
 684 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
 685 is t."
 686   (interactive "P")
 687   (when (eq major-mode 'mail-mode) (bury-buffer))
 688   (let ((buf (and (not force-new)
 689                   ;; (not (eq major-mode 'mail-mode))
 690                   (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
 691     (if buf (switch-to-buffer buf)
 692       (vm-compose-mail))))
 693
 694 (define-key global-map [(control x) (m)] 'ff/compose-mail)
 695
 696 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 697 ;; bbdb
 698
 699 (load "bbdb")
 700 ;; (load "bbdb-hooks")
 701
 702 (when (load "bbdb-vm" t)
 703
 704   (defun ff/mail-aliases-from-bbdb ()
 705     "Creates automatically mail aliases from the bbdb records. For
 706 instance, someone in bbdb named \"Paul Smith\" would generate an alias
 707 'pm'. Does not replace existing aliases."
 708     (interactive)
 709     (let* ((records (bbdb-records)))
 710       (while records
 711         (let* ((record (car records))
 712                (name (concat (elt record 0) " " (elt record 1)))
 713                (email (car (elt record 6)))
 714                (alias (downcase (replace-regexp-in-string
 715                                  "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
 716           (if (and email
 717                    (> (length alias) 1)
 718                    ;; Do not overwrite an existing alias
 719                    (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
 720               (define-mail-abbrev alias email))
 721           (setq records (cdr records))))))
 722
 723   (when (>= emacs-major-version 22)
 724     (bbdb-insinuate-vm)
 725     (ff/mail-aliases-from-bbdb)
 726     )
 727   )
 728
 729 (defun ff/pipe-to-tmp (universal)
 730   (interactive "P")
 731
 732   (if universal (vm-pipe-message-to-command)
 733
 734     (let ((link "/tmp/at")
 735           (dir (format-time-string "/tmp/at-%Y%m%d-%H%M%S" (current-time))))
 736       (mkdir dir)
 737
 738       (when (file-symlink-p (concat link "~~"))
 739         (delete-file (concat link "~~")))
 740
 741       (when (and (file-symlink-p (concat link "~"))
 742                  (not (file-exists-p (concat link "~~"))))
 743         (rename-file (concat link "~") (concat link "~~")))
 744
 745       (when (and (file-symlink-p link)
 746                  (not (file-exists-p (concat link "~"))))
 747         (file-symlink-p link) (rename-file link (concat link "~")))
 748
 749       (unless (file-exists-p link)
 750         (make-symbolic-link dir link 1))
 751
 752       ;; (vm-pipe-message-to-command (concat "munpack -C " dir))
 753
 754       (vm-pipe-message-to-command (concat "munpack -t -C " dir))
 755       (message "Wrote files to %s" dir)
 756       )
 757     )
 758   )
 759
 760 (define-key vm-mode-pipe-map "\\" 'ff/pipe-to-tmp)
 761
 762 (defun ff/make-nonexisting-filename (filename)
 763   (let ((root filename)
 764         (extension "")
 765         (result filename))
 766     (when (file-exists-p result)
 767       (when (string-match "^\\(.*\\)\\(\\.[^\\.]*\\)$" filename)
 768         (setq root (match-string 1 filename)
 769               extension (match-string 2 filename)))
 770       (let ((n 0))
 771         (while (file-exists-p (setq result (format "%s_%03d%s" root n extension)))
 772           (setq n (+ n 1)))))
 773     result))
 774
 775 (defun ff/vm-mime-save-all-attachments (&optional count
 776                                                   directory
 777                                                   no-delete-after-saving)
 778   "Save all attachments in the next COUNT messages or marked
 779 messages.  For the purpose of this function, an \"attachment\" is
 780 a mime part part which has \"attachment\" as its disposition or
 781 simply has an associated filename.  Any mime types that match
 782 `vm-mime-savable-types' but not `vm-mime-savable-type-exceptions'
 783 are also included.
 784
 785 The attachments are saved to the specified DIRECTORY.  The
 786 variables `vm-all-attachments-directory' or
 787 `vm-mime-attachment-save-directory' can be used to set the
 788 default location.  When directory does not exist it will be
 789 created."
 790   (interactive
 791    (list current-prefix-arg
 792          (vm-read-file-name
 793           "Attachment directory: "
 794           (or vm-mime-all-attachments-directory
 795               vm-mime-attachment-save-directory
 796               default-directory)
 797           (or vm-mime-all-attachments-directory
 798               vm-mime-attachment-save-directory
 799               default-directory)
 800           nil nil
 801           vm-mime-save-all-attachments-history)))
 802
 803   (vm-check-for-killed-summary)
 804   (if (interactive-p) (vm-follow-summary-cursor))
 805
 806   (let ((n 0))
 807     (vm-mime-action-on-all-attachments
 808      count
 809      ;; the action to be performed BEGIN
 810      (lambda (msg layout type file)
 811        (let ((directory (if (functionp directory)
 812                             (funcall directory msg)
 813                           directory)))
 814          (setq file
 815                (if file
 816                    (expand-file-name (file-name-nondirectory file) directory)
 817                  (vm-read-file-name
 818                   (format "Save %s to file: " type)
 819                   (or directory
 820                       vm-mime-all-attachments-directory
 821                       vm-mime-attachment-save-directory)
 822                   (or directory
 823                       vm-mime-all-attachments-directory
 824                       vm-mime-attachment-save-directory)
 825                   nil nil
 826                   vm-mime-save-all-attachments-history)
 827                  ))
 828
 829          (setq file (ff/make-nonexisting-filename file))
 830
 831          (when file
 832            (message "Saving `%s%s" type (if file (format " (%s)" file) ""))
 833            (make-directory (file-name-directory file) t)
 834            (vm-mime-send-body-to-file layout file file)
 835            (if vm-mime-delete-after-saving
 836                (let ((vm-mime-confirm-delete nil))
 837                  (vm-mime-discard-layout-contents
 838                   layout (expand-file-name file))))
 839            (setq n (+ 1 n)))))
 840      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END
 841      ;; attachment filters
 842      vm-mime-savable-types
 843      vm-mime-savable-type-exceptions)
 844
 845     (when (interactive-p)
 846       (vm-discard-cached-data)
 847       (vm-preview-current-message))
 848
 849     (if (> n 0)
 850         (message "%d attachment%s saved" n (if (= n 1) "" "s"))
 851       (message "No attachments to be saved!"))))
 852
 853 (define-key vm-summary-mode-map [(control c) (control s)] 'ff/vm-mime-save-all-attachments)
 854
 855 ;; I do not like relief
 856
 857 (ff/configure-faces
 858  '(
 859
 860    ;; (vm-highlight-url :weight 'bold :foreground "#0000f0" :box nil)
 861    (vm-highlight-url :underline nil :foreground "#0000f0" :box nil)
 862    ;; (vm-highlight-url :background "white" :foreground "#0000f0" :box nil)
 863    (vm-highlighted-header :box nil) ;; :weight 'bold :background "white")
 864
 865    (vm-attachment-button :background "#f0d0d0" :box nil)
 866    (vm-attachment-button-mouse :background "#f0d0d0" :box nil)
 867    (vm-attachment-button-pressed-face :background "#f0d0d0" :box nil)
 868    (vm-mime-button :background "#f0d0d0" :box nil)
 869    (vm-mime-button-mouse :background "#f0d0d0" :box nil)
 870    (vm-mime-button-pressed-face :background "#f0d0d0" :box nil)
 871    ))