Mercurial > hg > xemacs-beta

comparison lisp/gnus/mailheader.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 131b0175ea99
children 360340f9fd5f
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
34 ;; of headers. 34 ;; of headers.
35 35
36 ;; The car of each element in the message-header alist is a symbol whose 36 ;; The car of each element in the message-header alist is a symbol whose
37 ;; print name is the name of the header, in all lower-case. The cdr of an 37 ;; print name is the name of the header, in all lower-case. The cdr of an
38 ;; element depends on the operation. After extracting headers from a 38 ;; element depends on the operation. After extracting headers from a
39 ;; messge, it is a string, the value of the header. An extracted set of 39 ;; message, it is a string, the value of the header. An extracted set of
40 ;; headers may be parsed further, which may turn it into a list, whose car 40 ;; headers may be parsed further, which may turn it into a list, whose car
41 ;; is the original value and whose subsequent elements depend on the 41 ;; is the original value and whose subsequent elements depend on the
42 ;; header. For formatting, it is evaluated to obtain the strings to be 42 ;; header. For formatting, it is evaluated to obtain the strings to be
43 ;; inserted. For merging, one set of headers consists of strings, while 43 ;; inserted. For merging, one set of headers consists of strings, while
44 ;; the other set will be evaluated with the symbols in the first set of 44 ;; the other set will be evaluated with the symbols in the first set of
70 (while (progn (forward-char) (> (skip-chars-forward " \t") 0)) 70 (while (progn (forward-char) (> (skip-chars-forward " \t") 0))
71 (push (buffer-substring (point) (progn (end-of-line) (point))) 71 (push (buffer-substring (point) (progn (end-of-line) (point)))
72 value)) 72 value))
73 (push (if (cdr value) 73 (push (if (cdr value)
74 (cons header (mapconcat #'identity (nreverse value) " ")) 74 (cons header (mapconcat #'identity (nreverse value) " "))
75 (cons header (car value))) 75 (cons header (car value)))
76 message-headers))) 76 message-headers)))
77 (goto-char top) 77 (goto-char top)
78 (nreverse message-headers))) 78 (nreverse message-headers)))
79 79
80 (defun mail-header-extract-no-properties () 80 (defun mail-header-extract-no-properties ()
106 106
107 (defsubst mail-header (header &optional header-alist) 107 (defsubst mail-header (header &optional header-alist)
108 "Return the value associated with header HEADER in HEADER-ALIST. 108 "Return the value associated with header HEADER in HEADER-ALIST.
109 If the value is a string, it is the original value of the header. If the 109 If the value is a string, it is the original value of the header. If the
110 value is a list, its first element is the original value of the header, 110 value is a list, its first element is the original value of the header,
111 with any subsequent elements bing the result of parsing the value. 111 with any subsequent elements being the result of parsing the value.
112 If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." 112 If HEADER-ALIST is nil, the dynamically bound variable `headers' is used."
113 (cdr (assq header (or header-alist headers)))) 113 (cdr (assq header (or header-alist headers))))
114 114
115 (defun mail-header-set (header value &optional header-alist) 115 (defun mail-header-set (header value &optional header-alist)
116 "Set the value associated with header HEADER to VALUE in HEADER-ALIST. 116 "Set the value associated with header HEADER to VALUE in HEADER-ALIST.
117 HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. 117 HEADER-ALIST defaults to the dynamically bound variable `headers' if nil.
118 See `mail-header' for the semantics of VALUE." 118 See `mail-header' for the semantics of VALUE."
119 (let* ((alist (or header-alist headers)) 119 (let* ((alist (or header-alist headers))
120 (entry (assq header alist))) 120 (entry (assq header alist)))
121 (if entry 121 (if entry
122 (setf (cdr entry) value) 122 (setf (cdr entry) value)
123 (nconc alist (list (cons header value))))) 123 (nconc alist (list (cons header value)))))
124 value) 124 value)
125 125
126 (defsetf mail-header (header &optional header-alist) (value) 126 (defsetf mail-header (header &optional header-alist) (value)
127 `(mail-header-set ,header ,value ,header-alist)) 127 `(mail-header-set ,header ,value ,header-alist))
128 128
159 A key of nil has as its value a list of defaulted headers to ignore." 159 A key of nil has as its value a list of defaulted headers to ignore."
160 (let ((ignore (append (cdr (assq nil format-rules)) 160 (let ((ignore (append (cdr (assq nil format-rules))
161 (mapcar #'car format-rules)))) 161 (mapcar #'car format-rules))))
162 (dolist (rule format-rules) 162 (dolist (rule format-rules)
163 (let* ((header (car rule)) 163 (let* ((header (car rule))
164 (value (mail-header header))) 164 (value (mail-header header)))
165 (cond ((null header) 'ignore) 165 (cond ((null header) 'ignore)
166 ((eq header t) 166 ((eq header t)
167 (dolist (defaulted headers) 167 (dolist (defaulted headers)
168 (unless (memq (car defaulted) ignore) 168 (unless (memq (car defaulted) ignore)
169 (let* ((header (car defaulted)) 169 (let* ((header (car defaulted))
170 (value (cdr defaulted))) 170 (value (cdr defaulted)))
171 (if (cdr rule) 171 (if (cdr rule)
172 (funcall (cdr rule) header value) 172 (funcall (cdr rule) header value)
173 (funcall mail-header-format-function header value)))))) 173 (funcall mail-header-format-function header value))))))
174 (value 174 (value
175 (if (cdr rule) 175 (if (cdr rule)
176 (funcall (cdr rule) header value) 176 (funcall (cdr rule) header value)
177 (funcall mail-header-format-function header value)))))) 177 (funcall mail-header-format-function header value))))))
178 (insert "\n"))) 178 (insert "\n")))
179 179
180 (provide 'mailheader) 180 (provide 'mailheader)
181 181
182 ;;; mail-header.el ends here 182 ;;; mail-header.el ends here