1 ;;; mail-utils.el --- utility functions used both by rmail and rnews
4 ;; Last-Modified: 16 Mar 1992
6 ;; Copyright (C) 1985 Free Software Foundation, Inc.
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26 ;;; We require lisp-mode to make sure that lisp-mode-syntax-table has
31 (defvar mail-use-rfc822 nil
"\
32 *If non-nil, use a full, hairy RFC822 parser on mail addresses.
33 Otherwise, (the default) use a smaller, somewhat faster, and
34 often correct parser.")
36 (defun mail-string-delete (string start end
)
37 "Returns a string containing all of STRING except the part
38 from START (inclusive) to END (exclusive)."
39 (if (null end
) (substring string
0 start
)
40 (concat (substring string
0 start
)
41 (substring string end nil
))))
43 (defun mail-strip-quoted-names (address)
44 "Delete comments and quoted strings in an address list ADDRESS.
45 Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
46 Return a modified address list."
50 (progn (require 'rfc822
)
51 (mapconcat 'identity
(rfc822-addresses address
) ", "))
53 (string-match "\\`[ \t\n]*" address
)
54 ;; strip surrounding whitespace
55 (setq address
(substring address
57 (string-match "[ \t\n]*\\'" address
60 ;; Detect nested comments.
61 (if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address
)
62 ;; Strip nested comments.
64 (set-buffer (get-buffer-create " *temp*"))
67 (set-syntax-table lisp-mode-syntax-table
)
69 (while (search-forward "(" nil t
)
71 (skip-chars-backward " \t")
72 (delete-region (point)
73 (save-excursion (forward-sexp 1) (point))))
74 (setq address
(buffer-string))
76 ;; Strip non-nested comments an easier way.
77 (while (setq pos
(string-match
78 ;; This doesn't hack rfc822 nested comments
79 ;; `(xyzzy (foo) whinge)' properly. Big deal.
80 "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
83 (mail-string-delete address
86 ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
88 (while (setq pos
(string-match
89 "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
91 ;; If the next thing is "@", we have "foo bar"@host. Leave it.
92 (if (and (> (length address
) (match-end 0))
93 (= (aref address
(match-end 0)) ?
@))
94 (setq pos
(match-end 0))
96 (mail-string-delete address
98 ;; Retain only part of address in <> delims, if there is such a thing.
99 (while (setq pos
(string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
101 (let ((junk-beg (match-end 1))
102 (junk-end (match-beginning 2))
103 (close (match-end 0)))
104 (setq address
(mail-string-delete address
(1- close
) close
))
105 (setq address
(mail-string-delete address junk-beg junk-end
))))
108 (or (and (boundp 'rmail-default-dont-reply-to-names
)
109 (not (null rmail-default-dont-reply-to-names
)))
110 (setq rmail-default-dont-reply-to-names
"info-"))
112 ; rmail-dont-reply-to-names is defined in loaddefs
113 (defun rmail-dont-reply-to (userids)
114 "Returns string of mail addresses USERIDS sans any recipients
115 that start with matches for `rmail-dont-reply-to-names'.
116 Usenet paths ending in an element that matches are removed also."
117 (if (null rmail-dont-reply-to-names
)
118 (setq rmail-dont-reply-to-names
119 (concat (if rmail-default-dont-reply-to-names
120 (concat rmail-default-dont-reply-to-names
"\\|")
122 (concat (regexp-quote (user-original-login-name))
124 (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
125 rmail-dont-reply-to-names
129 (while (setq pos
(string-match match userids
))
130 (if (> pos
0) (setq pos
(1+ pos
)))
132 (if (string-match "[ \t\n,]+" userids
(match-end 0))
138 ;; get rid of any trailing commas
139 (if (setq pos
(string-match "[ ,\t\n]*\\'" userids
))
140 (setq userids
(substring userids
0 pos
)))
141 ;; remove leading spaces. they bother me.
142 (if (string-match "\\s *" userids
)
143 (substring userids
(match-end 0))
146 (defun mail-fetch-field (field-name &optional last all
)
147 "Return the value of the header field FIELD-NAME.
148 The buffer is expected to be narrowed to just the headers of the message.
149 If second arg LAST is non-nil, use the last such field if there are several.
150 If third arg ALL is non-nil, concatenate all such fields with commas between."
152 (goto-char (point-min))
153 (let ((case-fold-search t
)
154 (name (concat "^" (regexp-quote field-name
) "[ \t]*:[ \t]*")))
155 (goto-char (point-min))
158 (while (re-search-forward name nil t
)
159 (let ((opoint (point)))
160 (while (progn (forward-line 1)
161 (looking-at "[ \t]")))
162 (setq value
(concat value
163 (if (string= value
"") "" ", ")
164 (buffer-substring opoint
(1- (point)))))))
165 (and (not (string= value
"")) value
))
166 (if (re-search-forward name nil t
)
168 (if last
(while (re-search-forward name nil t
)))
169 (let ((opoint (point)))
170 (while (progn (forward-line 1)
171 (looking-at "[ \t]")))
172 (buffer-substring opoint
(1- (point))))))))))
174 ;; Parse a list of tokens separated by commas.
175 ;; It runs from point to the end of the visible part of the buffer.
176 ;; Whitespace before or after tokens is ignored,
177 ;; but whitespace within tokens is kept.
178 (defun mail-parse-comma-list ()
181 (skip-chars-forward " ")
184 (skip-chars-forward "^,")
185 (skip-chars-backward " ")
187 (cons (buffer-substring beg
(point))
189 (skip-chars-forward "^,")
190 (skip-chars-forward ", "))
193 (defun mail-comma-list-regexp (labels)
195 (setq pos
(or (string-match "[^ \t]" labels
) 0))
196 ;; Remove leading and trailing whitespace.
197 (setq labels
(substring labels pos
(string-match "[ \t]*$" labels pos
)))
198 ;; Change each comma to \|, and flush surrounding whitespace.
199 (while (setq pos
(string-match "[ \t]*,[ \t]*" labels
))
201 (concat (substring labels
0 pos
)
203 (substring labels
(match-end 0))))))
206 (provide 'mail-utils
)
208 ;;; mail-utils.el ends here