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

   1 ;;; vm-serial.el --- automatic creation of personalized message bodies
   2 ;;                   and sending of personalized serial mails
   3 ;;
   4 ;; Copyright (C) 2000-2005 Robert Widhopf-Fenk
   5 ;;
   6 ;; Author:      Robert Widhopf-Fenk
   7 ;; Status:      Tested with XEmacs 21.4.15 & VM 7.19
   8 ;; Keywords:    sending mail, default mail, multiple recipients, serial mails
   9 ;; X-URL:       http://www.robf.de/Hacking/elisp
  10
  11 ;;
  12 ;; This code 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 1, 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, write to the Free Software
  24 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25 ;;
  26 ;;
  27 ;;; Commentary:
  28 ;;
  29 ;; Are you lazy on the one hand, but you like salutations and greetings?
  30 ;;
  31 ;;  YES?
  32 ;;
  33 ;; If so you got the right package here!  The idea is similar to those of
  34 ;; autoinsert.el, tempo.el, template.el etc., but specialized for composing
  35 ;; mails with VM.
  36 ;;
  37 ;; You may want to use the following into your .vm file after adding other
  38 ;; vm-mail-mode-hooks ...
  39 ;;
  40 ;;   (require 'vm-serial)
  41 ;;   (add-hook 'vm-mail-mode-hook 'vm-serial-auto-yank-mail t)
  42 ;;   (define-key vm-mail-mode-map "\C-c\C-t" 'vm-serial-expand-tokens)
  43 ;;
  44 ;; and check out what happens if you reply to a message or what happens after
  45 ;; specifying a recipient in the to header and typing [C-c C-t].
  46 ;;
  47 ;; Isn't it cool?
  48 ;;
  49 ;; Now add multiple recipients to a mail before pressing [C-c C-t] and call
  50 ;; [M-x vm-serial-send-mail] in order to see what happens.  If you are a
  51 ;; trustful guy you may add a prefix arg [C-u].
  52 ;;
  53 ;; In order to learn more about valid tokens you should have a look at the
  54 ;; documentation mail template.
  55 ;;
  56 ;; Go to an newly mail buffer add a From and To header and type:
  57 ;;    C-u M-x vm-serial-yank-mail RET doc RET
  58 ;;    M-x vm-serial-expand-tokens RET
  59 ;;
  60 ;;; KNOWN PROBLEMS:
  61 ;;
  62 ;; - mail-signature: instead of using this variable, you should use
  63 ;;   `vm-serial-mail-signature' with exaclty the same semantics.
  64 ;;
  65 ;;; Thanks:
  66 ;;
  67 ;; Ivan Kanis has contributed some bugfixes & enhancements.
  68 ;;
  69 ;;; Code:
  70
  71 (defgroup vm nil
  72   "VM"
  73   :group 'mail)
  74
  75 (defgroup vm-serial nil
  76   "Sending personalized serial mails and getting message templates."
  77   :group  'vm)
  78
  79 (eval-when-compile
  80   (require 'cl))
  81
  82 (require 'vm-reply)
  83
  84 (eval-and-compile
  85   (require 'vm-pine)
  86   (require 'mail-utils)
  87   (require 'mail-extr)
  88   (require 'advice))
  89
  90 (let ((feature-list '(bbdb bbdb-sc)))
  91   (while feature-list
  92     (condition-case nil
  93         (require (car feature-list))
  94       (error
  95        (if (load (format "%s" (car feature-list)) t)
  96            (message "Library %s loaded!" (car feature-list))
  97          (message "Could not load feature %S.  Related functions may not work correctly!" (car feature-list)))))
  98     (setq feature-list (cdr feature-list))))
  99
 100 (defvar vm-reply-list nil)
 101 (defvar vm-redistribute-list nil)
 102 (defvar vm-forward-list)
 103
 104 ;;-----------------------------------------------------------------------------
 105 (defcustom vm-serial-token-alist
 106   '(;; standard tokens you should not change (or need not)
 107     ("to"       (vm-serial-get-to)
 108      "to header of the mail")
 109
 110     ("sir"      (vm-serial-get-name 'last)
 111      "the last name of the recipient")
 112     ("you"      (vm-serial-get-name 'first)
 113      "the first name of the recipient")
 114     ("mr"       (vm-serial-get-name)
 115      "the full name of the recipient")
 116
 117     ("bbdbsir"  (vm-serial-get-bbdb-name 'last)
 118      "the last name of the recipient as returned by the BBDB")
 119     ("bbdbyou"  (vm-serial-get-bbdb-name 'first)
 120      "the first name of the recipient as returned by the BBDB")
 121     ("bbdbmr"   (vm-serial-get-bbdb-name)
 122      "the full name of the recipient as returned by the BBDB")
 123
 124     ("me"       (user-full-name)
 125      "your full name")
 126     ("i"        (vm-serial-get-name 'first (user-full-name))
 127      "your first name")
 128     ("I"        (vm-serial-get-name 'last (user-full-name))
 129      "your last name")
 130     ("point"    (and (setq vm-serial-point (point)) nil)
 131      "the position of point after expanding tokens")
 132     ("reply"    (if (and vm-reply-list vm-serial-body-contents)
 133                     (insert vm-serial-body-contents))
 134      "set to the message body when replying")
 135     ("forward"  (if (and vm-forward-list vm-serial-body-contents)
 136                     (insert vm-serial-body-contents))
 137      "set to the message body when forwarding")
 138     ("body"     (if vm-serial-body-contents
 139                     (insert vm-serial-body-contents))
 140      "set to the message body before yanking a mail template")
 141     ("sig"      (cond
 142                  ((not vm-serial-mail-signature)
 143                   nil)
 144                  ((stringp vm-serial-mail-signature)
 145                   vm-serial-mail-signature)
 146                  ((eq t vm-serial-mail-signature)
 147                   (insert-file mail-signature-file))
 148                  ((functionp vm-serial-mail-signature)
 149                   (funcall vm-serial-mail-signature))
 150                  (t
 151                   (eval vm-serial-mail-signature)))
 152      "the signature obtained from `vm-serial-mail-signature'")
 153     ("fifosig"   (concat "-- \n"
 154                          (shell-command-to-string
 155                           (concat "cat " mail-signature-file)))
 156      "a signature read from a FIFO")
 157     ;; english
 158     ("hi"       ("Hi" "Hello" "Dear")
 159      "a randomly selected hi-style salutation")
 160     ("dear"     ("Lovely" "Hello" "Dear" "Sweetheart")
 161      "a randomly selected dear-style salutation")
 162     ("bye"      ("" "Bye " "Cheers " "CU ")
 163      "a randomly selected bye-style greeting")
 164     ("br"       ("Best regards" "Sincerly" "Yours")
 165      "a randomly selected best-regards-style greeting")
 166     ("babe"     ("honey" "sugar pie" "darling" "babe")
 167      "a randomly selected honey-style salutation")
 168     ("inlove"   ("In love" "Dreaming of you" "1 billion kisses")
 169      "a randomly selected inlove-style greeting")
 170     ("your"     ("honey" "sugar pie" "darling" "babe"
 171                  (vm-serial-get-name 'first (user-full-name)))
 172      "a randomly selected your-style greeting")
 173     ;; german
 174     ("hallo"    ("Hi" "Griass di" "Servus" "Hallo")
 175      "ein Hallo-Gruß")
 176     ("mausl"    ("Mausl" "Liebling" "Schatzi" "Hallo")
 177      "die Freundin")
 178     ("ciao"     ("" "Ciao " "Tschüß " "Servus " "Mach's gut " "Bis denn "
 179                  "Bis die Tage mal ")
 180      "Verabschiedung")
 181     ("sg"      ("Sehr geehrte Frau/Herr")
 182      "förmliche Anrede")
 183     ("mfg"     ("Mit freundlichen Grüßen")
 184      "förmliche Verabschiedung")
 185     ;; french
 186     ("salut" ("Salut" "Bonjour")
 187      "Une salutation au hasard")
 188     ("merci" ("Merci" "Au revoir" "A+" "Amicalement")
 189      "Un au revoir au hasard")
 190     )
 191   "*Alist for mapping tokens to real things, i.e., strings.
 192 Set this by calling `vm-serial-set-tokens'!
 193
 194 The format of each record is:
 195
 196         (TOKENNAME SEXPRESSION DOCUMENTATION)
 197
 198 TOKENNAME and DOCUMENTATION have to be strings.
 199 SEXPRESSION one of
 200 - a list starting with a string, which might be followed by other
 201   string, functions or Lisp expressions
 202 - a function returning a string
 203 - a Lisp expression which evaluates to a string
 204
 205 When a list starting with a string then `vm-serial-expand-tokens' will
 206 randomly select one of them during expansion."
 207   :group 'vm-serial
 208   :type '(repeat (list (string :tag "Tagname")
 209                        (choice (repeat :tag "List of strings" (string))
 210                                (sexp :tag "SExp evaluating to a string"))
 211                        (string :tag "Documentation"))))
 212
 213 (defcustom vm-serial-mails-alist
 214   '(("honey"
 215      "girlfriend"
 216      "$dear $babe,
 217
 218 $point$reply
 219
 220 $inlove $your
 221 $forward")
 222     ("german-reply"
 223      (and vm-reply-list
 224           (string-match "\\.\\(de\\|at\\|ch\\)>?$"
 225                         (vm-mail-mode-get-header-contents "To:")))
 226           "$reply
 227 $point
 228 $ciao$i")
 229     ("german-default"
 230      "\\.\\(de\\|at\\|ch\\)>?$"
 231      "$hallo $you,
 232
 233 $point$reply
 234
 235 $ciao$i
 236
 237 $forward
 238 $sig")
 239     ("german-serious"
 240      "\\.\\(de\\|at\\|ch\\)>?$"
 241      "$sg $sir,
 242
 243 $point$reply
 244
 245 $mfg
 246 $me
 247
 248 $forward
 249 $sig")
 250     ("english-reply"
 251      vm-reply-list
 252      "$reply
 253 $point
 254 $bye$i")
 255     ("english-default"
 256      t
 257      "$hi $you,
 258
 259 $point$reply
 260
 261 $bye$i
 262
 263 $forward
 264 $sig
 265 ")
 266     ;; A test mail for showing what's possible
 267     ("doc"
 268      nil
 269      "
 270                             A LECTURE ON VM-SERIAL
 271
 272 The `vm-serial-mails-alist' contains a list of templates and associated
 273 conditions and names for these templates.
 274
 275 When doing a `vm-serial-yank-mail' it will check for the first condition
 276 which matches and inserts this template.  Tokens in the template are
 277 expanded by the function called `vm-serial-expand-tokens'.
 278
 279 There are default tokens for various things.  Tokens start with the
 280 string specified in `vm-serial-cookie' which is \"$(eval vm-serial-cookie)\" followed by a
 281 string matching the regexp \\([a-zA-Z][a-zA-Z0-9_-]*\\) which may be
 282 enclosed by {} or a lisp expressions.  The first type is a named token
 283 and has to be listed in the variable `vm-serial-token-alist'.  It will be
 284 expanded and if evaluating to a non nil object then it is inserted.  In
 285 order to get just the `vm-serial-cookie' \"$(eval vm-serial-cookie)\" simply write it twice.
 286
 287 You may also embed any kind of lisp expression.  If they return a string, it
 288 will be inserted.
 289
 290 Do [M-x vm-serial-expand-tokens] in order to see how things change ...
 291
 292 Example of a embedded lisp expression:
 293
 294  the current date is $$(format-time-string \"%D %r\").
 295
 296  $$(center-line) Center this line
 297
 298  $$$no expansion
 299
 300 The following tokens are currently defined:
 301
 302 Token   Documentation  (the example follows in the next line)
 303 $(mapconcat
 304   (function (lambda (tk)
 305       (concat (car tk) \"\\t\" (caddr tk) \"\n\t$\" (car tk))))
 306   vm-serial-token-alist  \"\n\")
 307
 308
 309 If you thing there are other tokens which should be added to this list, please
 310 let me know!
 311
 312 mailto:Robert Fenk"))
 313   "*Alist of default mail templates.
 314 Set this by calling `vm-serial-set-mail'!
 315
 316 Format:
 317    ((SYMBOLIC-NAME CONDITION MAIL-FORM)
 318     ...)
 319
 320 When calling `vm-serial-yank-mail' interactively one will be prompted for
 321 a SYMBOLIC-NAME of a mail from.  If called non interactively it will
 322 search for the first condition which evaluates to true and inserts the
 323 corresponding mail.  If CONDITION is a string it is matched against the
 324 To-header otherwise it is evaluated."
 325   :group 'vm-serial
 326   :type '(repeat (list (string :tag "Name")
 327                        (choice :tag "Condition"
 328                                (const :tag "NEVER" nil)
 329                                (const :tag "ALWAYS" t)
 330                                (string :tag "Regexp" "emailaddress")
 331                                (variable-item :tag "Relpy" vm-reply-list)
 332                                (variable-item :tag "Forward" vm-forward-list)
 333                                (variable-item :tag "Redistribute" vm-redistribute-list)
 334                                (sexp :tag "SEXP"))
 335                        (string :tag "Message-Template"))))
 336
 337 (defcustom vm-serial-cookie "$"
 338   "*The string which begins a token or Lisp expression.
 339 See `vm-serial-expand-tokens' for information about valid tokens."
 340   :group 'vm-serial
 341   :type 'string)
 342
 343 (defcustom vm-serial-fcc  nil
 344   "*Whether to keep a FCC from the source mail within each serial mail.
 345 If the function `vm-postpone-message' (from vm-pine) is present it will
 346 also save the source message in the specified folder otherwise there is
 347 no way to save the source message."
 348   :group 'vm-serial
 349   :type 'boolean)
 350
 351 (defcustom vm-serial-mail-signature nil
 352   "*Text inserted at the `sig'-token of a mail buffer.
 353 The semantics are equal to those of variable `mail-signature', however you
 354 should disable variable `mail-signature', since it interacts badly with
 355 vm-serial, i.e. set vm-serial-mail-signature to the value of variable
 356 `mail-signature' and set variable `mail-signature' to nil!"
 357   :group 'vm-serial
 358   :type '(choice (const :tag "None" nil)
 359                  (const :tag "The content of `mail-signature-file'" t)
 360                  (function-item :tag "Function")
 361                  (sexp :tag "Lisp-Form")))
 362
 363 (defvar vm-serial-to  nil
 364   "The recipient of the currently expanded message.")
 365
 366 (defvar vm-serial-body-contents nil
 367   "The message body of the currently replied or forwarded message.")
 368
 369 (defcustom vm-serial-unknown-to  "unknown"
 370   "*The string displayed for recipients without a real name.
 371 If set to something different than a string it will be evaluated in order to
 372 return a string."
 373   :group 'vm-serial
 374   :type 'string)
 375
 376 (defvar vm-serial-source-buffer
 377   nil
 378   "The source buffer of the currently expanded template.
 379 When doing a `vm-serial-send-mail' this will point to the source
 380 buffer containing the original message.")
 381
 382 (defvar vm-serial-send-mail-buffer "*vm-serial-mail*"
 383   "*Name of the buffer use by `vm-serial-send-mail' for expanded template.")
 384
 385 (defvar vm-serial-send-mail-jobs
 386   nil
 387   "Remaining list of addresses which have to be processed after editing.")
 388
 389 (make-variable-buffer-local 'vm-serial-source-buffer)
 390 (make-variable-buffer-local 'vm-serial-send-mail-jobs)
 391
 392 ;;-----------------------------------------------------------------------------
 393 (defun vm-serial-get-completing-list (alist)
 394   "Return cars from ALIST for completion."
 395   (mapcar (lambda (e) (list (car e))) alist))
 396
 397 ;;-----------------------------------------------------------------------------
 398 (defvar vm-serial-token-history nil)
 399
 400 (defun vm-serial-set-token (&optional token newvalue doc)
 401   "Set vm-serial TOKEN to NEWVALUE with DOC.
 402 You may remove a token by specifying just the TOKEN as argument."
 403   (interactive
 404    (let* ((token (completing-read "Token: "
 405                                 (vm-serial-get-completing-list
 406                                  vm-serial-token-alist)
 407                                 nil nil nil
 408                                 vm-serial-token-history))
 409           (value (read-expression
 410                   "Value: "
 411                   (format "%S" (cdr (assoc var vm-serial-token-alist))))))
 412      (list token value)))
 413   (let ((tk (assoc token vm-serial-token-alist)))
 414     (if tk
 415         (if newvalue
 416             (setcdr tk (list newvalue doc))
 417           (setq vm-serial-token-alist (delete tk vm-serial-token-alist)))
 418       (setq vm-serial-token-alist
 419             (nconc vm-serial-token-alist
 420                    (list (list token newvalue doc)))))))
 421
 422 (defun vm-serial-set-tokens (token-list)
 423   "Set `vm-serial-token-alist' according to TOKEN-LIST.
 424 Is a list of (TOKEN NEWVALUE DOC) elements"
 425   (let (token-value)
 426   (while token-list
 427     (setq token-value (car token-list))
 428     (vm-serial-set-token (car token-value) (cadr token-value)
 429                          (caddr token-value))
 430     (setq token-list (cdr token-list)))))
 431
 432 (defun vm-serial-get-token (&optional token)
 433   "Return value of vm-serial TOKEN."
 434   (interactive (list (completing-read "Token: "
 435                                       (vm-serial-get-completing-list
 436                                        vm-serial-token-alist)
 437                                       nil nil nil
 438                                       vm-serial-token-history)))
 439   (let ((value (assoc token vm-serial-token-alist)))
 440     (if value
 441         (cadr value)
 442       (warn "There is no vm-serial token `%s'" token)
 443       nil)))
 444
 445 (defun vm-serial-eval-token-value (&optional token-value)
 446   "Return string value by evaluation TOKEN-VALUE."
 447   (if (stringp token-value)
 448       token-value
 449     (condition-case err
 450       (cond ((and (listp token-value) (stringp (car token-value)))
 451              (setq token-value (vm-serial-random-string token-value)))
 452             ((functionp token-value)
 453              (setq token-value (funcall  token-value)))
 454           (t
 455            (setq token-value (eval token-value))))
 456       (error (setq token-value nil)
 457              (warn (format "Token `%s' caused a %S"
 458                            token-value err))
 459              nil))
 460     token-value))
 461
 462 ;;-----------------------------------------------------------------------------
 463 (defun vm-serial-get-emails (&optional header)
 464   "Return the recipient of current message.
 465 Optional argument HEADER is the header to get the recipients from."
 466   (setq header (or header "To:"))
 467   (let ((to (vm-mail-mode-get-header-contents header)))
 468     (if (functionp 'bbdb-extract-address-components)
 469         (car (bbdb-extract-address-components to))
 470       (mail-extract-address-components to))))
 471
 472 (defun vm-serial-get-to ()
 473   "Return the recipient of current message."
 474   (or vm-serial-to
 475       (vm-serial-get-emails "To:")))
 476
 477 (defun vm-serial-get-name (&optional part name)
 478   (let ((name (or name
 479                   (and vm-serial-to (car vm-serial-to))
 480                   (let ((to (vm-serial-get-to)))
 481                     (and to (or (car to)
 482                                 (cadr to))))
 483                   (eval vm-serial-unknown-to)))
 484         (part (cond ((stringp part) part)
 485                     ((equal part 'first) "^\\(\\w+\\)[\t ._]")
 486                     ((equal part 'last) "^\\w+[\t ._]+\\(.+\\)$"))))
 487
 488     (if (and part (string-match part name))
 489         (match-string 1 name)
 490       name)))
 491
 492 (defun vm-serial-get-bbdb-name (&optional part name)
 493   (let* ((to (vm-serial-get-to))
 494          (rec (bbdb-search-simple nil (cadr to))))
 495     (if rec
 496         (cond ((equal part 'first) (or (bbdb/sc-consult-attr (cadr to))
 497                                        (bbdb-record-firstname rec)))
 498               ((equal part 'last)  (bbdb-record-lastname rec)))
 499       (vm-serial-get-name part name))))
 500
 501 ;;-----------------------------------------------------------------------------
 502 (defun vm-serial-set-mails (mail-alist)
 503   "Set `vm-serial-mails-alist' according to MAIL-ALIST."
 504   (let (m)
 505     (setq mail-alist (reverse mail-alist))
 506     (while mail-alist
 507       (setq m (assoc (caar mail-alist) vm-serial-mails-alist))
 508       (if m
 509           (setq vm-serial-mails-alist (delete m vm-serial-mails-alist)))
 510       (add-to-list 'vm-serial-mails-alist (car mail-alist))
 511       (setq mail-alist (cdr mail-alist)))))
 512
 513 (defun vm-serial-get-mail (&optional mail)
 514   "Return the mail body associated with MAIL."
 515   (let ((value (assoc mail vm-serial-mails-alist)))
 516     (if value (car (last value)) nil)))
 517
 518 (defvar vm-serial-mail-history nil
 519   "History for `vm-serial-yank-mail'.")
 520
 521 (defun vm-serial-find-default-mail ()
 522   "Return the first recipient."
 523   (let ((to (vm-decode-mime-encoded-words-in-string
 524              (or (vm-mail-mode-get-header-contents "To:")
 525                  (vm-mail-mode-get-header-contents "CC:")
 526                  (vm-mail-mode-get-header-contents "BCC:")
 527                  "")))
 528         (mails-alist vm-serial-mails-alist)
 529         m mail)
 530     (setq mail nil)
 531     (if (string-match "^\\s-*\\(.*[^ \t]\\)\\s-*$" to)
 532         (setq to (match-string 1 to)))
 533     (while mails-alist
 534       (setq m (car mails-alist))
 535       (if (and (> (length m) 2)
 536                (cond ((stringp (cadr m))
 537                       (let ((case-fold-search t))
 538                         (string-match (cadr m) to)))
 539                      ((functionp (cadr m))
 540                       (funcall (cadr m)))
 541                      ((equal (cadr m) t))
 542                      (t
 543                       (eval (cadr m)))))
 544           (setq mail (car m)
 545                 mails-alist nil))
 546       (setq mails-alist (cdr mails-alist)))
 547     mail))
 548
 549 (defun vm-serial-auto-yank-mail (&optional mail no-expand)
 550   "Yank the mail associated with MAIL.
 551 If MAIL is nil search for a default mail, i.e. the first which evaluates its
 552 condition to true.  When called with a prefix argument or if NO-EXPAND is non
 553 nil no tokens will be expanded after yanking.
 554
 555 This is like `vm-serial-yank-mail', but it ensures to yank only if the buffer
 556 is no serial mail buffer and if there was no yank-mail before!"
 557   (if (and (not vm-serial-source-buffer)
 558            (not vm-redistribute-list)
 559            (not (local-variable-p 'vm-serial-body-contents (current-buffer)))
 560            (boundp 'vm-postponed-message-folder-buffer)
 561            (not vm-postponed-message-folder-buffer))
 562       (vm-serial-yank-mail (or mail (vm-serial-find-default-mail))
 563                            no-expand)))
 564
 565 (defvar vm-serial-yank-mail-choice nil)
 566 (make-variable-buffer-local 'vm-serial-yank-mail-choice)
 567
 568 (defun vm-serial-yank-mail (&optional mail no-expand)
 569   "Yank the template associated with MAIL.
 570
 571 If MAIL is nil search for a default template, i.e. the first one which
 572 evaluates its condition to true.  When called with a prefix argument ask for
 573 a template and with another prefix argument or if NO-EXPAND is non nil
 574 no tokens will be expanded after yanking.
 575
 576 You may bind this to [C-c C-t] in mail-mode in order to automatically yank
 577 the right mail into the composition buffer and move the cursor to the
 578 editing point.
 579
 580 I try to be clever when to delete the existing buffer contents and when to
 581 expand the tokens, however if this does not satisfy you please report it to
 582 me."
 583
 584   (interactive "p")
 585
 586   (if (numberp mail)
 587       (if (= mail 1)
 588           (setq mail nil)
 589         (setq no-expand (if (= mail 16) '(t))
 590               mail (completing-read
 591                     "Mail: "
 592                     (vm-serial-get-completing-list
 593                      vm-serial-mails-alist)
 594                     nil
 595                     t;; exact match
 596                     (cons (vm-serial-find-default-mail)
 597                           0)
 598                     vm-serial-mail-history)
 599               vm-serial-yank-mail-choice mail)))
 600
 601   (setq mail (or mail vm-serial-yank-mail-choice (vm-serial-find-default-mail)))
 602
 603   (let ((save-point (point)))
 604     (if (not mail)
 605         (message "There is no matching mail form!")
 606       (if (local-variable-p 'vm-serial-body-contents (current-buffer))
 607           (progn (delete-region (mail-text) (point-max))
 608                  (setq no-expand (if (and no-expand (listp no-expand))
 609                                      no-expand 'not))))
 610
 611       (if (or (interactive-p)
 612               (local-variable-p 'vm-serial-body-contents (current-buffer)))
 613           (message "Inserting serial mail `%S'." mail)
 614         (let ((start (mail-text)) (end (goto-char (point-max))))
 615           (make-local-variable 'vm-serial-body-contents)
 616           (make-local-variable 'vm-serial-to)
 617           (setq vm-serial-to nil
 618                 vm-serial-body-contents nil)
 619           (if (not (or vm-reply-list vm-forward-list))
 620               (setq no-expand (if (equal no-expand 'not) nil
 621                                 (if (and no-expand (listp no-expand))
 622                                     no-expand t)))
 623             (setq vm-serial-body-contents (buffer-substring start end))
 624             (delete-region start end))))
 625
 626       (let ((value (vm-serial-get-mail mail)))
 627       (save-excursion
 628         (insert value)))
 629
 630       (if (or (and (not vm-forward-list) (not no-expand))
 631               (equal no-expand 'not))
 632           (vm-serial-expand-tokens)
 633         (goto-char save-point)))))
 634
 635 ;;-----------------------------------------------------------------------------
 636 (defun vm-serial-random-string (string-list)
 637   "Randomly return one of the strings in STRING-LIST."
 638   (let ((value (nth (mod (random) (length string-list)) string-list)))
 639     (cond ((stringp value)
 640            value)
 641           ((functionp value)
 642            (funcall value))
 643           (t
 644            (eval value)))))
 645
 646 (defun vm-serial-expand-tokens (&optional rstart rend)
 647   "Expand all tokens within the current mail.
 648 This means we search for the `vm-serial-cookie' and if it is followed by a
 649 regexp of \"[a-zA-Z][a-zA-Z0-9_-]\" we treat this as a symbol to look up in
 650 our `vm-serial-token-alist'.  Optionally one may enclose the symbol by curly
 651 parenthesis.  See the test mail in `vm-serial-mails-alist' for examples.
 652 If the cookie is followed by a parenthesis then it is treated as a lisp
 653 expression which is evaluated
 654
 655 Results evaluating to a string are inserted all other return values are
 656 ignored.  For non existing tokens or errors during evaluation one will get
 657 a warning."
 658   (interactive)
 659
 660   (let ((token-regexp (concat (regexp-quote vm-serial-cookie)
 661                        "\\(" (regexp-quote vm-serial-cookie) "\\)*"
 662                        "[{\(a-zA-Z]"))
 663         start end expr result vm-serial-point)
 664     (if (and vm-xemacs-p
 665              (region-exists-p)
 666              (eq (zmacs-region-buffer) (current-buffer)))
 667         (setq rstart (goto-char (region-beginning)) rend (region-end))
 668       (setq rstart (mail-text) rend (point-max)))
 669
 670     (narrow-to-region rstart rend)
 671     (while (re-search-forward token-regexp (point-max) t)
 672       (backward-char 1)
 673       (setq start (- (match-end 0) 1)
 674             result nil)
 675       (cond ((> (length (match-string 1)) 0)
 676              (delete-region (match-beginning 1) (match-end 1)))
 677             ((looking-at "(")
 678              (setq end (scan-sexps start 1))
 679              (goto-char start)
 680              (setq expr (read (current-buffer)))
 681              (delete-region (- start 1) end)
 682              (setq result (vm-serial-eval-token-value expr)))
 683             ((looking-at "\\({\\)?\\([a-zA-Z][a-zA-Z0-9_-]*\\)\\(}\\)?")
 684              (setq start (match-beginning 2))
 685              (setq end (match-end 2))
 686              (setq expr (buffer-substring start end))
 687              (if (and (not (and (match-end 1) (match-end 3)))
 688                       (or (match-end 1) (match-end 3)))
 689                  (error "Invalid token expression `%s'"
 690                         (match-string 0)))
 691              (delete-region (- (match-beginning 0) 1) (match-end 0))
 692              (setq result (vm-serial-eval-token-value
 693                            (vm-serial-get-token expr))))
 694             )
 695       (if (and result (stringp result))
 696           (insert (format "%s" result))))
 697     (widen)
 698     (if vm-serial-point
 699         (goto-char vm-serial-point))))
 700
 701 (defvar vm-serial-insert-token-history nil)
 702
 703 (defun vm-serial-insert-token (token)
 704   "Reads a valid token, inserts it at point and expands it."
 705   (interactive (list
 706                 (completing-read
 707                  (format "Token%s: "
 708                          (if vm-serial-insert-token-history
 709                              (concat " (default: "
 710                                      (car vm-serial-insert-token-history)
 711                                      ")")
 712                            ""))
 713                  (mapcar (lambda (tok) (list (car tok)))
 714                          vm-serial-token-alist)
 715                  nil
 716                  t
 717                  nil
 718                  'vm-serial-insert-token-history)))
 719   (setq vm-serial-insert-token-history
 720         (delete "" vm-serial-insert-token-history))
 721   (if (string= "" token)
 722       (setq token (car vm-serial-insert-token-history)))
 723   (if (null token)
 724       (error "Error: you have to enter a toke name!"))
 725   (let ((start (point)))
 726     (insert vm-serial-cookie token)
 727     (vm-serial-expand-tokens start (point))))
 728
 729 ;;-----------------------------------------------------------------------------
 730 (defvar vm-serial-sent-cnt nil)
 731 (defvar vm-serial-edited-cnt nil)
 732 (defvar vm-serial-killed-cnt nil)
 733 (defvar vm-serial-send-mail-exit nil)
 734
 735 (defun vm-serial-send-mail-increment (variable)
 736   (save-excursion
 737     (set-buffer vm-serial-source-buffer)
 738     (eval (list 'vm-increment variable))))
 739
 740
 741 (defun vm-serial-send-mail-and-exit (&optional non-interactive)
 742   "Like `vm-serial-send-mail' but kills the buffer after sending all."
 743   (interactive "P")
 744   (make-local-variable 'vm-serial-send-mail-exit)
 745   (setq vm-serial-send-mail-exit t)
 746   (vm-serial-send-mail non-interactive))
 747
 748 (defun vm-serial-send-mail (&optional non-interactive done)
 749   "Send an expanded mail to each recipient listed in the To-header.
 750 This will create a new buffer for expanding the tokens and user interaction.
 751 You may send each mail interactively, that means you may send the message as
 752 it is, or you may edit it before sending or you may skip it.
 753
 754 If called with a prefix argument or NON-INTERACTIVE set to non nil, no
 755 questions will bother you!"
 756   (interactive "P")
 757
 758   (remove-hook 'kill-buffer-hook 'vm-serial-send-mail t)
 759
 760   (if vm-serial-source-buffer
 761       (progn (set-buffer vm-serial-source-buffer)
 762              (setq done t)))
 763
 764   (if (get-buffer vm-serial-send-mail-buffer)
 765       (save-excursion
 766         (kill-buffer (get-buffer vm-serial-send-mail-buffer))))
 767
 768   (let* ((work-buffer
 769           (save-excursion
 770             (let ((vm-frame-per-composition nil))
 771               (flet ((vm-display (buffer display commands configs
 772                                          &optional do-not-raise)
 773                                  nil))
 774                 (vm-mail-internal vm-serial-send-mail-buffer))
 775               (get-buffer vm-serial-send-mail-buffer))))
 776          (source-buffer (current-buffer))
 777          work to to-string)
 778
 779     (if (and (not vm-serial-send-mail-jobs) (not done))
 780         (if (not (setq to (mail-fetch-field "To" nil t)))
 781             (error "There are no recipients in %s!" (buffer-name))
 782           (setq vm-serial-send-mail-jobs
 783                 (if (functionp 'bbdb-extract-address-components)
 784                     (bbdb-extract-address-components to)
 785                   (mapcar 'mail-extract-address-components
 786                           (bbdb-split to ","))))
 787           (make-local-variable 'vm-serial-sent-cnt)
 788           (make-local-variable 'vm-serial-edited-cnt)
 789           (make-local-variable 'vm-serial-killed-cnt)
 790           (setq vm-serial-sent-cnt 0
 791                 vm-serial-edited-cnt 0
 792                 vm-serial-killed-cnt 0)))
 793
 794     ;; mail-extract-address-components isn't good at all! Fix it!
 795     (save-excursion
 796       (set-buffer work-buffer)
 797       (setq major-mode 'mail-mode))
 798
 799     (while (and (not work) vm-serial-send-mail-jobs)
 800       (setq to (car vm-serial-send-mail-jobs)
 801             to-string (if (car to)
 802                           (concat (car to) " <" (cadr to) ">")
 803                         (cadr to)))
 804       (copy-to-buffer work-buffer (point-min) (point-max))
 805       (save-excursion
 806         (set-buffer work-buffer)
 807         (goto-char (point-min))
 808         (vm-mail-mode-remove-header "To:")
 809         (mail-position-on-field "To")
 810         (insert to-string)
 811         (if (not vm-serial-fcc)
 812             (vm-mail-mode-remove-header "FCC:"))
 813         (setq vm-serial-to to
 814               vm-serial-source-buffer source-buffer)
 815         (setq buffer-undo-list t)
 816         (vm-serial-expand-tokens)
 817
 818         (if (not non-interactive)
 819             (let (command)
 820               (switch-to-buffer work-buffer)
 821               (while (not command)
 822                 (message "(q)uit session or (e)dit, (s)end or (k)ill this mail to `%s'?"
 823                          to)
 824                 (setq command (read-char-exclusive))
 825                 (cond ((= command ?e)
 826                        (vm-serial-send-mail-increment 'vm-serial-edited-cnt)
 827                        (setq work 'edit))
 828                       ((= command ?s)
 829                        (vm-serial-send-mail-increment 'vm-serial-sent-cnt)
 830                        (vm-mail-send))
 831                       ((= command ?k)
 832                        (vm-serial-send-mail-increment 'vm-serial-killed-cnt))
 833                       ((= command ?q)
 834                        (setq work 'quit))
 835                       (t (message "Invalid command!")
 836                          (sit-for 1)
 837                          (setq command nil)))))
 838           (vm-mail-send)
 839           (vm-serial-send-mail-increment 'vm-serial-sent-cnt)))
 840
 841       (setq vm-serial-send-mail-jobs (cdr vm-serial-send-mail-jobs)))
 842
 843     ;; ok there was an exit or the like
 844     (if (equal work 'edit)
 845         (progn ;; and we want to edit the outgoing mail before sending
 846           (switch-to-buffer work-buffer)
 847           (run-hooks 'vm-mail-hook)
 848           (run-hooks 'vm-mail-mode-hook)
 849           (setq buffer-undo-list nil)
 850           (make-local-hook 'kill-buffer-hook)
 851           (add-hook 'kill-buffer-hook
 852                     '(lambda ()
 853                        (vm-serial-send-mail-increment 'vm-serial-killed-cnt))
 854                     t t)
 855           (add-hook 'kill-buffer-hook 'vm-serial-send-mail t t)
 856           (make-local-hook 'mail-send-hook)
 857           (add-hook 'mail-send-hook
 858                     '(lambda ()
 859                        (vm-serial-send-mail-increment 'vm-serial-sent-cnt))
 860                     t t)
 861           (remove-hook 'kill-buffer-hook 'vm-save-killed-message-hook t)
 862           (message "Kill or send this mail to get to the next mail!"))
 863
 864       ;; get rid of the work buffer and go back to the source
 865       (kill-buffer work-buffer)
 866       (switch-to-buffer source-buffer)
 867
 868       (if (not (equal work 'quit))
 869           (let ((fcc (vm-mail-mode-get-header-contents "FCC:")))
 870             ;; some statistics
 871             (message "%s mail%s sent, %s edited and %s killed by vm-serial!"
 872                      (if (= vm-serial-sent-cnt 1) "One" vm-serial-sent-cnt)
 873                      (if (= vm-serial-sent-cnt 1) "" "s")
 874                      vm-serial-edited-cnt vm-serial-killed-cnt)
 875
 876             ;; this was the last mail so is there some FCC work to do?
 877             (if (and fcc (not vm-serial-send-mail-jobs))
 878                 (if (not (functionp 'vm-postpone-message))
 879                     (error "vm-pine.el is needed to save source messages!")
 880                   ;; no postponed header for this!!
 881                   (vm-mail-mode-remove-header "FCC:")
 882                   (vm-postpone-message fcc vm-serial-send-mail-exit t))
 883               (if vm-serial-send-mail-exit
 884                   (kill-this-buffer))))))))
 885
 886 (defadvice vm-mail-send-and-exit (after vm-serial-send-mail activate)
 887   (if vm-serial-source-buffer
 888       (kill-this-buffer)))
 889
 890 ;;-----------------------------------------------------------------------------
 891 (provide 'vm-serial)
 892
 893 ;;; vm-serial.el ends here