diff options
Diffstat (limited to 'lisp/mail/mailheader.el')
| -rw-r--r-- | lisp/mail/mailheader.el | 182 |
1 files changed, 182 insertions, 0 deletions
diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el new file mode 100644 index 00000000000..fa0265faf41 --- /dev/null +++ b/lisp/mail/mailheader.el @@ -0,0 +1,182 @@ +;;; mail-header.el --- Mail header parsing, merging, formatting + +;; Copyright (C) 1996 by Free Software Foundation, Inc. + +;; Author: Erik Naggum <erik@arcana.naggum.no> +;; Keywords: tools, mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package provides an abstraction to RFC822-style messages, used in +;; mail news, and some other systems. The simple syntactic rules for such +;; headers, such as quoting and line folding, are routinely reimplemented +;; in many individual packages. This package removes the need for this +;; redundancy by representing message headers as association lists, +;; offering functions to extract the set of headers from a message, to +;; parse individual headers, to merge sets of headers, and to format a set +;; of headers. + +;; The car of each element in the message-header alist is a symbol whose +;; print name is the name of the header, in all lower-case. The cdr of an +;; element depends on the operation. After extracting headers from a +;; messge, it is a string, the value of the header. An extracted set of +;; headers may be parsed further, which may turn it into a list, whose car +;; is the original value and whose subsequent elements depend on the +;; header. For formatting, it is evaluated to obtain the strings to be +;; inserted. For merging, one set of headers consists of strings, while +;; the other set will be evaluated with the symbols in the first set of +;; headers bound to their respective values. + +;;; Code: + +(require 'cl) + +;; Make the byte-compiler shut up. +(defvar headers) + +(defun mail-header-extract () + "Extract headers from current buffer after point. +Returns a header alist, where each element is a cons cell (name . value), +where NAME is a symbol, and VALUE is the string value of the header having +that name." + (let ((message-headers ()) (top (point)) + start end) + (while (and (setq start (point)) + (> (skip-chars-forward "^\0- :") 0) + (= (following-char) ?:) + (setq end (point)) + (progn (forward-char) + (> (skip-chars-forward " \t") 0))) + (let ((header (intern (downcase (buffer-substring start end)))) + (value (list (buffer-substring + (point) (progn (end-of-line) (point)))))) + (while (progn (forward-char) (> (skip-chars-forward " \t") 0)) + (push (buffer-substring (point) (progn (end-of-line) (point))) + value)) + (push (if (cdr value) + (cons header (mapconcat #'identity (nreverse value) " ")) + (cons header (car value))) + message-headers))) + (goto-char top) + (nreverse message-headers))) + +(defun mail-header-extract-no-properties () + "Extract headers from current buffer after point, without properties. +Returns a header alist, where each element is a cons cell (name . value), +where NAME is a symbol, and VALUE is the string value of the header having +that name." + (mapcar + (lambda (elt) + (set-text-properties 0 (length (cdr elt)) nil (cdr elt)) + elt) + (mail-header-extract))) + +(defun mail-header-parse (parsing-rules headers) + "Apply PARSING-RULES to HEADERS. +PARSING-RULES is an alist whose keys are header names (symbols) and whose +value is a parsing function. The function takes one argument, a string, +and return a list of values, which will destructively replace the value +associated with the key in HEADERS, after being prepended with the original +value." + (dolist (rule parsing-rules) + (let ((header (assq (car rule) headers))) + (when header + (if (consp (cdr header)) + (setf (cddr header) (funcall (cdr rule) (cadr header))) + (setf (cdr header) + (cons (cdr header) (funcall (cdr rule) (cdr header)))))))) + headers) + +(defsubst mail-header (header &optional header-alist) + "Return the value associated with header HEADER in HEADER-ALIST. +If the value is a string, it is the original value of the header. If the +value is a list, its first element is the original value of the header, +with any subsequent elements bing the result of parsing the value. +If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." + (cdr (assq header (or header-alist headers)))) + +(defun mail-header-set (header value &optional header-alist) + "Set the value associated with header HEADER to VALUE in HEADER-ALIST. +HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. +See `mail-header' for the semantics of VALUE." + (let* ((alist (or header-alist headers)) + (entry (assq header alist))) + (if entry + (setf (cdr entry) value) + (nconc alist (list (cons header value))))) + value) + +(defsetf mail-header (header &optional header-alist) (value) + `(mail-header-set ,header ,value ,header-alist)) + +(defun mail-header-merge (merge-rules headers) + "Return a new header alist with MERGE-RULES applied to HEADERS. +MERGE-RULES is an alist whose keys are header names (symbols) and whose +values are forms to evaluate, the results of which are the new headers. It +should be a string or a list of string. The first element may be nil to +denote that the formatting functions must use the remaining elements, or +skip the header altogether if there are no other elements. + The macro `mail-header' can be used to access headers in HEADERS." + (mapcar + (lambda (rule) + (cons (car rule) (eval (cdr rule)))) + merge-rules)) + +(defvar mail-header-format-function + (lambda (header value) + "Function to format headers without a specified formatting function." + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n"))) + +(defun mail-header-format (format-rules headers) + "Use FORMAT-RULES to format HEADERS and insert into current buffer. +FORMAT-RULES is an alist whose keys are header names (symbols), and whose +values are functions that format the header, the results of which are +inserted, unless it is nil. The function takes two arguments, the header +symbol, and the value of that header. If the function itself is nil, the +default action is to insert the value of the header, unless it is nil. +The headers are inserted in the order of the FORMAT-RULES. +A key of t represents any otherwise unmentioned headers. +A key of nil has as its value a list of defaulted headers to ignore." + (let ((ignore (append (cdr (assq nil format-rules)) + (mapcar #'car format-rules)))) + (dolist (rule format-rules) + (let* ((header (car rule)) + (value (mail-header header))) + (cond ((null header) 'ignore) + ((eq header t) + (dolist (defaulted headers) + (unless (memq (car defaulted) ignore) + (let* ((header (car defaulted)) + (value (cdr defaulted))) + (if (cdr rule) + (funcall (cdr rule) header value) + (funcall mail-header-format-function header value)))))) + (value + (if (cdr rule) + (funcall (cdr rule) header value) + (funcall mail-header-format-function header value)))))) + (insert "\n"))) + +(provide 'mailheader) + +;;; mail-header.el ends here |