Mercurial > emacs
comparison lisp/mail/mail-utils.el @ 36:9697c13298e5
Initial revision
author | Joseph Arceneaux <jla@gnu.org> |
---|---|
date | Tue, 31 Oct 1989 16:00:07 +0000 |
parents | |
children | 2ea306376f97 |
comparison
equal
deleted
inserted
replaced
35:63b375f17a65 | 36:9697c13298e5 |
---|---|
1 ;; Utility functions used both by rmail and rnews | |
2 ;; Copyright (C) 1985 Free Software Foundation, Inc. | |
3 | |
4 ;; This file is part of GNU Emacs. | |
5 | |
6 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
7 ;; it under the terms of the GNU General Public License as published by | |
8 ;; the Free Software Foundation; either version 1, or (at your option) | |
9 ;; any later version. | |
10 | |
11 ;; GNU Emacs is distributed in the hope that it will be useful, | |
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 ;; GNU General Public License for more details. | |
15 | |
16 ;; You should have received a copy of the GNU General Public License | |
17 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
18 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
19 | |
20 | |
21 (provide 'mail-utils) | |
22 | |
23 ;; should be in loaddefs | |
24 (defvar mail-use-rfc822 nil | |
25 "*If non-nil, use a full, hairy RFC822 parser on mail addresses. | |
26 Otherwise, (the default) use a smaller, somewhat faster and | |
27 often-correct parser.") | |
28 | |
29 (defun mail-string-delete (string start end) | |
30 "Returns a string containing all of STRING except the part | |
31 from START (inclusive) to END (exclusive)." | |
32 (if (null end) (substring string 0 start) | |
33 (concat (substring string 0 start) | |
34 (substring string end nil)))) | |
35 | |
36 (defun mail-strip-quoted-names (address) | |
37 "Delete comments and quoted strings in an address list ADDRESS. | |
38 Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR. | |
39 Return a modified address list." | |
40 (if mail-use-rfc822 | |
41 (progn (require 'rfc822) | |
42 (mapconcat 'identity (rfc822-addresses address) ", ")) | |
43 (let (pos) | |
44 (string-match "\\`[ \t\n]*" address) | |
45 ;; strip surrounding whitespace | |
46 (setq address (substring address | |
47 (match-end 0) | |
48 (string-match "[ \t\n]*\\'" address | |
49 (match-end 0)))) | |
50 | |
51 ;; Detect nested comments. | |
52 (if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address) | |
53 ;; Strip nested comments. | |
54 (save-excursion | |
55 (set-buffer (get-buffer-create " *temp*")) | |
56 (erase-buffer) | |
57 (insert address) | |
58 (set-syntax-table lisp-mode-syntax-table) | |
59 (goto-char 1) | |
60 (while (search-forward "(" nil t) | |
61 (forward-char -1) | |
62 (skip-chars-backward " \t") | |
63 (delete-region (point) | |
64 (save-excursion (forward-sexp 1) (point)))) | |
65 (setq address (buffer-string)) | |
66 (erase-buffer)) | |
67 ;; Strip non-nested comments an easier way. | |
68 (while (setq pos (string-match | |
69 ;; This doesn't hack rfc822 nested comments | |
70 ;; `(xyzzy (foo) whinge)' properly. Big deal. | |
71 "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)" | |
72 address)) | |
73 (setq address | |
74 (mail-string-delete address | |
75 pos (match-end 0))))) | |
76 | |
77 ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>') | |
78 (setq pos 0) | |
79 (while (setq pos (string-match | |
80 "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*" | |
81 address pos)) | |
82 ;; If the next thing is "@", we have "foo bar"@host. Leave it. | |
83 (if (and (> (length address) (match-end 0)) | |
84 (= (aref address (match-end 0)) ?@)) | |
85 (setq pos (match-end 0)) | |
86 (setq address | |
87 (mail-string-delete address | |
88 pos (match-end 0))))) | |
89 ;; Retain only part of address in <> delims, if there is such a thing. | |
90 (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)" | |
91 address)) | |
92 (let ((junk-beg (match-end 1)) | |
93 (junk-end (match-beginning 2)) | |
94 (close (match-end 0))) | |
95 (setq address (mail-string-delete address (1- close) close)) | |
96 (setq address (mail-string-delete address junk-beg junk-end)))) | |
97 address))) | |
98 | |
99 (or (and (boundp 'rmail-default-dont-reply-to-names) | |
100 (not (null rmail-default-dont-reply-to-names))) | |
101 (setq rmail-default-dont-reply-to-names "info-")) | |
102 | |
103 ; rmail-dont-reply-to-names is defined in loaddefs | |
104 (defun rmail-dont-reply-to (userids) | |
105 "Returns string of mail addresses USERIDS sans any recipients | |
106 that start with matches for rmail-dont-reply-to-names. | |
107 Usenet paths ending in an element that matches are removed also." | |
108 (if (null rmail-dont-reply-to-names) | |
109 (setq rmail-dont-reply-to-names | |
110 (concat (if rmail-default-dont-reply-to-names | |
111 (concat rmail-default-dont-reply-to-names "\\|") | |
112 "") | |
113 (concat (regexp-quote (user-original-login-name)) | |
114 "\\>")))) | |
115 (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\(" | |
116 rmail-dont-reply-to-names | |
117 "\\)")) | |
118 (case-fold-search t) | |
119 pos epos) | |
120 (while (setq pos (string-match match userids)) | |
121 (if (> pos 0) (setq pos (1+ pos))) | |
122 (setq epos | |
123 (if (string-match "[ \t\n,]+" userids (match-end 0)) | |
124 (match-end 0) | |
125 (length userids))) | |
126 (setq userids | |
127 (mail-string-delete | |
128 userids pos epos))) | |
129 ;; get rid of any trailing commas | |
130 (if (setq pos (string-match "[ ,\t\n]*\\'" userids)) | |
131 (setq userids (substring userids 0 pos))) | |
132 ;; remove leading spaces. they bother me. | |
133 (if (string-match "\\s *" userids) | |
134 (substring userids (match-end 0)) | |
135 userids))) | |
136 | |
137 (defun mail-fetch-field (field-name &optional last all) | |
138 "Return the value of the header field FIELD. | |
139 The buffer is expected to be narrowed to just the headers of the message. | |
140 If 2nd arg LAST is non-nil, use the last such field if there are several. | |
141 If 3rd arg ALL is non-nil, concatenate all such fields, with commas between." | |
142 (save-excursion | |
143 (goto-char (point-min)) | |
144 (let ((case-fold-search t) | |
145 (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*"))) | |
146 (goto-char (point-min)) | |
147 (if all | |
148 (let ((value "")) | |
149 (while (re-search-forward name nil t) | |
150 (let ((opoint (point))) | |
151 (while (progn (forward-line 1) | |
152 (looking-at "[ \t]"))) | |
153 (setq value (concat value | |
154 (if (string= value "") "" ", ") | |
155 (buffer-substring opoint (1- (point))))))) | |
156 (and (not (string= value "")) value)) | |
157 (if (re-search-forward name nil t) | |
158 (progn | |
159 (if last (while (re-search-forward name nil t))) | |
160 (let ((opoint (point))) | |
161 (while (progn (forward-line 1) | |
162 (looking-at "[ \t]"))) | |
163 (buffer-substring opoint (1- (point)))))))))) | |
164 | |
165 ;; Parse a list of tokens separated by commas. | |
166 ;; It runs from point to the end of the visible part of the buffer. | |
167 ;; Whitespace before or after tokens is ignored, | |
168 ;; but whitespace within tokens is kept. | |
169 (defun mail-parse-comma-list () | |
170 (let (accumulated | |
171 beg) | |
172 (skip-chars-forward " ") | |
173 (while (not (eobp)) | |
174 (setq beg (point)) | |
175 (skip-chars-forward "^,") | |
176 (skip-chars-backward " ") | |
177 (setq accumulated | |
178 (cons (buffer-substring beg (point)) | |
179 accumulated)) | |
180 (skip-chars-forward "^,") | |
181 (skip-chars-forward ", ")) | |
182 accumulated)) | |
183 | |
184 (defun mail-comma-list-regexp (labels) | |
185 (let (pos) | |
186 (setq pos (or (string-match "[^ \t]" labels) 0)) | |
187 ;; Remove leading and trailing whitespace. | |
188 (setq labels (substring labels pos (string-match "[ \t]*$" labels pos))) | |
189 ;; Change each comma to \|, and flush surrounding whitespace. | |
190 (while (setq pos (string-match "[ \t]*,[ \t]*" labels)) | |
191 (setq labels | |
192 (concat (substring labels 0 pos) | |
193 "\\|" | |
194 (substring labels (match-end 0)))))) | |
195 labels) |