cgit.sxemacs.org Git - gnus/blob - lisp/ietf-drums.el

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