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