git.chise.org Git - elisp/gnus.git-/blob - lisp/drums.el

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