Mercurial > emacs
annotate lisp/mail/mail-utils.el @ 15314:796d825f4444
(reset_modifiers): Only clear a modifier if the modifier key has been
detected to have been released since Emacs lost focus.
(win32_wnd_proc): Have Windows translate VK_NUMLOCK and VK_SCROLL key
downs; don't reset the modifier state when Emacs loses focus.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Sat, 01 Jun 1996 12:19:27 +0000 |
parents | 7bba84af4b94 |
children | b549210f6989 |
rev | line source |
---|---|
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
1 ;;; mail-utils.el --- utility functions used both by rmail and rnews |
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
2 |
845 | 3 ;; Copyright (C) 1985 Free Software Foundation, Inc. |
4 | |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
5 ;; Maintainer: FSF |
811
e694e0879463
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
807
diff
changeset
|
6 ;; Keywords: mail, news |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
7 |
36 | 8 ;; This file is part of GNU Emacs. |
9 | |
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 | |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
12 ;; the Free Software Foundation; either version 2, or (at your option) |
36 | 13 ;; any later version. |
14 | |
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. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
14169 | 21 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
36 | 24 |
2307
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
25 ;;; Commentary: |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
26 |
5365 | 27 ;; Utility functions for mail and netnews handling. These handle fine |
2307
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
28 ;; points of header parsing. |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
845
diff
changeset
|
29 |
807
4f28bd14272c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
659
diff
changeset
|
30 ;;; Code: |
36 | 31 |
285 | 32 ;;; We require lisp-mode to make sure that lisp-mode-syntax-table has |
33 ;;; been initialized. | |
34 (require 'lisp-mode) | |
36 | 35 |
268 | 36 ;;;###autoload |
37 (defvar mail-use-rfc822 nil "\ | |
38 *If non-nil, use a full, hairy RFC822 parser on mail addresses. | |
39 Otherwise, (the default) use a smaller, somewhat faster, and | |
40 often correct parser.") | |
36 | 41 |
13055
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
42 ;; Returns t if file FILE is an Rmail file. |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
43 ;;;###autoload |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
44 (defun mail-file-babyl-p (file) |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
45 (let ((buf (generate-new-buffer " *rmail-file-p*"))) |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
46 (unwind-protect |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
47 (save-excursion |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
48 (set-buffer buf) |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
49 (insert-file-contents file nil 0 100) |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
50 (looking-at "BABYL OPTIONS:")) |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
51 (kill-buffer buf)))) |
d94531fd96a4
(mail-file-babyl-p): Function moved from rmail.el and renamed.
Richard M. Stallman <rms@gnu.org>
parents:
12613
diff
changeset
|
52 |
36 | 53 (defun mail-string-delete (string start end) |
54 "Returns a string containing all of STRING except the part | |
55 from START (inclusive) to END (exclusive)." | |
56 (if (null end) (substring string 0 start) | |
57 (concat (substring string 0 start) | |
58 (substring string end nil)))) | |
59 | |
60 (defun mail-strip-quoted-names (address) | |
61 "Delete comments and quoted strings in an address list ADDRESS. | |
62 Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR. | |
63 Return a modified address list." | |
477 | 64 (if (null address) |
65 nil | |
66 (if mail-use-rfc822 | |
67 (progn (require 'rfc822) | |
68 (mapconcat 'identity (rfc822-addresses address) ", ")) | |
69 (let (pos) | |
70 (string-match "\\`[ \t\n]*" address) | |
71 ;; strip surrounding whitespace | |
72 (setq address (substring address | |
73 (match-end 0) | |
74 (string-match "[ \t\n]*\\'" address | |
75 (match-end 0)))) | |
36 | 76 |
477 | 77 ;; Detect nested comments. |
78 (if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address) | |
79 ;; Strip nested comments. | |
80 (save-excursion | |
81 (set-buffer (get-buffer-create " *temp*")) | |
82 (erase-buffer) | |
83 (insert address) | |
84 (set-syntax-table lisp-mode-syntax-table) | |
85 (goto-char 1) | |
86 (while (search-forward "(" nil t) | |
87 (forward-char -1) | |
88 (skip-chars-backward " \t") | |
89 (delete-region (point) | |
3118
e7dd24a618fb
(mail-strip-quoted-names): Catch errors from forward-sexp.
Richard M. Stallman <rms@gnu.org>
parents:
2307
diff
changeset
|
90 (save-excursion |
e7dd24a618fb
(mail-strip-quoted-names): Catch errors from forward-sexp.
Richard M. Stallman <rms@gnu.org>
parents:
2307
diff
changeset
|
91 (condition-case () |
e7dd24a618fb
(mail-strip-quoted-names): Catch errors from forward-sexp.
Richard M. Stallman <rms@gnu.org>
parents:
2307
diff
changeset
|
92 (forward-sexp 1) |
e7dd24a618fb
(mail-strip-quoted-names): Catch errors from forward-sexp.
Richard M. Stallman <rms@gnu.org>
parents:
2307
diff
changeset
|
93 (error (goto-char (point-max)))) |
e7dd24a618fb
(mail-strip-quoted-names): Catch errors from forward-sexp.
Richard M. Stallman <rms@gnu.org>
parents:
2307
diff
changeset
|
94 (point)))) |
477 | 95 (setq address (buffer-string)) |
96 (erase-buffer)) | |
97 ;; Strip non-nested comments an easier way. | |
98 (while (setq pos (string-match | |
99 ;; This doesn't hack rfc822 nested comments | |
100 ;; `(xyzzy (foo) whinge)' properly. Big deal. | |
101 "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)" | |
102 address)) | |
103 (setq address | |
104 (mail-string-delete address | |
105 pos (match-end 0))))) | |
36 | 106 |
477 | 107 ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>') |
108 (setq pos 0) | |
109 (while (setq pos (string-match | |
110 "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*" | |
111 address pos)) | |
112 ;; If the next thing is "@", we have "foo bar"@host. Leave it. | |
113 (if (and (> (length address) (match-end 0)) | |
114 (= (aref address (match-end 0)) ?@)) | |
115 (setq pos (match-end 0)) | |
116 (setq address | |
117 (mail-string-delete address | |
118 pos (match-end 0))))) | |
119 ;; Retain only part of address in <> delims, if there is such a thing. | |
13192
c7174381d5d9
(mail-strip-quoted-names): Preserve white space
Richard M. Stallman <rms@gnu.org>
parents:
13055
diff
changeset
|
120 (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)[^,]*<\\([^>,]*>\\)" |
477 | 121 address)) |
122 (let ((junk-beg (match-end 1)) | |
123 (junk-end (match-beginning 2)) | |
124 (close (match-end 0))) | |
125 (setq address (mail-string-delete address (1- close) close)) | |
126 (setq address (mail-string-delete address junk-beg junk-end)))) | |
127 address)))) | |
36 | 128 |
129 (or (and (boundp 'rmail-default-dont-reply-to-names) | |
130 (not (null rmail-default-dont-reply-to-names))) | |
131 (setq rmail-default-dont-reply-to-names "info-")) | |
132 | |
133 ; rmail-dont-reply-to-names is defined in loaddefs | |
134 (defun rmail-dont-reply-to (userids) | |
135 "Returns string of mail addresses USERIDS sans any recipients | |
220 | 136 that start with matches for `rmail-dont-reply-to-names'. |
36 | 137 Usenet paths ending in an element that matches are removed also." |
138 (if (null rmail-dont-reply-to-names) | |
139 (setq rmail-dont-reply-to-names | |
140 (concat (if rmail-default-dont-reply-to-names | |
141 (concat rmail-default-dont-reply-to-names "\\|") | |
142 "") | |
5914
7643239d5bf2
(rmail-dont-reply-to): Change user-original-login-name to user-login-name.
Karl Heuer <kwzh@gnu.org>
parents:
5365
diff
changeset
|
143 (concat (regexp-quote (user-login-name)) |
36 | 144 "\\>")))) |
145 (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\(" | |
146 rmail-dont-reply-to-names | |
147 "\\)")) | |
148 (case-fold-search t) | |
149 pos epos) | |
150 (while (setq pos (string-match match userids)) | |
13590
bd48b68249cf
(rmail-dont-reply-to): Preserve whitespace after comma.
Richard M. Stallman <rms@gnu.org>
parents:
13192
diff
changeset
|
151 (if (> pos 0) (setq pos (match-beginning 2))) |
36 | 152 (setq epos |
14660
071940e2a563
(rmail-dont-reply-to): Allow parsing lists of addresses with comment fields.
Richard M. Stallman <rms@gnu.org>
parents:
14169
diff
changeset
|
153 ;; Delete thru the next comma, plus whitespace after. |
071940e2a563
(rmail-dont-reply-to): Allow parsing lists of addresses with comment fields.
Richard M. Stallman <rms@gnu.org>
parents:
14169
diff
changeset
|
154 (if (string-match ",[ \t\n]+" userids (match-end 0)) |
36 | 155 (match-end 0) |
156 (length userids))) | |
157 (setq userids | |
158 (mail-string-delete | |
159 userids pos epos))) | |
160 ;; get rid of any trailing commas | |
161 (if (setq pos (string-match "[ ,\t\n]*\\'" userids)) | |
162 (setq userids (substring userids 0 pos))) | |
163 ;; remove leading spaces. they bother me. | |
164 (if (string-match "\\s *" userids) | |
165 (substring userids (match-end 0)) | |
166 userids))) | |
167 | |
5289
4e000b7b285a
(mail-fetch-field): Add autoload cookie.
Richard M. Stallman <rms@gnu.org>
parents:
5095
diff
changeset
|
168 ;;;###autoload |
36 | 169 (defun mail-fetch-field (field-name &optional last all) |
220 | 170 "Return the value of the header field FIELD-NAME. |
36 | 171 The buffer is expected to be narrowed to just the headers of the message. |
220 | 172 If second arg LAST is non-nil, use the last such field if there are several. |
173 If third arg ALL is non-nil, concatenate all such fields with commas between." | |
36 | 174 (save-excursion |
175 (goto-char (point-min)) | |
176 (let ((case-fold-search t) | |
177 (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*"))) | |
178 (if all | |
179 (let ((value "")) | |
180 (while (re-search-forward name nil t) | |
181 (let ((opoint (point))) | |
182 (while (progn (forward-line 1) | |
183 (looking-at "[ \t]"))) | |
5095
976d7492e00e
(mail-fetch-field): Exclude trailing whitespace.
Richard M. Stallman <rms@gnu.org>
parents:
4022
diff
changeset
|
184 ;; Back up over newline, then trailing spaces or tabs |
976d7492e00e
(mail-fetch-field): Exclude trailing whitespace.
Richard M. Stallman <rms@gnu.org>
parents:
4022
diff
changeset
|
185 (forward-char -1) |
14989
7bba84af4b94
(mail-fetch-field): Use skip-chars-backward
Richard M. Stallman <rms@gnu.org>
parents:
14660
diff
changeset
|
186 (skip-chars-backward " \t" opoint) |
36 | 187 (setq value (concat value |
188 (if (string= value "") "" ", ") | |
12613
1243b1f01079
(mail-fetch-field): Use buffer-substring-no-properties.
Richard M. Stallman <rms@gnu.org>
parents:
5914
diff
changeset
|
189 (buffer-substring-no-properties |
1243b1f01079
(mail-fetch-field): Use buffer-substring-no-properties.
Richard M. Stallman <rms@gnu.org>
parents:
5914
diff
changeset
|
190 opoint (point)))))) |
36 | 191 (and (not (string= value "")) value)) |
192 (if (re-search-forward name nil t) | |
193 (progn | |
194 (if last (while (re-search-forward name nil t))) | |
195 (let ((opoint (point))) | |
196 (while (progn (forward-line 1) | |
197 (looking-at "[ \t]"))) | |
5095
976d7492e00e
(mail-fetch-field): Exclude trailing whitespace.
Richard M. Stallman <rms@gnu.org>
parents:
4022
diff
changeset
|
198 ;; Back up over newline, then trailing spaces or tabs |
976d7492e00e
(mail-fetch-field): Exclude trailing whitespace.
Richard M. Stallman <rms@gnu.org>
parents:
4022
diff
changeset
|
199 (forward-char -1) |
14989
7bba84af4b94
(mail-fetch-field): Use skip-chars-backward
Richard M. Stallman <rms@gnu.org>
parents:
14660
diff
changeset
|
200 (skip-chars-backward " \t" opoint) |
12613
1243b1f01079
(mail-fetch-field): Use buffer-substring-no-properties.
Richard M. Stallman <rms@gnu.org>
parents:
5914
diff
changeset
|
201 (buffer-substring-no-properties opoint (point))))))))) |
36 | 202 |
203 ;; Parse a list of tokens separated by commas. | |
204 ;; It runs from point to the end of the visible part of the buffer. | |
205 ;; Whitespace before or after tokens is ignored, | |
206 ;; but whitespace within tokens is kept. | |
207 (defun mail-parse-comma-list () | |
208 (let (accumulated | |
209 beg) | |
210 (skip-chars-forward " ") | |
211 (while (not (eobp)) | |
212 (setq beg (point)) | |
213 (skip-chars-forward "^,") | |
214 (skip-chars-backward " ") | |
215 (setq accumulated | |
216 (cons (buffer-substring beg (point)) | |
217 accumulated)) | |
218 (skip-chars-forward "^,") | |
219 (skip-chars-forward ", ")) | |
220 accumulated)) | |
221 | |
222 (defun mail-comma-list-regexp (labels) | |
223 (let (pos) | |
224 (setq pos (or (string-match "[^ \t]" labels) 0)) | |
225 ;; Remove leading and trailing whitespace. | |
226 (setq labels (substring labels pos (string-match "[ \t]*$" labels pos))) | |
227 ;; Change each comma to \|, and flush surrounding whitespace. | |
228 (while (setq pos (string-match "[ \t]*,[ \t]*" labels)) | |
229 (setq labels | |
230 (concat (substring labels 0 pos) | |
231 "\\|" | |
232 (substring labels (match-end 0)))))) | |
233 labels) | |
4022
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
234 |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
235 (defun mail-rfc822-time-zone (time) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
236 (let* ((sec (or (car (current-time-zone time)) 0)) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
237 (absmin (/ (abs sec) 60))) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
238 (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60)))) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
239 |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
240 (defun mail-rfc822-date () |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
241 (let* ((time (current-time)) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
242 (s (current-time-string time))) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
243 (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s) |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
244 (concat (substring s (match-beginning 2) (match-end 2)) " " |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
245 (substring s (match-beginning 1) (match-end 1)) " " |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
246 (substring s (match-beginning 4) (match-end 4)) " " |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
247 (substring s (match-beginning 3) (match-end 3)) " " |
a3d3d7eef5ce
(mail-rfc822-time-zone, mail-rfc822-date): New fns.
Richard M. Stallman <rms@gnu.org>
parents:
3118
diff
changeset
|
248 (mail-rfc822-time-zone time)))) |
584 | 249 |
250 (provide 'mail-utils) | |
251 | |
659
505130d1ddf8
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
584
diff
changeset
|
252 ;;; mail-utils.el ends here |