cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-pcrisis.el

   1 ;;; vm-pcrisis.el --- wide-ranging auto-setup for personalities in VM
   2 ;;
   3 ;; Copyright (C) 1999 Rob Hodges,
   4 ;;               2006 Robert Widhopf, Robert P. Goldman
   5 ;;
   6 ;; Package: Personality Crisis for VM
   7 ;; Author: Rob Hodges
   8 ;;
   9 ;; Maintainer: Robert Widhopf-Fenk <hack@robf.de>
  10 ;; X-URL:       http://www.robf.de/Hacking/elisp
  11 ;;
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program; if not, you can either send email to this
  24 ;; program's maintainer or write to: The Free Software Foundation,
  25 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  26
  27
  28 ;; DOCUMENTATION:
  29 ;; -------------
  30 ;;
  31 ;; Documentation is now in Texinfo and HTML formats.  You should have
  32 ;; downloaded one or the other along with this package at the URL
  33 ;; above.
  34
  35 ;;; Code:
  36
  37 (eval-when-compile
  38   (require 'vm-version)
  39   (require 'vm-message)
  40   (require 'vm-macro)
  41   (require 'vm-reply)
  42   ;; get the macros we need.
  43   (require 'cl)
  44   (require 'advice)
  45   (condition-case e
  46       (progn
  47         (require 'regexp-opt)
  48         (require 'bbdb))
  49     (error
  50      (message "%S" e)
  51      (message "Could not load bbdb.el.  Related functions may not work correctly!")
  52      (sit-for 5))))
  53
  54 ;; -------------------------------------------------------------------
  55 ;; Variables:
  56 ;; -------------------------------------------------------------------
  57 (defconst vmpc-version "0.9.1"
  58   "Version of pcrisis.")
  59
  60 (defgroup vmpc nil
  61   "Manage personalities and more in VM."
  62   :group  'vm)
  63
  64 (defcustom vmpc-conditions ()
  65   "*List of conditions which will be checked by pcrisis."
  66   :group 'vmpc)
  67
  68 (defcustom vmpc-actions ()
  69   "*List of actions.
  70 Actions are associated with conditions from `vmpc-conditions' by one of
  71 `vmpc-actions-alist', `vmpc-reply-alist', `', `vmpc-forward-alist',
  72 `vmpc-resend-alist',  `vmpc-newmail-alist' or `vmpc-automorph-alist'.
  73
  74 These are also the actions from which you can choose when using the newmail
  75 features of Personality Crisis, or the `vmpc-prompt-for-profile' action."
  76   :type '(repeat (list (string :tag "Action name")
  77                        (sexp :tag "Condition")))
  78   :group 'vmpc)
  79
  80 (defun vmpc-alist-set (symbol value)
  81   "Used as :set for vmpc-*-alist variables.
  82 Checks if the condition and all the actions exist."
  83   (while value
  84     (let ((condition (caar value))
  85           (actions   (cdar value)))
  86       (if (and condition (not (assoc condition vmpc-conditions)))
  87           (error "Condition '%s' does not exist!" condition))
  88       (while actions
  89         (if (not (assoc (car actions) vmpc-actions))
  90             (error "Action '%s' does not exist!" (car actions)))
  91         (setq actions (cdr actions))))
  92     (setq value (cdr value)))
  93   (set symbol value))
  94
  95 (defun vmpc-defcustom-alist-type ()
  96   "Generate :type for vmpc-*-alist variables."
  97   (list 'repeat
  98         (list 'list
  99               (append '(choice :tag "Condition")
 100                       (mapcar (lambda (c) (list 'const (car c))) vmpc-conditions)
 101                       '((string)))
 102               (list 'repeat :tag "Actions to run"
 103                     (append '(choice :tag "Action")
 104                             (mapcar (lambda (a) (list 'const (car a))) vmpc-actions)
 105                             '(string))))))
 106
 107 (defcustom vmpc-actions-alist ()
 108   "*An alist associating conditions with actions from `vmpc-actions'.
 109 If you do not want to map actions for each state, e.g. for replying, forwarding,
 110 resending, composing or automorphing, then set this one."
 111   :type (vmpc-defcustom-alist-type)
 112 ;  :set 'vmpc-alist-set
 113   :group 'vmpc)
 114
 115 (defcustom vmpc-reply-alist ()
 116   "*An alist associating conditions with actions from `vmpc-actions' when replying."
 117   :type (vmpc-defcustom-alist-type)
 118 ;  :set 'vmpc-alist-set
 119   :group 'vmpc)
 120
 121 (defcustom vmpc-forward-alist ()
 122   "*An alist associating conditions with actions from `vmpc-actions' when forwarding."
 123   :type (vmpc-defcustom-alist-type)
 124 ;  :set 'vmpc-alist-set
 125   :group 'vmpc)
 126
 127 (defcustom vmpc-automorph-alist ()
 128   "*An alist associating conditions with actions from `vmpc-actions' when automorphing."
 129   :type (vmpc-defcustom-alist-type)
 130 ;  :set 'vmpc-alist-set
 131   :group 'vmpc)
 132
 133 (defcustom vmpc-newmail-alist ()
 134   "*An alist associating conditions with actions from `vmpc-actions' when composing."
 135   :type (vmpc-defcustom-alist-type)
 136 ;  :set 'vmpc-alist-set
 137   :group 'vmpc)
 138
 139 (defcustom vmpc-resend-alist ()
 140   "*An alist associating conditions with actions from `vmpc-actions' when resending."
 141   :type (vmpc-defcustom-alist-type)
 142 ;  :set 'vmpc-alist-set
 143   :group 'vmpc)
 144
 145 (defcustom vmpc-auto-profiles-file "~/.vmpc-auto-profiles"
 146   "*File in which to save information used by `vmpc-prompt-for-profile'.
 147 When set to the symbol 'BBDB, profiles will be stored there."
 148   :type '(choice (file)
 149                  (const BBDB))
 150   :group 'vmpc)
 151
 152 (defcustom vmpc-auto-profiles-expunge-days 100
 153   "*Number of days after which to expunge old address-profile associations.
 154 Performance may suffer noticeably if this file becomes enormous, but in other
 155 respects it is preferable for this value to be fairly high.  The value that is
 156 right for you will depend on how often you send email to new addresses using
 157 `vmpc-prompt-for-profile' (with the REMEMBER flag set to 'always or 'prompt)."
 158   :type 'integer
 159   :group 'vmpc)
 160
 161 (defvar vmpc-current-state nil
 162   "The current state of pcrisis.
 163 It is one of 'reply, 'forward, 'resend, 'automorph or 'newmail.
 164 It controls which actions/functions can/will be run.")
 165
 166 (defvar vmpc-current-buffer nil
 167   "The current buffer, i.e. 'none or 'composition.
 168 It is 'none before running an adviced VM function and 'composition afterward,
 169 i.e. when within the composition buffer.")
 170
 171 (defvar vmpc-saved-headers-alist nil
 172   "Alist of headers from the original message saved for later use.")
 173
 174 (defvar vmpc-actions-to-run nil
 175   "The actions to run.")
 176
 177 (defvar vmpc-true-conditions nil
 178   "The true conditions.")
 179
 180 (defvar vmpc-auto-profiles nil
 181   "The auto profiles as stored in `vmpc-auto-profiles-file'.")
 182
 183 ;; An "exerlay" is an overlay in FSF Emacs and an extent in XEmacs.
 184 ;; It's not a real type; it's just the way I'm dealing with the damn
 185 ;; things to produce containers for the signature and pre-signature
 186 ;; which can be highlighted etc. and work on both platforms.
 187
 188 (defvar vmpc-pre-sig-exerlay ()
 189   "Don't mess with this.")
 190
 191 (make-variable-buffer-local 'vmpc-pre-sig-exerlay)
 192
 193 (defvar vmpc-sig-exerlay ()
 194   "Don't mess with this.")
 195
 196 (make-variable-buffer-local 'vmpc-sig-exerlay)
 197
 198 (defvar vmpc-pre-sig-face (progn (make-face 'vmpc-pre-sig-face
 199             "Face used for highlighting the pre-signature.")
 200                                  (set-face-foreground
 201                                   'vmpc-pre-sig-face "forestgreen")
 202                                  'vmpc-pre-sig-face)
 203   "Face used for highlighting the pre-signature.")
 204
 205 (defvar vmpc-sig-face (progn (make-face 'vmpc-sig-face
 206                 "Face used for highlighting the signature.")
 207                              (set-face-foreground 'vmpc-sig-face
 208                                                   "steelblue")
 209                              'vmpc-sig-face)
 210   "Face used for highlighting the signature.")
 211
 212 (defvar vmpc-intangible-pre-sig 'nil
 213   "Whether to forbid the cursor from entering the pre-signature.")
 214
 215 (defvar vmpc-intangible-sig 'nil
 216   "Whether to forbid the cursor from entering the signature.")
 217
 218 (defvar vmpc-expect-default-signature 'nil
 219   "*Set this to 't if you have a signature-inserting function.
 220 It will ensure that pcrisis correctly handles the signature .")
 221
 222
 223 ;; -------------------------------------------------------------------
 224 ;; Some easter-egg functionality:
 225 ;; -------------------------------------------------------------------
 226
 227 (defun vmpc-my-identities (&rest identities)
 228   "Setup pcrisis with the given IDENTITIES."
 229   (setq vmpc-conditions    '(("always true" t))
 230         vmpc-actions-alist '(("always true" "prompt for a profile"))
 231         vmpc-actions       '(("prompt for a profile" (vmpc-prompt-for-profile 'always))))
 232   (setq vmpc-actions
 233         (append (mapcar
 234                  (lambda (i)
 235                    (list i (list 'vmpc-substitute-header "From" i)))
 236                  identities)
 237                 vmpc-actions)))
 238
 239 (defun vmpc-header-field-for-point ()
 240   "*Return a string indicating the mail header field point is in.
 241 If point is not in a header field, returns nil."
 242   (save-excursion
 243     (unless (save-excursion
 244               (re-search-backward (regexp-quote mail-header-separator)
 245                                   (point-min) t))
 246       (re-search-backward "^\\([^ \t\n:]+\\):")
 247       (match-string 1))))
 248
 249 (defun vmpc-tab-header-or-tab-stop (&optional backward)
 250   "*If in a mail header field, moves to next useful header or body.
 251 When moving to the message body, calls the `vmpc-automorph' function.
 252 If within the message body, runs `tab-to-tab-stop'.
 253 If BACKWARD is specified and non-nil, moves to previous useful header
 254 field, whether point is in the body or the headers.
 255 \"Useful header fields\" are currently, in order, \"To\" and
 256 \"Subject\"."
 257   (interactive)
 258   (let ((curfield) (nextfield) (useful-headers '("To" "Subject")))
 259     (if (or (setq curfield (vmpc-header-field-for-point))
 260             backward)
 261         (progn
 262           (setq nextfield
 263                 (- (length useful-headers)
 264                    (length (member curfield useful-headers))))
 265           (if backward
 266               (setq nextfield (nth (1- nextfield) useful-headers))
 267             (setq nextfield (nth (1+ nextfield) useful-headers)))
 268           (if nextfield
 269               (mail-position-on-field nextfield)
 270             (mail-text)
 271             (vmpc-automorph))
 272           )
 273       (tab-to-tab-stop)
 274       )))
 275
 276 (defun vmpc-backward-tab-header-or-tab-stop ()
 277   "*Wrapper for `vmpc-tab-header-or-tab-stop' with BACKWARD set."
 278   (interactive)
 279   (vmpc-tab-header-or-tab-stop t))
 280
 281
 282 ;; -------------------------------------------------------------------
 283 ;; Stuff for dealing with exerlays:
 284 ;; -------------------------------------------------------------------
 285
 286 (defun vmpc-set-overlay-insertion-types (overlay start end)
 287   "Set insertion types for OVERLAY from START to END.
 288 In fact a new copy of OVERLAY with different insertion types at START and END
 289 is created and returned.
 290
 291 START and END should be nil or t -- the marker insertion types at the start
 292 and end.  This seems to be the only way you of changing the insertion types
 293 for an overlay -- save the overlay properties that we care about, create a new
 294 overlay with the new insertion types, set its properties to the saved ones.
 295 Overlays suck.  Extents rule.  XEmacs got this right."
 296   (let* ((useful-props (list 'face 'intangible 'evaporate)) (saved-props)
 297          (i 0) (len (length useful-props)) (startpos) (endpos) (new-ovl))
 298     (while (< i len)
 299       (setq saved-props (append saved-props (cons
 300                        (overlay-get overlay (nth i useful-props)) ())))
 301       (setq i (1+ i)))
 302     (setq startpos (overlay-start overlay))
 303     (setq endpos (overlay-end overlay))
 304     (delete-overlay overlay)
 305     (if (and startpos endpos)
 306         (setq new-ovl (make-overlay startpos endpos (current-buffer)
 307                                     start end))
 308       (setq new-ovl (make-overlay 1 1 (current-buffer) start end))
 309       (vmpc-forcefully-detach-exerlay new-ovl))
 310     (setq i 0)
 311     (while (< i len)
 312       (overlay-put new-ovl (nth i useful-props) (nth i saved-props))
 313       (setq i (1+ i)))
 314     new-ovl))
 315
 316
 317 (defun vmpc-set-extent-insertion-types (extent start end)
 318   "Set the insertion types of EXTENT from START to END.
 319 START and END should be either nil or t, indicating the desired value
 320 of the 'start-open and 'end-closed properties of the extent
 321 respectively.
 322 This is the XEmacs version of `vmpc-set-overlay-insertion-types'."
 323   ;; pretty simple huh?
 324   (set-extent-property extent 'start-open start)
 325   (set-extent-property extent 'end-closed end))
 326
 327
 328 (defun vmpc-set-exerlay-insertion-types (exerlay start end)
 329   "Set the insertion types for EXERLAY from START to END.
 330 In other words, EXERLAY is the name of the overlay or extent with a quote in
 331 front.  START and END are the equivalent of the marker insertion types for the
 332 start and end of the overlay/extent."
 333   (if vm-xemacs-p
 334       (vmpc-set-extent-insertion-types (symbol-value exerlay) start end)
 335     (set exerlay (vmpc-set-overlay-insertion-types (symbol-value exerlay)
 336                                                    start end))))
 337
 338
 339 (defun vmpc-exerlay-start (exerlay)
 340   "Return buffer position of the start of EXERLAY."
 341   (if vm-xemacs-p
 342       (extent-start-position exerlay)
 343     (overlay-start exerlay)))
 344
 345
 346 (defun vmpc-exerlay-end (exerlay)
 347   "Return buffer position of the end of EXERLAY."
 348   (if vm-xemacs-p
 349       (extent-end-position exerlay)
 350     (overlay-end exerlay)))
 351
 352
 353 (defun vmpc-move-exerlay (exerlay new-start new-end)
 354   "Change EXERLAY to cover region from NEW-START to NEW-END."
 355   (if vm-xemacs-p
 356       (set-extent-endpoints exerlay new-start new-end (current-buffer))
 357     (move-overlay exerlay new-start new-end (current-buffer))))
 358
 359
 360 (defun vmpc-set-exerlay-detachable-property (exerlay newval)
 361   "Set the 'detachable or 'evaporate property for EXERLAY to NEWVAL."
 362   (if vm-xemacs-p
 363       (set-extent-property exerlay 'detachable newval)
 364     (overlay-put exerlay 'evaporate newval)))
 365
 366
 367 (defun vmpc-set-exerlay-intangible-property (exerlay newval)
 368   "Set the 'intangible or 'atomic property for EXERLAY to NEWVAL."
 369   (if vm-xemacs-p
 370       (progn
 371         (require 'atomic-extents)
 372         (set-extent-property exerlay 'atomic newval))
 373     (overlay-put exerlay 'intangible newval)))
 374
 375
 376 (defun vmpc-set-exerlay-face (exerlay newface)
 377   "Set the face used by EXERLAY to NEWFACE."
 378   (if vm-xemacs-p
 379       (set-extent-face exerlay newface)
 380     (overlay-put exerlay 'face newface)))
 381
 382
 383 (defun vmpc-forcefully-detach-exerlay (exerlay)
 384   "Leave EXERLAY in memory but detaches it from the buffer."
 385   (if vm-xemacs-p
 386       (detach-extent exerlay)
 387     (delete-overlay exerlay)))
 388
 389
 390 (defun vmpc-make-exerlay (startpos endpos)
 391   "Create a new exerlay spanning from STARTPOS to ENDPOS."
 392   (if vm-xemacs-p
 393       (make-extent startpos endpos (current-buffer))
 394     (make-overlay startpos endpos (current-buffer))))
 395
 396
 397 (defun vmpc-create-sig-and-pre-sig-exerlays ()
 398   "Create the extents in which the pre-sig and sig can reside.
 399 Or overlays, in the case of GNU Emacs.  Thus, exerlays."
 400   (setq vmpc-pre-sig-exerlay (vmpc-make-exerlay 1 2))
 401   (setq vmpc-sig-exerlay (vmpc-make-exerlay 3 4))
 402
 403   (vmpc-set-exerlay-detachable-property vmpc-pre-sig-exerlay t)
 404   (vmpc-set-exerlay-detachable-property vmpc-sig-exerlay t)
 405   (vmpc-forcefully-detach-exerlay vmpc-pre-sig-exerlay)
 406   (vmpc-forcefully-detach-exerlay vmpc-sig-exerlay)
 407
 408   (vmpc-set-exerlay-face vmpc-pre-sig-exerlay 'vmpc-pre-sig-face)
 409   (vmpc-set-exerlay-face vmpc-sig-exerlay 'vmpc-sig-face)
 410
 411   (vmpc-set-exerlay-intangible-property vmpc-pre-sig-exerlay
 412                                         vmpc-intangible-pre-sig)
 413   (vmpc-set-exerlay-intangible-property vmpc-sig-exerlay
 414                                         vmpc-intangible-sig)
 415
 416   (vmpc-set-exerlay-insertion-types 'vmpc-pre-sig-exerlay t nil)
 417   (vmpc-set-exerlay-insertion-types 'vmpc-sig-exerlay t nil)
 418
 419   ;; deal with signatures inserted by other things than vm-pcrisis:
 420   (if vmpc-expect-default-signature
 421       (save-excursion
 422         (let ((p-max (point-max))
 423               (body-start (save-excursion (mail-text) (point)))
 424               (sig-start nil))
 425           (goto-char p-max)
 426           (setq sig-start (re-search-backward "\n-- \n" body-start t))
 427           (if sig-start
 428               (vmpc-move-exerlay vmpc-sig-exerlay sig-start p-max))))))
 429
 430
 431 ;; -------------------------------------------------------------------
 432 ;; Functions for vmpc-actions:
 433 ;; -------------------------------------------------------------------
 434
 435 (defmacro vmpc-composition-buffer (&rest form)
 436   "Evaluate FORM if in the composition buffer.
 437 That is to say, evaluates the form if you are really in a composition
 438 buffer.  This function should not be called directly, only from within
 439 the `vmpc-actions' list."
 440   (list 'if '(eq vmpc-current-buffer 'composition)
 441         (list 'eval (cons 'progn form))))
 442
 443 (put 'vmpc-composition-buffer 'lisp-indent-hook 'defun)
 444
 445 (defmacro vmpc-pre-function (&rest form)
 446   "Evaluate FORM if in pre-function state.
 447 That is to say, evaluates the FORM before VM does its thing, whether
 448 that be creating a new mail or a reply.  This function should not be
 449 called directly, only from within the `vmpc-actions' list."
 450   (list 'if '(and (eq vmpc-current-buffer 'none)
 451                   (not (eq vmpc-current-state 'automorph)))
 452         (list 'eval (cons 'progn form))))
 453
 454 (put 'vmpc-pre-function 'lisp-indent-hook 'defun)
 455
 456 (defun vmpc-delete-header (hdrfield &optional entire)
 457   "Delete the contents of a HDRFIELD in the current mail message.
 458 If ENTIRE is specified and non-nil, deletes the header field as well."
 459   (if (eq vmpc-current-buffer 'composition)
 460       (save-excursion
 461         (let ((start) (end))
 462           (mail-position-on-field hdrfield)
 463           (if entire
 464               (setq end (+ (point) 1))
 465             (setq end (point)))
 466           (re-search-backward ": ")
 467           (if entire
 468               (setq start (progn (beginning-of-line) (point)))
 469             (setq start (+ (point) 2)))
 470           (delete-region start end)))))
 471
 472
 473 (defun vmpc-insert-header (hdrfield content)
 474   "Insert to HDRFIELD the new CONTENT.
 475 Both arguments are strings.  The field can either be present or not,
 476 but if present, HDRCONT will be appended to the current header
 477 contents."
 478   (if (eq vmpc-current-buffer 'composition)
 479       (save-excursion
 480         (mail-position-on-field hdrfield)
 481         (insert content))))
 482
 483 (defun vmpc-substitute-header (hdrfield content)
 484   "Substitute HDRFIELD with new CONTENT.
 485 Both arguments are strings.  The field can either be present or not.
 486 If the header field is present and already contains something, the
 487 contents will be replaced, otherwise a new header is created."
 488   (if (eq vmpc-current-buffer 'composition)
 489       (save-excursion
 490         (vmpc-delete-header hdrfield)
 491         (vmpc-insert-header hdrfield content))))
 492
 493 (defun vmpc-add-header (hdrfield content)
 494   "Add HDRFIELD with CONTENT if it is not present already.
 495 Both arguments are strings.
 496 If a header field with the same CONTENT is present already nothing will be
 497 done, otherwise  a new field with the same name and the new CONTENT will be
 498 added to the message.
 499
 500 This is suitable for FCC, which can be specified multiple times."
 501   (unless (eq vmpc-current-buffer 'composition)
 502     (error "attempting to insert a header into a non-composition buffer."))
 503   (let ((prev-contents (vmpc-get-header-contents hdrfield "\n")))
 504     (setq prev-contents (vmpc-split prev-contents "\n"))
 505     ;; don't add this new header if it's already there
 506     (unless (member content prev-contents)
 507       (save-excursion
 508         (or (mail-position-on-field hdrfield t) ; Put new field after existing one
 509             (mail-position-on-field "to"))
 510         (unless (eq (aref hdrfield (1- (length hdrfield))) ?:)
 511           (setq hdrfield (concat hdrfield ":")))
 512         (insert "\n" hdrfield " ")
 513         (insert content)))))
 514
 515 (defun vmpc-get-current-header-contents (hdrfield &optional clump-sep)
 516   "Return the contents of HDRFIELD in the current mail message.
 517 Returns an empty string if the header doesn't exist.  HDRFIELD should
 518 be a string.  If the string CLUMP-SEP is specified, it means to return
 519 the contents of all headers matching the regexp HDRFIELD, separated by
 520 CLUMP-SEP."
 521   ;; This code is based heavily on vm-get-header-contents and vm-match-header.
 522   ;; Thanks Kyle :)
 523   (if (eq vmpc-current-state 'automorph)
 524       (save-excursion
 525         (let ((contents nil) (header-name-regexp "\\([^ \t\n:]+\\):")
 526               (case-fold-search t) (temp-contents) (end-of-headers) (regexp))
 527           (if (not (listp hdrfield))
 528               (setq hdrfield (list hdrfield)))
 529           ;; find the end of the headers:
 530           (goto-char (point-min))
 531           (or (re-search-forward
 532                (concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
 533                nil t)
 534               (error "Cannot find mail-header-separator %S in buffer %S"
 535                      mail-header-separator (current-buffer)))
 536           (setq end-of-headers (match-beginning 0))
 537           ;; now rip through finding all the ones we want:
 538           (while hdrfield
 539             (setq regexp (concat "^\\(" (car hdrfield) "\\)"))
 540             (goto-char (point-min))
 541             (while (and (or (null contents) clump-sep)
 542                         (re-search-forward regexp end-of-headers t)
 543                         (save-excursion
 544                           (goto-char (match-beginning 0))
 545                           (let (header-cont-start header-cont-end)
 546                             (if (if (not clump-sep)
 547                                     (and (looking-at (car hdrfield))
 548                                          (looking-at header-name-regexp))
 549                                   (looking-at header-name-regexp))
 550                                 (save-excursion
 551                                   (goto-char (match-end 0))
 552                                   ;; skip leading whitespace
 553                                   (skip-chars-forward " \t")
 554                                   (setq header-cont-start (point))
 555                                   (forward-line 1)
 556                                   (while (looking-at "[ \t]")
 557                                     (forward-line 1))
 558                                   ;; drop the trailing newline
 559                                   (setq header-cont-end (1- (point)))))
 560                             (setq temp-contents
 561                                   (buffer-substring header-cont-start
 562                                                     header-cont-end)))))
 563               (if contents
 564                   (setq contents
 565                         (concat contents clump-sep temp-contents))
 566                 (setq contents temp-contents)))
 567             (setq hdrfield (cdr hdrfield)))
 568
 569           (if (null contents)
 570               (setq contents ""))
 571           contents ))))
 572
 573 (defun vmpc-get-current-body-text ()
 574   "Return the body text of the mail message in the current buffer."
 575   (if (eq vmpc-current-state 'automorph)
 576       (save-excursion
 577         (goto-char (point-min))
 578         (let ((start (re-search-forward
 579                       (concat "^" (regexp-quote mail-header-separator) "$")))
 580               (end (point-max)))
 581           (buffer-substring start end)))))
 582
 583
 584 (defun vmpc-get-replied-header-contents (hdrfield &optional clump-sep)
 585   "Return the contents of HDRFIELD in the message being replied to.
 586 If that header does not exist, returns an empty string.  If the string
 587 CLUMP-SEP is specified, treat HDRFIELD as a regular expression and
 588 return the contents of all header fields which match that regexp,
 589 separated from each other by CLUMP-SEP."
 590   (if (and (eq vmpc-current-buffer 'none)
 591            (memq vmpc-current-state '(reply forward resend)))
 592       (let ((mp (car (vm-select-marked-or-prefixed-messages 1)))
 593             content c)
 594         (if (not (listp hdrfield))
 595            (setq hdrfield (list hdrfield)))
 596         (while hdrfield
 597           (setq c (vm-get-header-contents mp (car hdrfield) clump-sep))
 598           (if c (setq content (cons c content)))
 599           (setq hdrfield (cdr hdrfield)))
 600         (or (mapconcat 'identity content "\n") ""))))
 601
 602 (defun vmpc-get-header-contents (hdrfield &optional clump-sep)
 603  "Return the contents of HDRFIELD."
 604  (cond ((and (eq vmpc-current-buffer 'none)
 605              (memq vmpc-current-state '(reply forward resend)))
 606         (vmpc-get-replied-header-contents hdrfield clump-sep))
 607        ((eq vmpc-current-state 'automorph)
 608         (vmpc-get-current-header-contents hdrfield clump-sep))))
 609
 610 (defun vmpc-get-replied-body-text ()
 611   "Return the body text of the message being replied to."
 612   (if (and (eq vmpc-current-buffer 'none)
 613            (memq vmpc-current-state '(reply forward resend)))
 614       (save-excursion
 615         (let* ((mp (car (vm-select-marked-or-prefixed-messages 1)))
 616                (message (vm-real-message-of mp))
 617                start end)
 618           (set-buffer (vm-buffer-of message))
 619           (save-restriction
 620             (widen)
 621             (setq start (vm-text-of message))
 622             (setq end (vm-end-of message))
 623             (buffer-substring start end))))))
 624
 625 (defun vmpc-save-replied-header (hdrfield)
 626   "Save the contents of HDRFIELD in `vmpc-saved-headers-alist'.
 627 Does nothing if that header doesn't exist."
 628   (let ((hdrcont (vmpc-get-replied-header-contents hdrfield)))
 629   (if (and (eq vmpc-current-buffer 'none)
 630            (memq vmpc-current-state '(reply forward resend))
 631            (not (equal hdrcont "")))
 632       (add-to-list 'vmpc-saved-headers-alist (cons hdrfield hdrcont)))))
 633
 634 (defun vmpc-get-saved-header (hdrfield)
 635   "Return the contents of HDRFIELD from `vmpc-saved-headers-alist'.
 636 The alist in question is created by `vmpc-save-replied-header'."
 637   (if (and (eq vmpc-current-buffer 'composition)
 638            (memq vmpc-current-state '(reply forward resend)))
 639       (cdr (assoc hdrfield vmpc-saved-headers-alist))))
 640
 641 (defun vmpc-substitute-replied-header (dest src)
 642   "Substitute header DEST with content from SRC.
 643 For example, if the address you want to send your reply to is the same
 644 as the contents of the \"From\" header in the message you are replying
 645 to, use (vmpc-substitute-replied-header \"To\" \"From\"."
 646   (if (memq vmpc-current-state '(reply forward resend))
 647       (progn
 648         (if (eq vmpc-current-buffer 'none)
 649             (vmpc-save-replied-header src))
 650         (if (eq vmpc-current-buffer 'composition)
 651             (vmpc-substitute-header dest (vmpc-get-saved-header src))))))
 652
 653 (defun vmpc-get-header-extents (hdrfield)
 654   "Return buffer positions (START . END) for the contents of HDRFIELD.
 655 If HDRFIELD does not exist, return nil."
 656   (if (eq vmpc-current-buffer 'composition)
 657       (save-excursion
 658         (let ((header-name-regexp "^\\([^ \t\n:]+\\):") (start) (end))
 659           (setq end
 660                 (if (mail-position-on-field hdrfield t)
 661                     (point)
 662                   nil))
 663           (setq start
 664                 (if (re-search-backward header-name-regexp (point-min) t)
 665                     (match-end 0)
 666                   nil))
 667           (and start end (<= start end) (cons start end))))))
 668
 669 (defun vmpc-substitute-within-header
 670   (hdrfield regexp to-string &optional append-if-no-match sep)
 671   "Replace in HDRFIELD strings matched by  REGEXP with TO-STRING.
 672 HDRFIELD need not exist.  TO-STRING may contain references to groups
 673 within REGEXP, in the same manner as `replace-regexp'.  If REGEXP is
 674 not found in the header contents, and APPEND-IF-NO-MATCH is t,
 675 TO-STRING will be appended to the header contents (with HDRFIELD being
 676 created if it does not exist).  In this case, if the string SEP is
 677 specified, it will be used to separate the previous header contents
 678 from TO-STRING, unless HDRFIELD has just been created or was
 679 previously empty."
 680   (if (eq vmpc-current-buffer 'composition)
 681       (save-excursion
 682         (let ((se (vmpc-get-header-extents hdrfield)) (found))
 683           (if se
 684               ;; HDRFIELD exists
 685               (save-restriction
 686                 (narrow-to-region (car se) (cdr se))
 687                 (goto-char (point-min))
 688                 (while (re-search-forward regexp nil t)
 689                   (setq found t)
 690                   (replace-match to-string))
 691                 (if (and (not found) append-if-no-match)
 692                     (progn
 693                       (goto-char (cdr se))
 694                       (if (and sep (not (equal (car se) (cdr se))))
 695                           (insert sep))
 696                       (insert to-string))))
 697             ;; HDRFIELD does not exist
 698             (if append-if-no-match
 699                 (progn
 700                   (mail-position-on-field hdrfield)
 701                   (insert to-string))))))))
 702
 703
 704 (defun vmpc-replace-or-add-in-header (hdrfield regexp hdrcont &optional sep)
 705   "Replace in HDRFIELD the match of REGEXP with HDRCONT.
 706 All arguments are strings.  The field can either be present or not.
 707 If the header field is present and already contains something, HDRCONT
 708 will be appended and if SEP is none nil it will be used as separator.
 709
 710 I use this function to modify recipients in the TO-header.
 711 e.g.
 712  (vmpc-replace-or-add-in-header \"To\" \"[Rr]obert Fenk[^,]*\"
 713                                      \"Robert Fenk\" \", \"))"
 714   (if (eq vmpc-current-buffer 'composition)
 715       (let ((hdr (vmpc-get-current-header-contents hdrfield))
 716             (old-point (point)))
 717         (if hdr
 718             (progn
 719               (vmpc-delete-header hdrfield)
 720               (if (string-match regexp hdr)
 721                   (setq hdr (vm-replace-in-string hdr regexp hdrcont))
 722                 (setq hdr (if sep (concat hdr sep hdrcont)
 723                             (concat hdr hdrcont))))
 724               (vmpc-insert-header hdrfield hdr)
 725               (goto-char old-point))
 726           ))))
 727
 728 (defun vmpc-insert-signature (sig &optional pos)
 729   "Insert SIG at the end of `vmpc-sig-exerlay'.
 730 SIG is a string.  If it is the name of a file, its contents is inserted --
 731 otherwise the string itself is inserted.  Optional parameter POS means insert
 732 the signature at POS if `vmpc-sig-exerlay' is detached."
 733   (if (eq vmpc-current-buffer 'composition)
 734       (progn
 735         (let ((end (or (vmpc-exerlay-end vmpc-sig-exerlay) pos)))
 736           (save-excursion
 737             (vmpc-set-exerlay-insertion-types 'vmpc-sig-exerlay nil t)
 738             (vmpc-set-exerlay-detachable-property vmpc-sig-exerlay nil)
 739             (vmpc-set-exerlay-intangible-property vmpc-sig-exerlay nil)
 740             (unless end
 741               (setq end (point-max))
 742               (vmpc-move-exerlay vmpc-sig-exerlay end end))
 743             (if (and pos (not (vmpc-exerlay-end vmpc-sig-exerlay)))
 744                 (vmpc-move-exerlay vmpc-sig-exerlay pos pos))
 745             (goto-char end)
 746             (insert "\n-- \n")
 747             (if (and (file-exists-p sig)
 748                      (file-readable-p sig)
 749                      (not (equal sig "")))
 750                 (insert-file-contents sig)
 751               (insert sig)))
 752           (vmpc-set-exerlay-intangible-property vmpc-sig-exerlay
 753                                                 vmpc-intangible-sig)
 754           (vmpc-set-exerlay-detachable-property vmpc-sig-exerlay t)
 755           (vmpc-set-exerlay-insertion-types 'vmpc-sig-exerlay t nil)))))
 756
 757
 758 (defun vmpc-delete-signature ()
 759   "Deletes the contents of `vmpc-sig-exerlay'."
 760   (when (and (eq vmpc-current-buffer 'composition)
 761              ;; make sure it's not detached first:
 762              (vmpc-exerlay-start vmpc-sig-exerlay))
 763     (delete-region (vmpc-exerlay-start vmpc-sig-exerlay)
 764                    (vmpc-exerlay-end vmpc-sig-exerlay))
 765     (vmpc-forcefully-detach-exerlay vmpc-sig-exerlay)))
 766
 767
 768 (defun vmpc-signature (sig)
 769   "Remove a current signature if present, and replace it with SIG.
 770 If the string SIG is the name of a readable file, its contents are
 771 inserted as the signature; otherwise SIG is inserted literally.  If
 772 SIG is the empty string (\"\"), the current signature is deleted if
 773 present, and that's all."
 774   (if (eq vmpc-current-buffer 'composition)
 775       (let ((pos (vmpc-exerlay-start vmpc-sig-exerlay)))
 776         (save-excursion
 777           (vmpc-delete-signature)
 778           (if (not (equal sig ""))
 779               (vmpc-insert-signature sig pos))))))
 780
 781
 782 (defun vmpc-insert-pre-signature (pre-sig &optional pos)
 783   "Insert PRE-SIG at the end of `vmpc-pre-sig-exerlay'.
 784 PRE-SIG is a string.  If it's the name of a file, the file's contents
 785 are inserted; otherwise the string itself is inserted.  Optional
 786 parameter POS means insert the pre-signature at position POS if
 787 `vmpc-pre-sig-exerlay' is detached."
 788   (if (eq vmpc-current-buffer 'composition)
 789       (progn
 790         (let ((end (or (vmpc-exerlay-end vmpc-pre-sig-exerlay) pos))
 791               (sigstart (vmpc-exerlay-start vmpc-sig-exerlay)))
 792           (save-excursion
 793             (vmpc-set-exerlay-insertion-types 'vmpc-pre-sig-exerlay nil t)
 794             (vmpc-set-exerlay-detachable-property vmpc-pre-sig-exerlay nil)
 795             (vmpc-set-exerlay-intangible-property vmpc-pre-sig-exerlay nil)
 796             (unless end
 797               (if sigstart
 798                   (setq end sigstart)
 799                 (setq end (point-max)))
 800               (vmpc-move-exerlay vmpc-pre-sig-exerlay end end))
 801             (if (and pos (not (vmpc-exerlay-end vmpc-pre-sig-exerlay)))
 802                 (vmpc-move-exerlay vmpc-pre-sig-exerlay pos pos))
 803             (goto-char end)
 804             (insert "\n")
 805             (if (and (file-exists-p pre-sig)
 806                      (file-readable-p pre-sig)
 807                      (not (equal pre-sig "")))
 808                 (insert-file-contents pre-sig)
 809               (insert pre-sig))))
 810         (vmpc-set-exerlay-intangible-property vmpc-pre-sig-exerlay
 811                                               vmpc-intangible-pre-sig)
 812         (vmpc-set-exerlay-detachable-property vmpc-pre-sig-exerlay t)
 813         (vmpc-set-exerlay-insertion-types 'vmpc-pre-sig-exerlay t nil))))
 814
 815
 816 (defun vmpc-delete-pre-signature ()
 817   "Deletes the contents of `vmpc-pre-sig-exerlay'."
 818   ;; make sure it's not detached first:
 819   (if (eq vmpc-current-buffer 'composition)
 820       (if (vmpc-exerlay-start vmpc-pre-sig-exerlay)
 821           (progn
 822             (delete-region (vmpc-exerlay-start vmpc-pre-sig-exerlay)
 823                            (vmpc-exerlay-end vmpc-pre-sig-exerlay))
 824             (vmpc-forcefully-detach-exerlay vmpc-pre-sig-exerlay)))))
 825
 826
 827 (defun vmpc-pre-signature (pre-sig)
 828   "Insert PRE-SIG at the end of `vmpc-pre-sig-exerlay' removing last pre-sig."
 829   (if (eq vmpc-current-buffer 'composition)
 830       (let ((pos (vmpc-exerlay-start vmpc-pre-sig-exerlay)))
 831         (save-excursion
 832           (vmpc-delete-pre-signature)
 833           (if (not (equal pre-sig ""))
 834               (vmpc-insert-pre-signature pre-sig pos))))))
 835
 836
 837 (defun vmpc-gregorian-days ()
 838   "Return the number of days elapsed since December 31, 1 B.C."
 839   ;; this code stolen from gnus-util.el :)
 840   (let ((tim (decode-time (current-time))))
 841     (timezone-absolute-from-gregorian
 842      (nth 4 tim) (nth 3 tim) (nth 5 tim))))
 843
 844
 845 (defun vmpc-load-auto-profiles ()
 846   "Initialise `vmpc-auto-profiles' from `vmpc-auto-profiles-file'."
 847   (interactive)
 848   (setq vmpc-auto-profiles nil)
 849   (if (eq vmpc-auto-profiles-file 'BBDB)
 850       (let ((records (bbdb-with-db-buffer bbdb-records))
 851             profile rec nets)
 852         (while records
 853           (setq rec (car records)
 854                 profile (bbdb-get-field rec 'vmpc-profile))
 855           (when (and profile (> (length profile) 0))
 856             (setq nets (bbdb-record-net rec))
 857             (while nets
 858               (setq vmpc-auto-profiles (cons (cons (car nets) (read profile))
 859                                              vmpc-auto-profiles)
 860                     nets (cdr nets))))
 861           (setq records (cdr records)))
 862         (setq vmpc-auto-profiles (reverse vmpc-auto-profiles)))
 863     (when (and (file-exists-p vmpc-auto-profiles-file) ;
 864                (file-readable-p vmpc-auto-profiles-file))
 865       (save-excursion
 866         (set-buffer (get-buffer-create "*pcrisis-temp*"))
 867         (buffer-disable-undo (current-buffer))
 868         (erase-buffer)
 869         (insert-file-contents vmpc-auto-profiles-file)
 870         (goto-char (point-min))
 871         (setq vmpc-auto-profiles (read (current-buffer)))
 872         (kill-buffer (current-buffer))))))
 873
 874
 875 (defun vmpc-save-auto-profiles ()
 876   "Save `vmpc-auto-profiles' to `vmpc-auto-profiles-file'."
 877   (when (not (eq vmpc-auto-profiles-file 'BBDB))
 878     (if (not (file-writable-p vmpc-auto-profiles-file))
 879         ;; if file is not writable, signal an error:
 880         (error "Error: P-Crisis could not write to file %s"
 881                vmpc-auto-profiles-file))
 882     (save-excursion
 883       (set-buffer (get-buffer-create "*pcrisis-temp*"))
 884       (buffer-disable-undo (current-buffer))
 885       (erase-buffer)
 886       (goto-char (point-min))
 887 ;       (prin1 vmpc-auto-profiles (current-buffer))
 888       (pp vmpc-auto-profiles (current-buffer))
 889       (write-region (point-min) (point-max)
 890                     vmpc-auto-profiles-file nil 'quietly)
 891       (kill-buffer (current-buffer)))))
 892
 893 (defun vmpc-fix-auto-profiles-file ()
 894   "Change `vmpc-auto-profiles-file' to the format used by v0.82+."
 895   (interactive)
 896   (vmpc-load-auto-profiles)
 897   (let ((len (length vmpc-auto-profiles)) (i 0) (day))
 898     (while (< i len)
 899       (setq day (cddr (nth i vmpc-auto-profiles)))
 900       (if (consp day)
 901           (setcdr (cdr (nth i vmpc-auto-profiles)) (car day)))
 902       (setq i (1+ i))))
 903   (vmpc-save-auto-profiles)
 904   (setq vmpc-auto-profiles ()))
 905
 906
 907 (defun vmpc-migrate-profiles-to-BBDB ()
 908   "Migrate the profiles stored in `vmpc-auto-profiles-file' to the BBDB.
 909
 910 This will automatically create records if they do not exist and add the new
 911 field `vmpc-profile' to the records which is a sexp not meant to be edited."
 912   (interactive)
 913   (if (eq vmpc-auto-profiles-file 'BBDB)
 914       (error "`vmpc-auto-profiles-file' has been migrated already."))
 915   (unless vmpc-auto-profiles
 916     (vmpc-load-auto-profiles))
 917   ;; create a BBDB backup
 918   (bbdb-save-db)
 919   (copy-file (expand-file-name bbdb-file)
 920              (concat (expand-file-name bbdb-file) "-vmpc-profile-migration-backup"))
 921   ;; now migrate the profiles
 922   (let ((profiles vmpc-auto-profiles)
 923         (records (bbdb-with-db-buffer bbdb-records))
 924         p addr rec)
 925     (while profiles
 926       (setq p (car profiles)
 927             addr (car p)
 928             rec (car (bbdb-search records nil nil addr)))
 929       (when (not rec)
 930         (setq rec (bbdb-create-internal "?" nil addr nil nil nil)))
 931       (bbdb-record-putprop rec 'vmpc-profile (format "%S" (cdr p)))
 932       (setq profiles (cdr profiles))))
 933   ;; move old profiles file out of the way
 934   (rename-file vmpc-auto-profiles-file
 935                (concat vmpc-auto-profiles-file "-migrated-to-BBDB"))
 936   ;; switch to BBDB mode
 937   (customize-save-variable 'vmpc-auto-profiles-file 'BBDB)
 938   (message "`vmpc-auto-profiles-file' has been set to 'BBDB"))
 939
 940 (defun vmpc-get-profile-for-address (addr)
 941   "Return profile for ADDR."
 942   (unless vmpc-auto-profiles
 943     (vmpc-load-auto-profiles))
 944   ;; TODO: BBDB "normalizes" email addresses, i.e. before we had a one-to-one
 945   ;; mapping of address=>actions, now multiple actions may point to the same
 946   ;; list of actions.  So either we should update vmpc-auto-profiles upon
 947   ;; storing a new profile or directly search BBDB for it, which might be
 948   ;; slower!
 949   (let ((prof (cadr (assoc addr vmpc-auto-profiles))))
 950     (when prof
 951       ;; we found a profile for this address and we are still
 952       ;; using it -- so "touch" the record to ensure it stays
 953       ;; newer than vmpc-auto-profiles-expunge-days
 954       (setcdr (cdr (assoc addr vmpc-auto-profiles)) (vmpc-gregorian-days))
 955       (vmpc-save-auto-profiles))
 956     prof))
 957
 958
 959 (defun vmpc-save-profile-for-address (addr actions)
 960   "Save the association ADDR => ACTIONS."
 961   (let ((today (vmpc-gregorian-days))
 962         (old-association (assoc addr vmpc-auto-profiles))
 963         profile)
 964
 965     ;; we store the actions list and the durrent date
 966     (setq profile (append (list addr actions) today))
 967
 968     ;; remove old profile
 969     (when old-association
 970       ;; now possibly delete it from the BBDB
 971       (setq vmpc-auto-profiles (delete old-association vmpc-auto-profiles))
 972       (when (and (eq vmpc-auto-profiles-file 'BBDB) (not actions))
 973         (let ((records (bbdb-with-db-buffer bbdb-records)) rec)
 974           (setq rec (bbdb-search records nil nil addr))
 975           (when rec
 976             (bbdb-record-putprop (car rec) 'vmpc-profile nil)))))
 977
 978     ;; add new profile
 979     (when actions
 980       (setq vmpc-auto-profiles (cons profile vmpc-auto-profiles))
 981       ;; now possibly add it to the BBDB
 982       (when (eq vmpc-auto-profiles-file 'BBDB)
 983         (let ((records (bbdb-with-db-buffer bbdb-records)) rec)
 984           (setq rec (car (bbdb-search records nil nil addr)))
 985           (when (not rec)
 986             (setq rec (bbdb-create-internal "?" nil addr nil nil nil)))
 987           (bbdb-record-putprop rec 'vmpc-profile (format "%S" (cdr profile))))))
 988
 989     ;; expunge old stuff from the list:
 990     (when vmpc-auto-profiles-expunge-days
 991       (setq vmpc-auto-profiles
 992             (mapcar (lambda (p)
 993                       (if (> (- today (cddr p)) vmpc-auto-profiles-expunge-days)
 994                           nil
 995                         p))
 996                     vmpc-auto-profiles))
 997       (setq vmpc-auto-profiles (delete nil vmpc-auto-profiles)))
 998
 999     ;; save the file
1000     (vmpc-save-auto-profiles)))
1001
1002
1003 (defun vmpc-string-extract-address (str)
1004   "Find the first email address in the string STR and return it.
1005 If no email address in found in STR, returns nil."
1006   (if (string-match "[^ \t,<]+@[^ \t,>]+" str)
1007       (match-string 0 str)))
1008
1009 (defun vmpc-split (string separators)
1010   "Return a list by splitting STRING at SEPARATORS and trimming all whitespace."
1011   (let (result
1012         (not-separators (concat "^" separators)))
1013     (save-excursion
1014       (set-buffer (get-buffer-create " *split*"))
1015       (erase-buffer)
1016       (insert string)
1017       (goto-char (point-min))
1018       (while (progn
1019                (skip-chars-forward separators)
1020                (skip-chars-forward " \t\n\r")
1021                (not (eobp)))
1022         (let ((begin (point))
1023               p)
1024           (skip-chars-forward not-separators)
1025           (setq p (point))
1026           (skip-chars-backward " \t\n\r")
1027           (setq result (cons (buffer-substring begin (point)) result))
1028           (goto-char p)))
1029       (erase-buffer))
1030     (nreverse result)))
1031
1032 (defun vmpc-read-actions (prompt)
1033   "Read a list of actions to run and store it in `vmpc-actions-to-run'."
1034   (interactive (list "VMPC actions %s:"))
1035   (let ((actions ()) a)
1036     (while (not (string-equal
1037                  (setq a (completing-read
1038                           (format prompt (or actions ""))
1039                           ;; omit those starting with (vmpc-prompt-for-profile ...
1040                           (mapcar
1041                            (lambda (a)
1042                              (if (not (or (eq (caadr a) 'vmpc-prompt-for-profile)
1043                                           (member (car a) actions)))
1044                                  a))
1045                            vmpc-actions)
1046                           nil t nil nil ""))
1047                  ""))
1048       (setq actions (cons a actions)))
1049     (setq actions (reverse actions))
1050     (when (interactive-p)
1051       (setq vmpc-actions-to-run actions)
1052       (message "VMPC actions to run: %S" actions))
1053     actions))
1054
1055 (defcustom vmpc-prompt-for-profile-headers
1056   '((composition ("To" "CC" "BCC"))
1057     (default     ("From" "Sender" "Reply-To" "From" "Resent-From")))
1058   "*List of headers to check for email addresses.
1059
1060 `vmpc-prompt-for-profile' will scan the given headers in the given order."
1061   :type '(repeat (list (choice (const default)
1062                                (const composition)
1063                                (const reply)
1064                                (const forward)
1065                                (const resent)
1066                                (const newmail))
1067                        (repeat (string :tag "Header"))))
1068   :group 'vmpc)
1069
1070 (defun vmpc-prompt-for-profile (&optional remember prompt)
1071   "Find a profile or prompt for it and add its actions to the list of actions.
1072
1073 A profile is an association between a recipient address and a set of the
1074 actions named in `vmpc-actions'.  When entering the list of actions, one has
1075 to press ENTER after each action and finish adding action by pressing ENTER
1076 without an action.
1077
1078 The association is stored in `vmpc-auto-profiles-file' and in the future the
1079 stored actions will automatically run for messages to that address.
1080
1081 REMEMBER can be set to 'always or 'prompt.  When set to 'prompt you will
1082 be asked if you want to store the association.  When set to 'always a new
1083 profile will be stored without asking.
1084
1085 If you want to change the profile late call this function interactively in a
1086 composition buffer.  Set PROFILE to 'never and you will never ever be prompted
1087 for anything, i.e. only existing profiles will be applied."
1088   (interactive (progn (setq vmpc-current-state 'automorph)
1089                       (list 'prompt 'again)))
1090
1091   (if (or (and (eq vmpc-current-buffer 'none)
1092                (not (eq vmpc-current-state 'automorph)))
1093           (eq vmpc-current-state 'automorph))
1094       (let ((headers (or (assoc vmpc-current-buffer vmpc-prompt-for-profile-headers)
1095                          (assoc vmpc-current-state vmpc-prompt-for-profile-headers)
1096                          (assoc 'default vmpc-prompt-for-profile-headers)))
1097             addrs a actions dest)
1098         (setq headers (car (cdr headers)))
1099         ;; search also other headers fro known addresses
1100         (while (and headers (not actions))
1101           (setq addrs (vmpc-get-header-contents (car headers)))
1102           (if addrs (setq addrs (vmpc-split addrs  ",")))
1103           (while addrs
1104             (setq a (vmpc-string-extract-address (car addrs)))
1105             (if (vm-ignored-reply-to a)
1106                 (setq a nil))
1107             (setq actions (append (vmpc-get-profile-for-address a) actions))
1108             (if actions (setq remember 'already))
1109             (if (not dest) (setq dest a))
1110             (setq addrs (cdr addrs)))
1111           (setq headers (cdr headers)))
1112
1113         (when dest
1114           ;; figure out which actions to run
1115           (when (if prompt (not (eq prompt 'never)) (not actions))
1116             (setq actions (vmpc-read-actions
1117                            (format "Actions for \"%s\" %%s (end with RET): " dest))))
1118
1119           ;; fixed old style format where there was only a single action
1120           (unless (listp actions)
1121             (setq remember 'again)
1122             (setq actions (list actions)))
1123
1124           ;; save the association of this profile with these actions if applicable
1125           (if (or (and (eq remember 'prompt)
1126                        (not (eq prompt 'never))
1127                        (if actions
1128                            (y-or-n-p (format "Always run %s for \"%s\"? "
1129                                              actions dest))
1130                          (if (vmpc-get-profile-for-address dest)
1131                              (yes-or-no-p (format "Delete profile for \"%s\"? "
1132                                                   dest)))))
1133                   (eq remember 'always))
1134               (vmpc-save-profile-for-address dest actions))
1135
1136           ;; TODO: understand when vmpc-prompt-for-profile has to run actions
1137           ;; if we are in automorph (actually being called from within an action)
1138           (if (eq vmpc-current-state 'automorph)
1139               (let ((vmpc-actions-to-run actions))
1140                 (vmpc-run-actions))
1141             ;; otherwise add the actions to the end of the list as a side effect
1142             (setq vmpc-actions-to-run (append vmpc-actions-to-run actions)))
1143
1144           ;; return the actions, which makes the condition true if a profile exists
1145           actions))))
1146
1147 ;; -------------------------------------------------------------------
1148 ;; Functions for vmpc-conditions:
1149 ;; -------------------------------------------------------------------
1150
1151 (defun vmpc-none-true-yet (&optional &rest exceptions)
1152   "True if none of the previous evaluated conditions was true.
1153 This is a condition that can appear in `vmpc-conditions'.  If EXCEPTIONS are
1154 specified, it means none were true except those.  For example, if you wanted
1155 to check whether no conditions had yet matched with the exception of the two
1156 conditions named \"default\" and \"blah\", you would make the call like this:
1157   (vmpc-none-true-yet \"default\" \"blah\")
1158 Then it will return true regardless of whether \"default\" and \"blah\" had
1159 matched."
1160   (let ((lenex (length exceptions)) (lentc (length vmpc-true-conditions)))
1161     (cond
1162      ((> lentc lenex)
1163       'nil)
1164      ((<= lentc lenex)
1165       (let ((i 0) (j 0) (k 0))
1166         (while (< i lenex)
1167           (setq k 0)
1168           (while (< k lentc)
1169             (if (equal (nth i exceptions) (nth k vmpc-true-conditions))
1170                 (setq j (1+ j)))
1171             (setq k (1+ k)))
1172           (setq i (1+ i)))
1173         (if (equal j lentc)
1174             't
1175           'nil))))))
1176
1177 (defun vmpc-other-cond (condition)
1178   "Return true if the specified CONDITION in `vmpc-conditions' matched.
1179 CONDITION can only be the name of a condition specified earlier in
1180 `vmpc-conditions' -- that is to say, any conditions which follow the one
1181 containing `vmpc-other-cond' will show up as not having matched, because they
1182 haven't yet been checked when this one is checked."
1183   (member condition vmpc-true-conditions))
1184
1185 (defun vmpc-folder-match (regexp)
1186   "Return true if the current folder name matches REGEXP."
1187   (string-match regexp (buffer-name)))
1188
1189 (defun vmpc-header-match (hdrfield regexp &optional clump-sep num)
1190   "Return true if the contents of specified header HDRFIELD match REGEXP.
1191 For automorph, this means the header in your message, when replying it means
1192 the header in the message being replied to.
1193
1194 CLUMP-SEP is specified, treat HDRFIELD as a regular expression and
1195 return the contents of all header fields which match that regexp,
1196 separated from each other by CLUMP-SEP.
1197
1198 If NUM is specified return the match string NUM."
1199   (cond ((memq vmpc-current-state '(reply forward resend))
1200          (let ((hdr (vmpc-get-replied-header-contents hdrfield clump-sep)))
1201            (and hdr (string-match regexp hdr)
1202                 (if num (match-string num hdr) t))))
1203         ((eq vmpc-current-state 'automorph)
1204          (let ((hdr (vmpc-get-current-header-contents hdrfield clump-sep)))
1205            (and (string-match regexp hdr)
1206                 (if num (match-string num hdr) t))))))
1207
1208 (defun vmpc-body-match (regexp)
1209   "Return non-nil if the contents of the message body match REGEXP.
1210 For automorph, this means the body of your message; when replying it means the
1211 body of the message being replied to."
1212   (cond ((and (memq vmpc-current-state '(reply forward resend))
1213               (eq vmpc-current-buffer 'none))
1214          (string-match regexp (vmpc-get-replied-body-text)))
1215         ((eq vmpc-current-state 'automorph)
1216          (string-match regexp (vmpc-get-current-body-text)))))
1217
1218
1219 (defun vmpc-xor (&rest args)
1220   "Return true if one and only one argument in ARGS is true."
1221   (= 1 (length (delete nil args))))
1222
1223 ;; -------------------------------------------------------------------
1224 ;; Support functions for the advices:
1225 ;; -------------------------------------------------------------------
1226
1227 (defun vmpc-true-conditions ()
1228   "Return a list of all true conditions.
1229 Run this function in order to test/check your conditions."
1230   (interactive)
1231   (let (vmpc-true-conditions
1232         vmpc-current-state
1233         vmpc-current-buffer)
1234     (if (eq major-mode 'vm-mail-mode)
1235         (setq vmpc-current-state 'automorph
1236               vmpc-current-buffer 'composition)
1237       (setq vmpc-current-state (intern (completing-read
1238                                         "VMPC state (default is 'reply): "
1239                                         '(("reply") ("forward") ("resend")
1240                                           ("newmail") ("automorph"))
1241                                         nil t nil nil "reply"))
1242             vmpc-current-buffer 'none))
1243     (vm-follow-summary-cursor)
1244     (vm-select-folder-buffer)
1245     (vm-check-for-killed-summary)
1246     (vm-error-if-folder-empty)
1247     (vmpc-build-true-conditions-list)
1248     (message "VMPC true conditions: %S" vmpc-true-conditions)
1249     vmpc-true-conditions))
1250
1251 (defun vmpc-build-true-conditions-list ()
1252   "Built list of true conditions and store it in variable `vmpc-true-conditions'."
1253   (setq vmpc-true-conditions nil)
1254   (mapcar (lambda (c)
1255             (if (save-excursion (eval (cons 'progn (cdr c))))
1256                 (setq vmpc-true-conditions (cons (car c) vmpc-true-conditions))))
1257           vmpc-conditions)
1258   (setq vmpc-true-conditions (reverse vmpc-true-conditions)))
1259
1260 (defun vmpc-build-actions-to-run-list ()
1261   "Built a list of the actions to run.
1262 These are the true conditions mapped to actions.  Duplicates will be
1263 eliminated.  You may run it in a composition buffer in order to see what
1264 actions will be run."
1265   (interactive)
1266   (if (and (interactive-p) (not (member major-mode '(vm-mail-mode mail-mode))))
1267       (error "Run `vmpc-build-actions-to-run-list' in a composition buffer!"))
1268   (let ((alist (or (symbol-value (intern (format "vmpc-%s-alist"
1269                                                  vmpc-current-state)))
1270                    vmpc-actions-alist))
1271         (old-vmpc-actions-to-run vmpc-actions-to-run)
1272         actions)
1273     (setq vmpc-actions-to-run nil)
1274     (mapcar (lambda (c)
1275               (setq actions (cdr (assoc c alist)))
1276               ;; TODO: warn about unbound conditions?
1277               (while actions
1278                 (if (not (member (car actions) vmpc-actions-to-run))
1279                     (setq vmpc-actions-to-run (cons (car actions) vmpc-actions-to-run)))
1280                 (setq actions (cdr actions))))
1281             vmpc-true-conditions)
1282     (setq vmpc-actions-to-run (reverse vmpc-actions-to-run))
1283     (setq vmpc-actions-to-run (append vmpc-actions-to-run old-vmpc-actions-to-run)))
1284   (if (interactive-p)
1285       (message "VMPC actions to run: %S" vmpc-actions-to-run))
1286   vmpc-actions-to-run)
1287
1288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1289 ;;;###autoload
1290 (defun vmpc-run-action (&optional action-regexp)
1291   "Run all actions with names matching the ACTION-REGEXP.
1292 If called interactivly it promts for the regexp.  You may also use
1293 completion."
1294   (interactive)
1295   (let ((action-names (mapcar '(lambda (a)
1296                                  (list (regexp-quote (car a)) 1))
1297                               vmpc-actions)))
1298     (if (not action-regexp)
1299         (setq action-regexp (completing-read "VMPC action-regexp: "
1300                                              action-names)))
1301     (mapcar '(lambda (action)
1302                (if (string-match action-regexp (car action))
1303                    (mapcar '(lambda (action-command)
1304                               (eval action-command))
1305                            (cdr action))))
1306             vmpc-actions)))
1307
1308
1309 (defun vmpc-run-actions (&optional actions verbose)
1310   "Run the argument actions, or the actions stored in `vmpc-actions-to-run'.
1311 If verbose is supplied, it should be a STRING, indicating the name of a
1312 buffer to which to write diagnostic output."
1313   (interactive)
1314
1315   (if (and (not vmpc-actions-to-run) (not actions) (interactive-p))
1316       (setq vmpc-actions-to-run (vmpc-read-actions "VMPC actions %%s")))
1317
1318   (let ((actions (or actions vmpc-actions-to-run)) form)
1319     (while actions
1320       (setq form (or (assoc (car actions) vmpc-actions)
1321                      (error "Action %S does not exist!" (car actions)))
1322             actions (cdr actions))
1323       (let ((form (cons 'progn (cdr form)))
1324             (results (eval (cons 'progn (cdr form)))))
1325         (when verbose
1326           (save-excursion
1327             (set-buffer verbose)
1328             (insert (format "Action form is:\n%S\nResults are:\n%S\n"
1329                             form results))))))))
1330
1331 ;; ------------------------------------------------------------------------
1332 ;; The main functions and advices -- these are the entry points to pcrisis:
1333 ;; ------------------------------------------------------------------------
1334 (defun vmpc-init-vars (&optional state buffer)
1335   "Initialize pcrisis variables and optionally set STATE and BUFFER."
1336   (setq vmpc-saved-headers-alist nil
1337         vmpc-actions-to-run nil
1338         vmpc-true-conditions nil
1339         vmpc-current-state state
1340         vmpc-current-buffer (or buffer 'none)))
1341
1342 (defun vmpc-make-vars-local ()
1343   "Make the pcrisis vars buffer local.
1344
1345 When the vars are first set they cannot be made buffer local as we are not in
1346 the composition buffer then.
1347
1348 Unfortunately making them buffer local while they are bound by a `let' does
1349 not work, see the info for `make-local-variable'.  So we are using the global
1350 ones and make them buffer local when in the composition buffer.  At least for
1351 `saved-headers-alist' this should fix the bug that another composition
1352 overwrites the stored headers for subsequent morphs.
1353
1354 The current solution is not reentrant save, but there also should be no
1355 recursion nor concurrent calls."
1356   ;; make the variables buffer local
1357   (let ((tc vmpc-true-conditions)
1358         (sha vmpc-saved-headers-alist)
1359         (atr vmpc-actions-to-run)
1360         (cs vmpc-current-state))
1361     (make-local-variable 'vmpc-true-conditions)
1362     (make-local-variable 'vmpc-saved-headers-alist)
1363     (make-local-variable 'vmpc-actions-to-run)
1364     (make-local-variable 'vmpc-current-state)
1365     (make-local-variable 'vmpc-current-buffer)
1366     ;; now set them again to make sure the contain the right value
1367     (setq vmpc-true-conditions tc)
1368     (setq vmpc-saved-headers-alist sha)
1369     (setq vmpc-actions-to-run atr)
1370     (setq vmpc-current-state cs))
1371     ;; mark, that we are in the composition buffer now
1372     (setq vmpc-current-buffer      'composition)
1373   ;; BUGME why is the global value resurrected after making the variable
1374   ;; buffer local?  Is this related to defadvice?  I have no idea what is
1375   ;; going on here!  Thus we clear it afterwards now!
1376   (save-excursion
1377     (set-buffer (get-buffer-create " *vmpc-cleanup*"))
1378     (vmpc-init-vars)
1379     (setq vmpc-current-buffer nil)))
1380
1381 (defadvice vm-do-reply (around vmpc-reply activate)
1382   "*Reply to a message with pcrisis voodoo."
1383   (vmpc-init-vars 'reply)
1384   (vmpc-build-true-conditions-list)
1385   (vmpc-build-actions-to-run-list)
1386   (vmpc-run-actions)
1387   ad-do-it
1388   (vmpc-create-sig-and-pre-sig-exerlays)
1389   (vmpc-make-vars-local)
1390   (vmpc-run-actions))
1391
1392 (defadvice vm-mail (around vmpc-newmail activate)
1393   "*Start a new message with pcrisis voodoo."
1394   (vmpc-init-vars 'newmail)
1395   (vmpc-build-true-conditions-list)
1396   (vmpc-build-actions-to-run-list)
1397   (vmpc-run-actions)
1398   ad-do-it
1399   (vmpc-create-sig-and-pre-sig-exerlays)
1400   (vmpc-make-vars-local)
1401   (vmpc-run-actions))
1402
1403 (defadvice vm-compose-mail (around vmpc-compose-newmail activate)
1404   "*Start a new message with pcrisis voodoo."
1405   (vmpc-init-vars 'newmail)
1406   (vmpc-build-true-conditions-list)
1407   (vmpc-build-actions-to-run-list)
1408   (vmpc-run-actions)
1409   ad-do-it
1410   (vmpc-create-sig-and-pre-sig-exerlays)
1411   (vmpc-make-vars-local)
1412   (vmpc-run-actions))
1413
1414 (defadvice vm-forward-message (around vmpc-forward activate)
1415   "*Forward a message with pcrisis voodoo."
1416   ;; this stuff is already done when replying, but not here:
1417   (vm-follow-summary-cursor)
1418   (vm-select-folder-buffer)
1419   (vm-check-for-killed-summary)
1420   (vm-error-if-folder-empty)
1421   ;;  the rest is almost exactly the same as replying:
1422   (vmpc-init-vars 'forward)
1423   (vmpc-build-true-conditions-list)
1424   (vmpc-build-actions-to-run-list)
1425   (vmpc-run-actions)
1426   ad-do-it
1427   (vmpc-create-sig-and-pre-sig-exerlays)
1428   (vmpc-make-vars-local)
1429   (vmpc-run-actions))
1430
1431 (defadvice vm-resend-message (around vmpc-resend activate)
1432   "*Resent a message with pcrisis voodoo."
1433   ;; this stuff is already done when replying, but not here:
1434   (vm-follow-summary-cursor)
1435   (vm-select-folder-buffer)
1436   (vm-check-for-killed-summary)
1437   (vm-error-if-folder-empty)
1438   ;; the rest is almost exactly the same as replying:
1439   (vmpc-init-vars 'resend)
1440   (vmpc-build-true-conditions-list)
1441   (vmpc-build-actions-to-run-list)
1442   (vmpc-run-actions)
1443   ad-do-it
1444   (vmpc-create-sig-and-pre-sig-exerlays)
1445   (vmpc-make-vars-local)
1446   (vmpc-run-actions))
1447
1448 (defvar vmpc-no-automorph nil
1449   "When true automorphing will be disabled.")
1450
1451 (make-variable-buffer-local 'vmpc-no-automorph)
1452
1453 ;;;###autoload
1454 (defun vmpc-toggle-no-automorph ()
1455   "Disable automorph for the current buffer.
1456 When automorph is not doing the right thing and you want to disable it for the
1457 current composition, then call this function."
1458   (interactive)
1459   (setq vmpc-no-automorph (not vmpc-no-automorph))
1460   (message (if vmpc-no-automorph
1461                "Automorphing has been enabled"
1462              "Automorphing has been disabled")))
1463
1464 ;;;###autoload
1465 (defun vmpc-automorph ()
1466   "*Change contents of the current mail message based on its own headers.
1467 Unless `vmpc-current-state' is 'no-automorph, headers and signatures can be
1468 changed; pre-signatures added; functions called.
1469
1470 Call `vmpc-no-automorph' to disable it for the current buffer."
1471   (interactive)
1472   (unless vmpc-no-automorph
1473     (vmpc-make-vars-local)
1474     (vmpc-init-vars 'automorph 'composition)
1475     (vmpc-build-true-conditions-list)
1476     (vmpc-build-actions-to-run-list)
1477     (vmpc-run-actions)))
1478
1479 (provide 'vm-pcrisis)
1480
1481 ;;; vm-pcrisis.el ends here