Return to mail-utils.el CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp

Annotation of 43BSD/contrib/emacs/lisp/mail-utils.el, revision 1.1

1.1     ! root        1: ;; Utility functions used both by rmail and rnews
        !             2: 
        !             3: ;; Copyright (C) 1985 Richard M. Stallman.
        !             4: 
        !             5: ;; This file is part of GNU Emacs.
        !             6: 
        !             7: ;; GNU Emacs is distributed in the hope that it will be useful,
        !             8: ;; but WITHOUT ANY WARRANTY.  No author or distributor
        !             9: ;; accepts responsibility to anyone for the consequences of using it
        !            10: ;; or for whether it serves any particular purpose or works at all,
        !            11: ;; unless he says so in writing.  Refer to the GNU Emacs General Public
        !            12: ;; License for full details.
        !            13: 
        !            14: ;; Everyone is granted permission to copy, modify and redistribute
        !            15: ;; GNU Emacs, but only under the conditions described in the
        !            16: ;; GNU Emacs General Public License.   A copy of this license is
        !            17: ;; supposed to have been given to you along with GNU Emacs so you
        !            18: ;; can know your rights and responsibilities.  It should be in a
        !            19: ;; file named COPYING.  Among other things, the copyright notice
        !            20: ;; and this notice must be preserved on all copies.
        !            21: 
        !            22: 
        !            23: (provide 'mail-utils)
        !            24:                     
        !            25: (defun mail-string-delete (string start end)
        !            26:   "Returns a string containing all of STRING except the part
        !            27: from START (inclusive) to END (exclusive)."
        !            28:   (if (null end) (substring string 0 start)
        !            29:     (concat (substring string 0 start)
        !            30:            (substring string end nil))))
        !            31: 
        !            32: (defun mail-strip-quoted-names (address)
        !            33:   "Delete comments and quoted strings in an address list ADDRESS.
        !            34: Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
        !            35: Return a modified address list."
        !            36:   (let (pos)
        !            37:     (string-match "\\`[ \t\n]*" address)
        !            38:     ;; strip surrounding whitespace
        !            39:     (setq address (substring address
        !            40:                             (match-end 0)
        !            41:                             (string-match "[ \t\n]*\\'" address
        !            42:                                           (match-end 0))))
        !            43:     ;; strip rfc822 comments
        !            44:     (while (setq pos (string-match 
        !            45:                       ;; This doesn't hack rfc822 nested comments
        !            46:                       ;;  `(xyzzy (foo) whinge)' properly.  Big deal.
        !            47:                       "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
        !            48:                       address))
        !            49:       (setq address
        !            50:            (mail-string-delete address
        !            51:                                pos (match-end 0))))
        !            52:     ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
        !            53:     (setq pos 0)
        !            54:     (while (setq pos (string-match
        !            55:                       "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t]*"
        !            56:                       address pos))
        !            57:       ;; If the next thing is "@", we have "foo bar"@host.  Leave it.
        !            58:       (if (and (> (length address) (match-end 0))
        !            59:               (= (aref address (match-end 0)) ?@))
        !            60:          (setq pos (match-end 0))
        !            61:        (setq address
        !            62:              (mail-string-delete address
        !            63:                                  pos (match-end 0)))))
        !            64:     ;; Retain only part of address in <> delims, if there is such a thing.
        !            65:     (while (setq pos (string-match "\\(,\\|^\\)[^,\n]*<\\([^>,\n]*>\\)" address))
        !            66:       (let ((junk-beg (match-end 1))
        !            67:            (junk-end (match-beginning 2))
        !            68:            (close (match-end 0)))
        !            69:        (setq address (mail-string-delete address (1- close) close))
        !            70:        (setq address (mail-string-delete address junk-beg junk-end))))
        !            71:     address))
        !            72:   
        !            73: ; rmail-dont-reply-to-names is defined in loaddefs
        !            74: (defun rmail-dont-reply-to (userids)
        !            75:   "Returns string of mail addresses USERIDS sans any recipients
        !            76: that are elements of  rmail-dont-reply-to-names.
        !            77: Usenet paths ending in an element of that list are removed also."
        !            78:   (if (null rmail-dont-reply-to-names)
        !            79:       (setq rmail-dont-reply-to-names
        !            80:            (concat "info-\\|"
        !            81:                    (regexp-quote (or (getenv "USER")
        !            82:                                      (getenv "LOGNAME")))
        !            83:                    "\\>")))
        !            84:   (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
        !            85:                       rmail-dont-reply-to-names
        !            86:                       "\\)"))
        !            87:        (case-fold-search t)
        !            88:        pos epos)
        !            89:     (while (setq pos (string-match match userids))
        !            90:       (if (> pos 0) (setq pos (1+ pos)))
        !            91:       (setq epos
        !            92:            (if (string-match "[ \t\n,]+" userids (match-end 0))
        !            93:                (match-end 0)
        !            94:              (length userids)))
        !            95:       (setq userids
        !            96:            (mail-string-delete
        !            97:              userids pos epos)))
        !            98:     ;; get rid of any trailing commas
        !            99:     (if (setq pos (string-match "[ ,\t\n]*\\'" userids))
        !           100:        (setq userids (substring userids 0 pos)))
        !           101:     ;; remove leading spaces. they bother me.
        !           102:     (if (string-match "\\s *" userids)
        !           103:        (substring userids (match-end 0))
        !           104:       userids)))
        !           105: 
        !           106: (defun mail-fetch-field (field-name &optional last all)
        !           107:   "Return the value of the header field FIELD.
        !           108: The buffer is expected to be narrowed to just the headers of the message.
        !           109: If 2nd arg LAST is non-nil, use the last such field if there are several.
        !           110: If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
        !           111:   (save-excursion
        !           112:     (goto-char (point-min))
        !           113:     (let ((case-fold-search t)
        !           114:          (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
        !           115:       (goto-char (point-min))
        !           116:       (if all
        !           117:          (let ((value ""))
        !           118:            (while (re-search-forward name nil t)
        !           119:              (let ((opoint (point)))
        !           120:                (while (progn (forward-line 1)
        !           121:                              (looking-at "[ \t]")))
        !           122:                (setq value (concat value
        !           123:                                    (if (string= value "") "" ", ")
        !           124:                                    (buffer-substring opoint (1- (point)))))))
        !           125:            (and (not (string= value "")) value))
        !           126:        (if (re-search-forward name nil t)
        !           127:            (progn
        !           128:              (if last (while (re-search-forward name nil t)))
        !           129:              (let ((opoint (point)))
        !           130:                (while (progn (forward-line 1)
        !           131:                              (looking-at "[ \t]")))
        !           132:                (buffer-substring opoint (1- (point))))))))))
        !           133: 
        !           134: ;; Parse a list of tokens separated by commas.
        !           135: ;; It runs from point to the end of the visible part of the buffer.
        !           136: ;; Whitespace before or after tokens is ignored,
        !           137: ;; but whitespace within tokens is kept.
        !           138: (defun mail-parse-comma-list ()
        !           139:   (let (accumulated
        !           140:        beg)
        !           141:     (skip-chars-forward " ")
        !           142:     (while (not (eobp))
        !           143:       (setq beg (point))
        !           144:       (skip-chars-forward "^,")
        !           145:       (skip-chars-backward " ")
        !           146:       (setq accumulated
        !           147:            (cons (buffer-substring beg (point))
        !           148:                  accumulated))
        !           149:       (skip-chars-forward "^,")
        !           150:       (skip-chars-forward ", "))
        !           151:     accumulated))
        !           152: 
        !           153: (defun mail-comma-list-regexp (labels)
        !           154:   (let (pos)
        !           155:     (setq pos (or (string-match "[^ \t]" labels) 0))
        !           156:     ;; Remove leading and trailing whitespace.
        !           157:     (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
        !           158:     ;; Change each comma to \|, and flush surrounding whitespace.
        !           159:     (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
        !           160:       (setq labels
        !           161:            (concat (substring labels 0 pos)
        !           162:                    "\\|"
        !           163:                    (substring labels (match-end 0))))))
        !           164:   labels)

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.