![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mail-utils.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to mail-utils.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 ! root 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 (null address) ! 41: nil ! 42: (if mail-use-rfc822 ! 43: (progn (require 'rfc822) ! 44: (mapconcat 'identity (rfc822-addresses address) ", ")) ! 45: (let (pos) ! 46: ;; Strip rfc822 comments (within parens). ! 47: ;; Understand properly the effect of backslashes and string quotes. ! 48: (let (instring (depth 0) start) ! 49: (setq pos -1) ! 50: (while pos ! 51: (cond ((< pos 0)) ! 52: ((= (aref address pos) ?\\) ! 53: (setq pos (1+ pos))) ! 54: ((= (aref address pos) ?\") ! 55: (setq instring (not instring))) ! 56: (instring nil) ! 57: ((= (aref address pos) ?\() ! 58: (if (= depth 0) (setq start pos)) ! 59: (setq depth (1+ depth))) ! 60: ((= (aref address pos) ?\)) ! 61: (setq depth (1- depth)) ! 62: (if (= depth 0) ! 63: (setq address (mail-string-delete address start (1+ pos)) ! 64: pos (1- start))))) ! 65: (setq pos (string-match "[\"\\()]" address (1+ pos))))) ! 66: ! 67: ;; strip surrounding whitespace ! 68: (string-match "\\`[ \t\n]*" address) ! 69: (setq address (substring address ! 70: (match-end 0) ! 71: (string-match "[ \t\n]*\\'" address ! 72: (match-end 0)))) ! 73: ! 74: ;; Strip whitespace before commas. ! 75: (let (instring) ! 76: (setq pos -1) ! 77: (while pos ! 78: (cond ((< pos 0)) ! 79: ((= (aref address pos) ?\\) ! 80: (setq pos (1+ pos))) ! 81: ((= (aref address pos) ?\") ! 82: (setq instring (not instring))) ! 83: (instring nil) ! 84: ((eq (string-match "[ \t]*," address pos) pos) ! 85: (setq address (mail-string-delete address pos ! 86: (1- (match-end 0)))))) ! 87: (setq pos (string-match "[ \t,\"\\]" address (1+ pos))))) ! 88: ! 89: ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>') ! 90: (setq pos 0) ! 91: (while (setq pos (string-match ! 92: "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*" ! 93: address pos)) ! 94: ;; If the next thing is "@", we have "foo bar"@host. Leave it. ! 95: (if (and (> (length address) (match-end 0)) ! 96: (= (aref address (match-end 0)) ?@)) ! 97: (setq pos (match-end 0)) ! 98: (setq address ! 99: (mail-string-delete address ! 100: pos (match-end 0))))) ! 101: ;; Retain only part of address in <> delims, if there is such a thing. ! 102: (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)" ! 103: address)) ! 104: (let ((junk-beg (match-end 1)) ! 105: (junk-end (match-beginning 2)) ! 106: (close (match-end 0))) ! 107: (setq address (mail-string-delete address (1- close) close)) ! 108: (setq address (mail-string-delete address junk-beg junk-end)))) ! 109: address)))) ! 110: ! 111: (or (and (boundp 'rmail-default-dont-reply-to-names) ! 112: (not (null rmail-default-dont-reply-to-names))) ! 113: (setq rmail-default-dont-reply-to-names "info-")) ! 114: ! 115: ; rmail-dont-reply-to-names is defined in loaddefs ! 116: (defun rmail-dont-reply-to (userids) ! 117: "Returns string of mail addresses USERIDS sans any recipients ! 118: that start with matches for rmail-dont-reply-to-names. ! 119: Usenet paths ending in an element that matches are removed also." ! 120: (if (null rmail-dont-reply-to-names) ! 121: (setq rmail-dont-reply-to-names ! 122: (concat (if rmail-default-dont-reply-to-names ! 123: (concat rmail-default-dont-reply-to-names "\\|") ! 124: "") ! 125: (concat (regexp-quote ! 126: (or (getenv "USER") (getenv "LOGNAME") ! 127: (user-login-name))) ! 128: "\\>")))) ! 129: (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\(" ! 130: rmail-dont-reply-to-names ! 131: "\\)")) ! 132: (case-fold-search t) ! 133: pos epos) ! 134: (while (setq pos (string-match match userids)) ! 135: (if (> pos 0) (setq pos (1+ pos))) ! 136: (setq epos ! 137: (if (string-match "[ \t\n,]+" userids (match-end 0)) ! 138: (match-end 0) ! 139: (length userids))) ! 140: (setq userids ! 141: (mail-string-delete ! 142: userids pos epos))) ! 143: ;; get rid of any trailing commas ! 144: (if (setq pos (string-match "[ ,\t\n]*\\'" userids)) ! 145: (setq userids (substring userids 0 pos))) ! 146: ;; remove leading spaces. they bother me. ! 147: (if (string-match "\\s *" userids) ! 148: (substring userids (match-end 0)) ! 149: userids))) ! 150: ! 151: (defun mail-fetch-field (field-name &optional last all) ! 152: "Return the value of the header field FIELD. ! 153: The buffer is expected to be narrowed to just the headers of the message. ! 154: If 2nd arg LAST is non-nil, use the last such field if there are several. ! 155: If 3rd arg ALL is non-nil, concatenate all such fields, with commas between." ! 156: (save-excursion ! 157: (goto-char (point-min)) ! 158: (let ((case-fold-search t) ! 159: (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*"))) ! 160: (goto-char (point-min)) ! 161: (if all ! 162: (let ((value "")) ! 163: (while (re-search-forward name nil t) ! 164: (let ((opoint (point))) ! 165: (while (progn (forward-line 1) ! 166: (looking-at "[ \t]"))) ! 167: (setq value (concat value ! 168: (if (string= value "") "" ", ") ! 169: (buffer-substring opoint (1- (point))))))) ! 170: (and (not (string= value "")) value)) ! 171: (if (re-search-forward name nil t) ! 172: (progn ! 173: (if last (while (re-search-forward name nil t))) ! 174: (let ((opoint (point))) ! 175: (while (progn (forward-line 1) ! 176: (looking-at "[ \t]"))) ! 177: (buffer-substring opoint (1- (point)))))))))) ! 178: ! 179: ;; Parse a list of tokens separated by commas. ! 180: ;; It runs from point to the end of the visible part of the buffer. ! 181: ;; Whitespace before or after tokens is ignored, ! 182: ;; but whitespace within tokens is kept. ! 183: (defun mail-parse-comma-list () ! 184: (let (accumulated ! 185: beg) ! 186: (skip-chars-forward " ") ! 187: (while (not (eobp)) ! 188: (setq beg (point)) ! 189: (skip-chars-forward "^,") ! 190: (skip-chars-backward " ") ! 191: (setq accumulated ! 192: (cons (buffer-substring beg (point)) ! 193: accumulated)) ! 194: (skip-chars-forward "^,") ! 195: (skip-chars-forward ", ")) ! 196: accumulated)) ! 197: ! 198: (defun mail-comma-list-regexp (labels) ! 199: (let (pos) ! 200: (setq pos (or (string-match "[^ \t]" labels) 0)) ! 201: ;; Remove leading and trailing whitespace. ! 202: (setq labels (substring labels pos (string-match "[ \t]*$" labels pos))) ! 203: ;; Change each comma to \|, and flush surrounding whitespace. ! 204: (while (setq pos (string-match "[ \t]*,[ \t]*" labels)) ! 205: (setq labels ! 206: (concat (substring labels 0 pos) ! 207: "\\|" ! 208: (substring labels (match-end 0)))))) ! 209: labels)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.