home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / functions / mail-add-header.el < prev    next >
Encoding:
Text File  |  1991-07-07  |  2.1 KB  |  55 lines
  1. ; Newsgroups: dg.ml.emacs.vm
  2. ; Path: dg-rtp!uunet!uunet!elroy.jpl.nasa.gov!decwrl!waikato.ac.nz!aukuni.ac.nz!mike-w
  3. ; From: mike-w@cs.aukuni.ac.nz (Mike Williams)
  4. ; Subject: Re: Correcting/Augmenting Mail Headers (was: User setting From: address in sendmail input)
  5. ; Organization: University of Auckland, New Zealand.
  6. ; Date: 3 Jul 91 09:26:27
  7. ; 
  8. ;   Here's a couple of elisp functions which facilitate adding and removing
  9. ;   mail (or news) headers.  Just stick the appropriate calls in your
  10. ;   mail-setup-hook, eg.
  11. ; 
  12. ;     | (setq mail-setup-hook 'my-mail-setup-hook)
  13. ;     | 
  14. ;     | (defun my-mail-setup-hook ()
  15. ;     |   (mail-add-header "Return-Receipt-To" my-email-address)
  16. ;     |   (mail-add-header "Reply-To" my-email-address 'replace)
  17. ;     |   )
  18. ; 
  19. ; --- Shnip 'ere ------------------------------------------------------------
  20. ; 
  21. (require 'mail-utils)
  22.  
  23. ;; LCD Archive Entry:
  24. ;; mail-add-header|Mike Williams|mike-w@cs.aukuni.ac.nz
  25. ;; |Functions to add and remove named mail headers
  26. ;; |91-07-03||~/functions/mail-add-header.el.Z
  27.  
  28. (defun mail-add-header (HEADER CONTENTS &optional REPLACE)
  29.   "Add the specified HEADER to the current mail message, with the given 
  30. CONTENTS.  
  31. If the header already exists, the contents are left unchanged, unless optional 
  32. argument REPLACE is non-nil."
  33.   (save-excursion
  34.     (let ((header-exists (mail-position-on-field HEADER)))
  35.       ;; Delete old contents if REPLACE is set
  36.       (if (and header-exists REPLACE)
  37.       (let ((end (point))
  38.         (beg (progn
  39.                (re-search-backward (concat HEADER ": "))
  40.                (goto-char (match-end 0)))))
  41.         (delete-region beg end)))
  42.       ;; Add new contents if REPLACE is set, or this is a new header.
  43.       (if (or (not header-exists) REPLACE)
  44.       (progn (insert CONTENTS) CONTENTS)))))
  45.  
  46. (defun mail-remove-header (HEADER)
  47.   "Remove the specified HEADER from the current mail message."
  48.   (save-excursion
  49.     (if (mail-position-on-field HEADER 'soft)
  50.     (let ((end (point))
  51.           (beg (progn
  52.              (re-search-backward (concat HEADER ": "))
  53.              (goto-char (match-beginning 0)))))
  54.       (delete-region beg (1+ end))))))
  55.