Initial revision

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