Mercurial > hg > xemacs-beta

comparison lisp/mu/std11.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; std11.el --- STD 11 functions for GNU Emacs
2
3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Keywords: mail, news, RFC 822, STD 11
7 ;; Version: $Id: std11.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $
8
9 ;; This file is part of MU (Message Utilities).
10
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
15
16 ;; This program is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Code:
27
28 (autoload 'buffer-substring-no-properties "emu")
29 (autoload 'member "emu")
30
31
32 ;;; @ field
33 ;;;
34
35 (defconst std11-field-name-regexp "[!-9;-~]+")
36 (defconst std11-field-head-regexp
37 (concat "^" std11-field-name-regexp ":"))
38 (defconst std11-next-field-head-regexp
39 (concat "\n" std11-field-name-regexp ":"))
40
41 (defun std11-field-end ()
42 "Move to end of field and return this point. [std11.el]"
43 (if (re-search-forward std11-next-field-head-regexp nil t)
44 (goto-char (match-beginning 0))
45 (if (re-search-forward "^$" nil t)
46 (goto-char (1- (match-beginning 0)))
47 (end-of-line)
48 ))
49 (point)
50 )
51
52 (defun std11-field-body (name &optional boundary)
53 "Return body of field NAME.
54 If BOUNDARY is not nil, it is used as message header separator.
55 \[std11.el]"
56 (save-excursion
57 (save-restriction
58 (std11-narrow-to-header boundary)
59 (goto-char (point-min))
60 (let ((case-fold-search t))
61 (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
62 (buffer-substring-no-properties (match-end 0) (std11-field-end))
63 )))))
64
65 (defun std11-find-field-body (field-names &optional boundary)
66 "Return the first found field-body specified by FIELD-NAMES
67 of the message header in current buffer. If BOUNDARY is not nil, it is
68 used as message header separator. [std11.el]"
69 (save-excursion
70 (save-restriction
71 (std11-narrow-to-header boundary)
72 (let ((case-fold-search t)
73 field-name)
74 (catch 'tag
75 (while (setq field-name (car field-names))
76 (goto-char (point-min))
77 (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
78 (throw 'tag
79 (buffer-substring-no-properties
80 (match-end 0) (std11-field-end)))
81 )
82 (setq field-names (cdr field-names))
83 ))))))
84
85 (defun std11-field-bodies (field-names &optional default-value boundary)
86 "Return list of each field-bodies of FIELD-NAMES of the message header
87 in current buffer. If BOUNDARY is not nil, it is used as message
88 header separator. [std11.el]"
89 (save-excursion
90 (save-restriction
91 (std11-narrow-to-header boundary)
92 (let* ((case-fold-search t)
93 (dest (make-list (length field-names) default-value))
94 (s-rest field-names)
95 (d-rest dest)
96 field-name)
97 (while (setq field-name (car s-rest))
98 (goto-char (point-min))
99 (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
100 (setcar d-rest
101 (buffer-substring-no-properties
102 (match-end 0) (std11-field-end)))
103 )
104 (setq s-rest (cdr s-rest)
105 d-rest (cdr d-rest))
106 )
107 dest))))
108
109
110 ;;; @ unfolding
111 ;;;
112
113 (defun std11-unfold-string (string)
114 "Unfold STRING as message header field. [std11.el]"
115 (let ((dest ""))
116 (while (string-match "\n\\([ \t]\\)" string)
117 (setq dest (concat dest
118 (substring string 0 (match-beginning 0))
119 (match-string 1 string)
120 ))
121 (setq string (substring string (match-end 0)))
122 )
123 (concat dest string)
124 ))
125
126
127 ;;; @ header
128 ;;;
129
130 (defun std11-narrow-to-header (&optional boundary)
131 "Narrow to the message header.
132 If BOUNDARY is not nil, it is used as message header separator.
133 \[std11.el]"
134 (narrow-to-region
135 (goto-char (point-min))
136 (if (re-search-forward
137 (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$")
138 nil t)
139 (match-beginning 0)
140 (point-max)
141 )))
142
143 (defun std11-header-string (regexp &optional boundary)
144 "Return string of message header fields matched by REGEXP.
145 If BOUNDARY is not nil, it is used as message header separator.
146 \[std11.el]"
147 (let ((case-fold-search t))
148 (save-excursion
149 (save-restriction
150 (std11-narrow-to-header boundary)
151 (goto-char (point-min))
152 (let (field header)
153 (while (re-search-forward std11-field-head-regexp nil t)
154 (setq field
155 (buffer-substring (match-beginning 0) (std11-field-end)))
156 (if (string-match regexp field)
157 (setq header (concat header field "\n"))
158 ))
159 header)
160 ))))
161
162 (defun std11-header-string-except (regexp &optional boundary)
163 "Return string of message header fields not matched by REGEXP.
164 If BOUNDARY is not nil, it is used as message header separator.
165 \[std11.el]"
166 (let ((case-fold-search t))
167 (save-excursion
168 (save-restriction
169 (std11-narrow-to-header boundary)
170 (goto-char (point-min))
171 (let (field header)
172 (while (re-search-forward std11-field-head-regexp nil t)
173 (setq field
174 (buffer-substring (match-beginning 0) (std11-field-end)))
175 (if (not (string-match regexp field))
176 (setq header (concat header field "\n"))
177 ))
178 header)
179 ))))
180
181 (defun std11-collect-field-names (&optional boundary)
182 "Return list of all field-names of the message header in current buffer.
183 If BOUNDARY is not nil, it is used as message header separator.
184 \[std11.el]"
185 (save-excursion
186 (save-restriction
187 (std11-narrow-to-header boundary)
188 (goto-char (point-min))
189 (let (dest name)
190 (while (re-search-forward std11-field-head-regexp nil t)
191 (setq name (buffer-substring-no-properties
192 (match-beginning 0)(1- (match-end 0))))
193 (or (member name dest)
194 (setq dest (cons name dest))
195 )
196 )
197 dest))))
198
199
200 ;;; @ quoted-string
201 ;;;
202
203 (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
204
205 (defun std11-wrap-as-quoted-string (string)
206 "Wrap STRING as RFC 822 quoted-string. [std11.el]"
207 (concat "\""
208 (mapconcat (function
209 (lambda (chr)
210 (if (memq chr std11-non-qtext-char-list)
211 (concat "\\" (char-to-string chr))
212 (char-to-string chr)
213 )
214 )) string "")
215 "\""))
216
217 (defun std11-strip-quoted-pair (str)
218 (let ((dest "")
219 (i 0)
220 (len (length str))
221 chr flag)
222 (while (< i len)
223 (setq chr (aref str i))
224 (if (or flag (not (eq chr ?\\)))
225 (progn
226 (setq dest (concat dest (char-to-string chr)))
227 (setq flag nil)
228 )
229 (setq flag t)
230 )
231 (setq i (+ i 1))
232 )
233 dest))
234
235 (defun std11-strip-quoted-string (string)
236 "Strip quoted-string STRING. [std11.el]"
237 (let ((len (length string)))
238 (or (and (>= len 2)
239 (let ((max (1- len)))
240 (and (eq (aref string 0) ?\")
241 (eq (aref string max) ?\")
242 (std11-strip-quoted-pair (substring string 1 max))
243 )))
244 string)))
245
246
247 ;;; @ composer
248 ;;;
249
250 (defun std11-addr-to-string (seq)
251 "Return string from lexical analyzed list SEQ
252 represents addr-spec of RFC 822. [std11.el]"
253 (mapconcat (function
254 (lambda (token)
255 (if (let ((name (car token)))
256 (or (eq name 'spaces)
257 (eq name 'comment)
258 ))
259 ""
260 (cdr token)
261 )))
262 seq "")
263 )
264
265 (defun std11-address-string (address)
266 "Return string of address part from parsed ADDRESS of RFC 822.
267 \[std11.el]"
268 (cond ((eq (car address) 'group)
269 (mapconcat (function std11-address-string)
270 (car (cdr address))
271 ", ")
272 )
273 ((eq (car address) 'mailbox)
274 (let ((addr (nth 1 address)))
275 (std11-addr-to-string
276 (if (eq (car addr) 'phrase-route-addr)
277 (nth 2 addr)
278 (cdr addr)
279 )
280 )))))
281
282 (defun std11-full-name-string (address)
283 "Return string of full-name part from parsed ADDRESS of RFC 822.
284 \[std11.el]"
285 (cond ((eq (car address) 'group)
286 (mapconcat (function
287 (lambda (token)
288 (cdr token)
289 ))
290 (nth 1 address) "")
291 )
292 ((eq (car address) 'mailbox)
293 (let ((addr (nth 1 address))
294 (comment (nth 2 address))
295 phrase)
296 (if (eq (car addr) 'phrase-route-addr)
297 (setq phrase (mapconcat (function
298 (lambda (token)
299 (cdr token)
300 ))
301 (nth 1 addr) ""))
302 )
303 (or phrase comment)
304 ))))
305
306
307 ;;; @ parser
308 ;;;
309
310 (defun std11-parse-address-string (string)
311 "Parse STRING as mail address. [std11.el]"
312 (std11-parse-address (std11-lexical-analyze string))
313 )
314
315 (defun std11-parse-addresses-string (string)
316 "Parse STRING as mail address list. [std11.el]"
317 (std11-parse-addresses (std11-lexical-analyze string))
318 )
319
320 (defun std11-extract-address-components (string)
321 "Extract full name and canonical address from STRING.
322 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
323 If no name can be extracted, FULL-NAME will be nil. [std11.el]"
324 (let* ((structure (car (std11-parse-address-string
325 (std11-unfold-string string))))
326 (phrase (std11-full-name-string structure))
327 (address (std11-address-string structure))
328 )
329 (list phrase address)
330 ))
331
332 (provide 'std11)
333
334 (mapcar (function
335 (lambda (func)
336 (autoload func "std11-parse")
337 ))
338 '(std11-lexical-analyze
339 std11-parse-address std11-parse-addresses
340 std11-parse-address-string))
341
342
343 ;;; @ end
344 ;;;
345
346 ;;; std11.el ends here