1 ;; Utility functions used both by rmail and rnews
2 ;; Copyright (C) 1985 Free Software Foundation, Inc.
4 ;; This file is part of GNU Emacs.
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)
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.
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.
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.")
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
))))
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."
41 (progn (require 'rfc822
)
42 (mapconcat 'identity
(rfc822-addresses address
) ", "))
44 (string-match "\\`[ \t\n]*" address
)
45 ;; strip surrounding whitespace
46 (setq address
(substring address
48 (string-match "[ \t\n]*\\'" address
51 ;; Detect nested comments.
52 (if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address
)
53 ;; Strip nested comments.
55 (set-buffer (get-buffer-create " *temp*"))
58 (set-syntax-table lisp-mode-syntax-table
)
60 (while (search-forward "(" nil t
)
62 (skip-chars-backward " \t")
63 (delete-region (point)
64 (save-excursion (forward-sexp 1) (point))))
65 (setq address
(buffer-string))
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\\)*)"
74 (mail-string-delete address
77 ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
79 (while (setq pos
(string-match
80 "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
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))
87 (mail-string-delete address
89 ;; Retain only part of address in <> delims, if there is such a thing.
90 (while (setq pos
(string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
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
))))
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-"))
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
"\\|")
113 (concat (regexp-quote (user-original-login-name))
115 (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
116 rmail-dont-reply-to-names
120 (while (setq pos
(string-match match userids
))
121 (if (> pos
0) (setq pos
(1+ pos
)))
123 (if (string-match "[ \t\n,]+" userids
(match-end 0))
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))
137 (defun mail-fetch-field (field-name &optional last all
)
138 "Return the value of the header field FIELD-NAME.
139 The buffer is expected to be narrowed to just the headers of the message.
140 If second arg LAST is non-nil, use the last such field if there are several.
141 If third arg ALL is non-nil, concatenate all such fields with commas between."
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))
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
)
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))))))))))
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 ()
172 (skip-chars-forward " ")
175 (skip-chars-forward "^,")
176 (skip-chars-backward " ")
178 (cons (buffer-substring beg
(point))
180 (skip-chars-forward "^,")
181 (skip-chars-forward ", "))
184 (defun mail-comma-list-regexp (labels)
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
))
192 (concat (substring labels
0 pos
)
194 (substring labels
(match-end 0))))))