cgit.sxemacs.org Git - packages/blob - xemacs-packages/mail-lib/mail-utils.el

   1 ;;; mail-utils.el --- utility functions used both by rmail and rnews
   2
   3 ;; Copyright (C) 1985 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: mail, news
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; 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.
  24
  25 ;;; Synched up with: FSF 20.5.
  26
  27 ;;; Commentary:
  28
  29 ;; Utility functions for mail and netnews handling.  These handle fine
  30 ;; points of header parsing.
  31
  32 ;;; Code:
  33
  34 ;;; We require lisp-mode to make sure that lisp-mode-syntax-table has
  35 ;;; been initialized.
  36 (require 'lisp-mode)
  37
  38 ;;;###autoload
  39 (defcustom mail-use-rfc822 nil "\
  40 *If non-nil, use a full, hairy RFC822 parser on mail addresses.
  41 Otherwise, (the default) use a smaller, somewhat faster, and
  42 often correct parser."
  43   :type 'boolean
  44   :group 'mail)
  45
  46 ;; Returns t if file FILE is an Rmail file.
  47 ;;;###autoload
  48 (defun mail-file-babyl-p (file)
  49   (let ((buf (generate-new-buffer " *rmail-file-p*")))
  50     (unwind-protect
  51         (save-excursion
  52           (set-buffer buf)
  53           (insert-file-contents file nil 0 100)
  54           (looking-at "BABYL OPTIONS:"))
  55       (kill-buffer buf))))
  56
  57 (defun mail-string-delete (string start end)
  58   "Returns a string containing all of STRING except the part
  59 from START (inclusive) to END (exclusive)."
  60   (if (null end) (substring string 0 start)
  61     (concat (substring string 0 start)
  62             (substring string end nil))))
  63
  64 (defvar mail-rewrite-address-function nil
  65   "Function called at the end of `mail-strip-quoted-names' if defined.
  66 May be used for X.400 rewriting, etc.")
  67
  68 (defun mail-strip-quoted-names (address)
  69   "Delete comments and quoted strings in an address list ADDRESS.
  70 Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
  71 Return a modified address list."
  72   (if (null address)
  73       nil
  74     (if mail-use-rfc822
  75         (progn (require 'rfc822)
  76                (mapconcat 'identity (rfc822-addresses address) ", "))
  77       (let (pos)
  78
  79        ;; Detect nested comments.
  80        (if (string-match "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*(" address)
  81            ;; Strip nested comments.
  82            (save-excursion
  83              (set-buffer (get-buffer-create " *temp*"))
  84              (erase-buffer)
  85              (insert address)
  86              (set-syntax-table lisp-mode-syntax-table)
  87              (goto-char 1)
  88              (while (search-forward "(" nil t)
  89                (forward-char -1)
  90                (skip-chars-backward " \t")
  91                (delete-region (point)
  92                               (save-excursion
  93                                 (condition-case ()
  94                                     (forward-sexp 1)
  95                                   (error (goto-char (point-max))))
  96                                   (point))))
  97              (setq address (buffer-string))
  98              (erase-buffer))
  99          ;; Strip non-nested comments an easier way.
 100          (while (setq pos (string-match
 101                             ;; This doesn't hack rfc822 nested comments
 102                             ;;  `(xyzzy (foo) whinge)' properly.  Big deal.
 103                             "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*)"
 104                             address))
 105            (setq address
 106                  (mail-string-delete address
 107                                      pos (match-end 0)))))
 108
 109        ;; strip surrounding whitespace
 110        (string-match "\\`[ \t\n]*" address)
 111        (setq address (substring address
 112                                 (match-end 0)
 113                                 (string-match "[ \t\n]*\\'" address
 114                                               (match-end 0))))
 115
 116        ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
 117        (setq pos 0)
 118        (while (setq pos (string-match
 119                           "\\([ \t]?\\)[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
 120                           address pos))
 121          ;; If the next thing is "@", we have "foo bar"@host.  Leave it.
 122          (if (and (> (length address) (match-end 0))
 123                   (= (aref address (match-end 0)) ?@))
 124              (setq pos (match-end 0))
 125            (setq address
 126                  (mail-string-delete address
 127                                      (match-end 1) (match-end 0)))))
 128        ;; Retain only part of address in <> delims, if there is such a thing.
 129        (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)[^,]*<\\([^>,:]*>\\)"
 130                                       address))
 131          (let ((junk-beg (match-end 1))
 132                (junk-end (match-beginning 2))
 133                (close (match-end 0)))
 134            (setq address (mail-string-delete address (1- close) close))
 135            (setq address (mail-string-delete address junk-beg junk-end))))
 136        (if (fboundp mail-rewrite-address-function)
 137            (funcall mail-rewrite-address-function address)
 138          address)))))
 139
 140
 141 ;; rmail-dont-reply-to-names is an autoloaded variable in rmail-mini.el
 142 (defun rmail-dont-reply-to (userids)
 143   "Returns string of mail addresses USERIDS sans any recipients
 144 that start with matches for `rmail-dont-reply-to-names'.
 145 Usenet paths ending in an element that matches are removed also."
 146   (if (null rmail-dont-reply-to-names)
 147       (setq rmail-dont-reply-to-names
 148             (concat (if rmail-default-dont-reply-to-names
 149                         (concat rmail-default-dont-reply-to-names "\\|")
 150                         "")
 151                     (concat (regexp-quote (user-login-name))
 152                             "\\>"))))
 153   (let ((match (concat "\\(^\\|,\\)[ \t\n]*"
 154                        ;; Can anyone figure out what this is for?
 155                        ;; Is it an obsolete remnant of another way of
 156                        ;; handling Foo Bar <foo@machine>?
 157                        "\\([^,\n]*[!<]\\|\\)"
 158                        "\\("
 159                              rmail-dont-reply-to-names
 160                        "\\|"
 161                              ;; Include the human name that precedes <foo@bar>.
 162                              "\\([^\,.<\"]\\|\"[^\"]*\"\\)*"
 163                              "<\\(" rmail-dont-reply-to-names "\\)"
 164                        "\\)[^,]*"))
 165         (case-fold-search t)
 166         pos epos)
 167     (while (setq pos (string-match match userids pos))
 168       ;; If there's a match, it starts at the beginning of the string,
 169       ;; or with `,'.  We must delete from that position to the
 170       ;; end of the user-id which starts at match-beginning 2.
 171       (let (inside-quotes quote-pos)
 172         (save-match-data
 173           (while (and (setq quote-pos (string-match "\"" userids quote-pos))
 174                       (< quote-pos pos))
 175             (setq quote-pos (1+ quote-pos))
 176             (setq inside-quotes (not inside-quotes))))
 177         (if inside-quotes
 178             ;; Advance to next even-parity quote, and scan from there.
 179             (setq pos (string-match "\"" userids pos))
 180           (setq userids (replace-match "" nil nil userids)))))
 181     ;; get rid of any trailing commas
 182     (if (setq pos (string-match "[ ,\t\n]*\\'" userids))
 183         (setq userids (substring userids 0 pos)))
 184     ;; remove leading spaces. they bother me.
 185     (if (string-match "\\(\\s \\|,\\)*" userids)
 186         (substring userids (match-end 0))
 187       userids)))
 188
 189 \f
 190 ;;;###autoload
 191 (defun mail-fetch-field (field-name &optional last all list)
 192   "Return the value of the header field whose type is FIELD-NAME.
 193 The buffer is expected to be narrowed to just the header of the message.
 194 If second arg LAST is non-nil, use the last field of type FIELD-NAME.
 195 If third arg ALL is non-nil, concatenate all such fields with commas between.
 196 If 4th arg LIST is non-nil, return a list of all such fields."
 197   (save-excursion
 198     (goto-char (point-min))
 199     (let ((case-fold-search t)
 200           (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
 201       (if (or all list)
 202           (let ((value (if all "")))
 203             (while (re-search-forward name nil t)
 204               (let ((opoint (point)))
 205                 (while (progn (forward-line 1)
 206                               (looking-at "[ \t]")))
 207                 ;; Back up over newline, then trailing spaces or tabs
 208                 (forward-char -1)
 209                 (skip-chars-backward " \t" opoint)
 210                 (if list
 211                     (setq value (cons (buffer-substring-no-properties
 212                                        opoint (point))
 213                                       value))
 214                   (setq value (concat value
 215                                       (if (string= value "") "" ", ")
 216                                       (buffer-substring-no-properties
 217                                        opoint (point)))))))
 218             (if list
 219                 value
 220               (and (not (string= value "")) value)))
 221         (if (re-search-forward name nil t)
 222             (progn
 223               (if last (while (re-search-forward name nil t)))
 224               (let ((opoint (point)))
 225                 (while (progn (forward-line 1)
 226                               (looking-at "[ \t]")))
 227                 ;; Back up over newline, then trailing spaces or tabs
 228                 (forward-char -1)
 229                 (skip-chars-backward " \t" opoint)
 230                 (buffer-substring-no-properties opoint (point)))))))))
 231 \f
 232 ;; Parse a list of tokens separated by commas.
 233 ;; It runs from point to the end of the visible part of the buffer.
 234 ;; Whitespace before or after tokens is ignored,
 235 ;; but whitespace within tokens is kept.
 236 (defun mail-parse-comma-list ()
 237   (let (accumulated
 238         beg)
 239     (skip-chars-forward " \t\n")
 240     (while (not (eobp))
 241       (setq beg (point))
 242       (skip-chars-forward "^,")
 243       (skip-chars-backward " \t\n")
 244       (setq accumulated
 245             (cons (buffer-substring-no-properties beg (point))
 246                   accumulated))
 247       (skip-chars-forward "^,")
 248       (skip-chars-forward ", \t\n"))
 249     accumulated))
 250
 251 (defun mail-comma-list-regexp (labels)
 252   (let (pos)
 253     (setq pos (or (string-match "[^ \t]" labels) 0))
 254     ;; Remove leading and trailing whitespace.
 255     (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
 256     ;; Change each comma to \|, and flush surrounding whitespace.
 257     (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
 258       (setq labels
 259             (concat (substring labels 0 pos)
 260                     "\\|"
 261                     (substring labels (match-end 0))))))
 262   labels)
 263 \f
 264 (defun mail-rfc822-time-zone (time)
 265   (let* ((sec (or (car (current-time-zone time)) 0))
 266          (absmin (/ (abs sec) 60)))
 267     (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60))))
 268
 269 (defun mail-rfc822-date ()
 270   (let* ((time (current-time))
 271          (s (current-time-string time)))
 272     (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s)
 273     (concat (substring s (match-beginning 2) (match-end 2)) " "
 274             (substring s (match-beginning 1) (match-end 1)) " "
 275             (substring s (match-beginning 4) (match-end 4)) " "
 276             (substring s (match-beginning 3) (match-end 3)) " "
 277             (mail-rfc822-time-zone time))))
 278
 279 (defun mail-y-or-n-p (question &rest text)
 280   "Ask QUESTION, displaying the rest of the arguments as strings in a buffer."
 281   (setq text (mail-flatten-list text))
 282   (save-window-excursion
 283     (save-excursion
 284       (with-output-to-temp-buffer " *SMTP information message*"
 285         (set-buffer " *SMTP information message*")
 286         (fundamental-mode)              ; for Emacs 20.4+
 287         (mapcar 'princ text)
 288         (goto-char (point-min))))
 289     (y-or-n-p question)))
 290
 291 (defun mail-flatten-list (list)
 292   "Return a new, flat list that contains all elements of LIST.
 293
 294 \(mail-flatten-list '(1 (2 3 (4 5 (6))) 7))
 295 => (1 2 3 4 5 6 7)"
 296   (cond ((consp list)
 297          (apply 'append (mapcar 'mail-flatten-list list)))
 298         (list
 299          (list list))))
 300
 301 (defun mail-check-safe-charset ()
 302   "Check that buffer contain characters that will be safely encoded."
 303   (if (featurep 'mule)
 304       (let ((bad-charsets (set-difference
 305                            (find-charset-region (point-min) (point-max))
 306                            '(ascii latin-iso8859-1 control-1))))
 307         (when bad-charsets
 308           (or (mail-y-or-n-p
 309                "Your message contain invalid characters. Continue? "
 310                "You're trying to send a message that contain characters\nin the following character set:\n\n" (mapconcat 'symbol-name bad-charsets ", ") "\n\nThese characters cannot be sent without proper encoding.  Please\nconsider using a MIME enabled mail composer (such as `message').\nContinuing is likely to cause mail corruption.")
 311               (error "Message contain invalid character"))))))
 312
 313 (provide 'mail-utils)
 314
 315 ;;; mail-utils.el ends here