code.delx.au - gnu-emacs/blob - lisp/gnus/ietf-drums.el

   1 ;;; ietf-drums.el --- Functions for parsing RFC822bis headers
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; DRUMS is an IETF Working Group that works (or worked) on the
  25 ;; successor to RFC822, "Standard For The Format Of Arpa Internet Text
  26 ;; Messages".  This library is based on
  27 ;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05.
  28
  29 ;; Pending a real regression self test suite, Simon Josefsson added
  30 ;; various self test expressions snipped from bug reports, and their
  31 ;; expected value, below.  I you believe it could be useful, please
  32 ;; add your own test cases, or write a real self test suite, or just
  33 ;; remove this.
  34
  35 ;; <m3oekvfd50.fsf@whitebox.m5r.de>
  36 ;; (ietf-drums-parse-address "'foo' <foo@example.com>")
  37 ;; => ("foo@example.com" . "'foo'")
  38
  39 ;;; Code:
  40
  41 (eval-when-compile (require 'cl))
  42 (require 'mm-util)
  43
  44 (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177"
  45   "US-ASCII control characters excluding CR, LF and white space.")
  46 (defvar ietf-drums-text-token "\001-\011\013\014\016-\177"
  47   "US-ASCII characters excluding CR and LF.")
  48 (defvar ietf-drums-specials-token "()<>[]:;@\\,.\""
  49   "Special characters.")
  50 (defvar ietf-drums-quote-token "\\"
  51   "Quote character.")
  52 (defvar ietf-drums-wsp-token " \t"
  53   "White space.")
  54 (defvar ietf-drums-fws-regexp
  55   (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+")
  56   "Folding white space.")
  57 (defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~"
  58   "Textual token.")
  59 (defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~."
  60   "Textual token including full stop.")
  61 (defvar ietf-drums-qtext-token
  62   (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177")
  63   "Non-white-space control characters, plus the rest of ASCII excluding
  64 backslash and doublequote.")
  65 (defvar ietf-drums-tspecials "][()<>@,;:\\\"/?="
  66   "Tspecials.")
  67
  68 (defvar ietf-drums-syntax-table
  69   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
  70     (modify-syntax-entry ?\\ "/" table)
  71     (modify-syntax-entry ?< "(" table)
  72     (modify-syntax-entry ?> ")" table)
  73     (modify-syntax-entry ?@ "w" table)
  74     (modify-syntax-entry ?/ "w" table)
  75     (modify-syntax-entry ?* "_" table)
  76     (modify-syntax-entry ?\; "_" table)
  77     (modify-syntax-entry ?\' "_" table)
  78     (if (featurep 'xemacs)
  79         (let ((i 128))
  80           (while (< i 256)
  81             (modify-syntax-entry i "w" table)
  82             (setq i (1+ i)))))
  83     table))
  84
  85 (defun ietf-drums-token-to-list (token)
  86   "Translate TOKEN into a list of characters."
  87   (let ((i 0)
  88         b e c out range)
  89     (while (< i (length token))
  90       (setq c (mm-char-int (aref token i)))
  91       (incf i)
  92       (cond
  93        ((eq c (mm-char-int ?-))
  94         (if b
  95             (setq range t)
  96           (push c out)))
  97        (range
  98         (while (<= b c)
  99           (push (make-char 'ascii b) out)
 100           (incf b))
 101         (setq range nil))
 102        ((= i (length token))
 103         (push (make-char 'ascii c) out))
 104        (t
 105         (when b
 106           (push (make-char 'ascii b) out))
 107         (setq b c))))
 108     (nreverse out)))
 109
 110 (defsubst ietf-drums-init (string)
 111   (set-syntax-table ietf-drums-syntax-table)
 112   (insert string)
 113   (ietf-drums-unfold-fws)
 114   (goto-char (point-min)))
 115
 116 (defun ietf-drums-remove-comments (string)
 117   "Remove comments from STRING."
 118   (with-temp-buffer
 119     (let (c)
 120       (ietf-drums-init string)
 121       (while (not (eobp))
 122         (setq c (char-after))
 123         (cond
 124          ((eq c ?\")
 125           (condition-case err
 126               (forward-sexp 1)
 127             (error (goto-char (point-max)))))
 128          ((eq c ?\()
 129           (delete-region
 130                (point)
 131                (condition-case nil
 132                    (with-syntax-table (copy-syntax-table ietf-drums-syntax-table)
 133                      (modify-syntax-entry ?\" "w")
 134                      (forward-sexp 1)
 135                      (point))
 136                  (error (point-max)))))
 137          (t
 138           (forward-char 1))))
 139       (buffer-string))))
 140
 141 (defun ietf-drums-remove-whitespace (string)
 142   "Remove whitespace from STRING."
 143   (with-temp-buffer
 144     (ietf-drums-init string)
 145     (let (c)
 146       (while (not (eobp))
 147         (setq c (char-after))
 148         (cond
 149          ((eq c ?\")
 150           (forward-sexp 1))
 151          ((eq c ?\()
 152           (forward-sexp 1))
 153          ((memq c '(?\  ?\t ?\n))
 154           (delete-char 1))
 155          (t
 156           (forward-char 1))))
 157       (buffer-string))))
 158
 159 (defun ietf-drums-get-comment (string)
 160   "Return the first comment in STRING."
 161   (with-temp-buffer
 162     (ietf-drums-init string)
 163     (let (result c)
 164       (while (not (eobp))
 165         (setq c (char-after))
 166         (cond
 167          ((eq c ?\")
 168           (forward-sexp 1))
 169          ((eq c ?\()
 170           (setq result
 171                 (buffer-substring
 172                  (1+ (point))
 173                  (progn (forward-sexp 1) (1- (point))))))
 174          (t
 175           (forward-char 1))))
 176       result)))
 177
 178 (defun ietf-drums-strip (string)
 179   "Remove comments and whitespace from STRING."
 180   (ietf-drums-remove-whitespace (ietf-drums-remove-comments string)))
 181
 182 (defun ietf-drums-parse-address (string)
 183   "Parse STRING and return a MAILBOX / DISPLAY-NAME pair."
 184   (with-temp-buffer
 185     (let (display-name mailbox c display-string)
 186       (ietf-drums-init string)
 187       (while (not (eobp))
 188         (setq c (char-after))
 189         (cond
 190          ((or (eq c ? )
 191               (eq c ?\t))
 192           (forward-char 1))
 193          ((eq c ?\()
 194           (forward-sexp 1))
 195          ((eq c ?\")
 196           (push (buffer-substring
 197                  (1+ (point)) (progn (forward-sexp 1) (1- (point))))
 198                 display-name))
 199          ((looking-at (concat "[" ietf-drums-atext-token "@" "]"))
 200           (push (buffer-substring (point) (progn (forward-sexp 1) (point)))
 201                 display-name))
 202          ((eq c ?<)
 203           (setq mailbox
 204                 (ietf-drums-remove-whitespace
 205                  (ietf-drums-remove-comments
 206                   (buffer-substring
 207                    (1+ (point))
 208                    (progn (forward-sexp 1) (1- (point))))))))
 209          (t
 210           (message "Unknown symbol: %c" c)
 211           (forward-char 1))))
 212       ;; If we found no display-name, then we look for comments.
 213       (if display-name
 214           (setq display-string
 215                 (mapconcat 'identity (reverse display-name) " "))
 216         (setq display-string (ietf-drums-get-comment string)))
 217       (if (not mailbox)
 218           (when (string-match "@" display-string)
 219             (cons
 220              (mapconcat 'identity (nreverse display-name) "")
 221              (ietf-drums-get-comment string)))
 222         (cons mailbox display-string)))))
 223
 224 (defun ietf-drums-parse-addresses (string &optional rawp)
 225   "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs.
 226 If RAWP, don't actually parse the addresses, but instead return
 227 a list of address strings."
 228   (if (null string)
 229       nil
 230     (with-temp-buffer
 231       (ietf-drums-init string)
 232       (let ((beg (point))
 233             pairs c address)
 234         (while (not (eobp))
 235           (setq c (char-after))
 236           (cond
 237            ((memq c '(?\" ?< ?\())
 238             (condition-case nil
 239                 (forward-sexp 1)
 240               (error
 241                (skip-chars-forward "^,"))))
 242            ((eq c ?,)
 243             (setq address
 244                   (if rawp
 245                       (buffer-substring beg (point))
 246                     (condition-case nil
 247                         (ietf-drums-parse-address
 248                          (buffer-substring beg (point)))
 249                       (error nil))))
 250             (if address (push address pairs))
 251             (forward-char 1)
 252             (setq beg (point)))
 253            (t
 254             (forward-char 1))))
 255         (setq address
 256               (if rawp
 257                   (buffer-substring beg (point))
 258                 (condition-case nil
 259                     (ietf-drums-parse-address
 260                      (buffer-substring beg (point)))
 261                   (error nil))))
 262         (if address (push address pairs))
 263         (nreverse pairs)))))
 264
 265 (defun ietf-drums-unfold-fws ()
 266   "Unfold folding white space in the current buffer."
 267   (goto-char (point-min))
 268   (while (re-search-forward ietf-drums-fws-regexp nil t)
 269     (replace-match " " t t))
 270   (goto-char (point-min)))
 271
 272 (defun ietf-drums-parse-date (string)
 273   "Return an Emacs time spec from STRING."
 274   (apply 'encode-time (parse-time-string string)))
 275
 276 (defun ietf-drums-narrow-to-header ()
 277   "Narrow to the header section in the current buffer."
 278   (narrow-to-region
 279    (goto-char (point-min))
 280    (if (re-search-forward "^\r?$" nil 1)
 281        (match-beginning 0)
 282      (point-max)))
 283   (goto-char (point-min)))
 284
 285 (defun ietf-drums-quote-string (string)
 286   "Quote string if it needs quoting to be displayed in a header."
 287   (if (string-match (concat "[^" ietf-drums-atext-token "]") string)
 288       (concat "\"" string "\"")
 289     string))
 290
 291 (defun ietf-drums-make-address (name address)
 292   (if name
 293       (concat (ietf-drums-quote-string name) " <" address ">")
 294     address))
 295
 296 (provide 'ietf-drums)
 297
 298 ;;; ietf-drums.el ends here