std11.el

   1 ;;; std11.el --- STD 11 functions for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
   4
   5 ;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: mail, news, RFC 822, STD 11
   7 ;; Version: $Id: std11.el,v 0.39 1996-12-17 12:06:15 morioka Exp $
   8
   9 ;; This file is part of MU (Message Utilities).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (autoload 'buffer-substring-no-properties "emu")
  29 (autoload 'member "emu")
  30
  31
  32 ;;; @ field
  33 ;;;
  34
  35 (defconst std11-field-name-regexp "[!-9;-~]+")
  36 (defconst std11-field-head-regexp
  37   (concat "^" std11-field-name-regexp ":"))
  38 (defconst std11-next-field-head-regexp
  39   (concat "\n" std11-field-name-regexp ":"))
  40
  41 (defun std11-field-end ()
  42   "Move to end of field and return this point. [std11.el]"
  43   (if (re-search-forward std11-next-field-head-regexp nil t)
  44       (goto-char (match-beginning 0))
  45     (if (re-search-forward "^$" nil t)
  46         (goto-char (1- (match-beginning 0)))
  47       (end-of-line)
  48       ))
  49   (point)
  50   )
  51
  52 (defun std11-field-body (name &optional boundary)
  53   "Return body of field NAME.
  54 If BOUNDARY is not nil, it is used as message header separator.
  55 \[std11.el]"
  56   (save-excursion
  57     (save-restriction
  58       (std11-narrow-to-header boundary)
  59       (goto-char (point-min))
  60       (let ((case-fold-search t))
  61         (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
  62             (buffer-substring-no-properties (match-end 0) (std11-field-end))
  63           )))))
  64
  65 (defun std11-find-field-body (field-names &optional boundary)
  66   "Return the first found field-body specified by FIELD-NAMES
  67 of the message header in current buffer. If BOUNDARY is not nil, it is
  68 used as message header separator. [std11.el]"
  69   (save-excursion
  70     (save-restriction
  71       (std11-narrow-to-header boundary)
  72       (let ((case-fold-search t)
  73             field-name)
  74         (catch 'tag
  75           (while (setq field-name (car field-names))
  76             (goto-char (point-min))
  77             (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
  78                 (throw 'tag
  79                        (buffer-substring-no-properties
  80                         (match-end 0) (std11-field-end)))
  81               )
  82             (setq field-names (cdr field-names))
  83             ))))))
  84
  85 (defun std11-field-bodies (field-names &optional default-value boundary)
  86   "Return list of each field-bodies of FIELD-NAMES of the message header
  87 in current buffer. If BOUNDARY is not nil, it is used as message
  88 header separator. [std11.el]"
  89   (save-excursion
  90     (save-restriction
  91       (std11-narrow-to-header boundary)
  92       (let* ((case-fold-search t)
  93              (dest (make-list (length field-names) default-value))
  94              (s-rest field-names)
  95              (d-rest dest)
  96              field-name)
  97         (while (setq field-name (car s-rest))
  98           (goto-char (point-min))
  99           (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
 100               (setcar d-rest
 101                       (buffer-substring-no-properties
 102                        (match-end 0) (std11-field-end)))
 103             )
 104           (setq s-rest (cdr s-rest)
 105                 d-rest (cdr d-rest))
 106           )
 107         dest))))
 108
 109
 110 ;;; @ unfolding
 111 ;;;
 112
 113 (defun std11-unfold-string (string)
 114   "Unfold STRING as message header field. [std11.el]"
 115   (let ((dest ""))
 116     (while (string-match "\n\\([ \t]\\)" string)
 117       (setq dest (concat dest
 118                          (substring string 0 (match-beginning 0))
 119                          (match-string 1 string)
 120                          ))
 121       (setq string (substring string (match-end 0)))
 122       )
 123     (concat dest string)
 124     ))
 125
 126
 127 ;;; @ header
 128 ;;;
 129
 130 (defun std11-narrow-to-header (&optional boundary)
 131   "Narrow to the message header.
 132 If BOUNDARY is not nil, it is used as message header separator.
 133 \[std11.el]"
 134   (narrow-to-region
 135    (goto-char (point-min))
 136    (if (re-search-forward
 137         (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$")
 138         nil t)
 139        (match-beginning 0)
 140      (point-max)
 141      )))
 142
 143 (defun std11-header-string (regexp &optional boundary)
 144   "Return string of message header fields matched by REGEXP.
 145 If BOUNDARY is not nil, it is used as message header separator.
 146 \[std11.el]"
 147   (let ((case-fold-search t))
 148     (save-excursion
 149       (save-restriction
 150         (std11-narrow-to-header boundary)
 151         (goto-char (point-min))
 152         (let (field header)
 153           (while (re-search-forward std11-field-head-regexp nil t)
 154             (setq field
 155                   (buffer-substring (match-beginning 0) (std11-field-end)))
 156             (if (string-match regexp field)
 157                 (setq header (concat header field "\n"))
 158               ))
 159           header)
 160         ))))
 161
 162 (defun std11-header-string-except (regexp &optional boundary)
 163   "Return string of message header fields not matched by REGEXP.
 164 If BOUNDARY is not nil, it is used as message header separator.
 165 \[std11.el]"
 166   (let ((case-fold-search t))
 167     (save-excursion
 168       (save-restriction
 169         (std11-narrow-to-header boundary)
 170         (goto-char (point-min))
 171         (let (field header)
 172           (while (re-search-forward std11-field-head-regexp nil t)
 173             (setq field
 174                   (buffer-substring (match-beginning 0) (std11-field-end)))
 175             (if (not (string-match regexp field))
 176                 (setq header (concat header field "\n"))
 177               ))
 178           header)
 179         ))))
 180
 181 (defun std11-collect-field-names (&optional boundary)
 182   "Return list of all field-names of the message header in current buffer.
 183 If BOUNDARY is not nil, it is used as message header separator.
 184 \[std11.el]"
 185   (save-excursion
 186     (save-restriction
 187       (std11-narrow-to-header boundary)
 188       (goto-char (point-min))
 189       (let (dest name)
 190         (while (re-search-forward std11-field-head-regexp nil t)
 191           (setq name (buffer-substring-no-properties
 192                       (match-beginning 0)(1- (match-end 0))))
 193           (or (member name dest)
 194               (setq dest (cons name dest))
 195               )
 196           )
 197         dest))))
 198
 199
 200 ;;; @ quoted-string
 201 ;;;
 202
 203 (defun std11-wrap-as-quoted-pairs (string specials)
 204   (let (dest
 205         (i 0)
 206         (b 0)
 207         (len (length string))
 208         )
 209     (while (< i len)
 210       (let ((chr (aref string i)))
 211         (if (memq chr specials)
 212             (setq dest (concat dest (substring string b i) "\\")
 213                   b i)
 214           ))
 215       (setq i (1+ i))
 216       )
 217     (concat dest (substring string b))
 218     ))
 219
 220 (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
 221
 222 (defun std11-wrap-as-quoted-string (string)
 223   "Wrap STRING as RFC 822 quoted-string. [std11.el]"
 224   (concat "\""
 225           (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list)
 226           "\""))
 227
 228 (defun std11-strip-quoted-pair (string)
 229   "Strip quoted-pairs in STRING. [std11.el]"
 230   (let (dest
 231         (b 0)
 232         (i 0)
 233         (len (length string))
 234         )
 235     (while (< i len)
 236       (let ((chr (aref string i)))
 237         (if (eq chr ?\\)
 238             (setq dest (concat dest (substring string b i))
 239                   b (1+ i)
 240                   i (+ i 2))
 241           (setq i (1+ i))
 242           )))
 243     (concat dest (substring string b))
 244     ))
 245
 246 (defun std11-strip-quoted-string (string)
 247   "Strip quoted-string STRING. [std11.el]"
 248   (let ((len (length string)))
 249     (or (and (>= len 2)
 250              (let ((max (1- len)))
 251                (and (eq (aref string 0) ?\")
 252                     (eq (aref string max) ?\")
 253                     (std11-strip-quoted-pair (substring string 1 max))
 254                     )))
 255         string)))
 256
 257
 258 ;;; @ composer
 259 ;;;
 260
 261 (defun std11-addr-to-string (seq)
 262   "Return string from lexical analyzed list SEQ
 263 represents addr-spec of RFC 822. [std11.el]"
 264   (mapconcat (function
 265               (lambda (token)
 266                 (if (let ((name (car token)))
 267                       (or (eq name 'spaces)
 268                           (eq name 'comment)
 269                           ))
 270                     ""
 271                   (cdr token)
 272                   )))
 273              seq "")
 274   )
 275
 276 (defun std11-address-string (address)
 277   "Return string of address part from parsed ADDRESS of RFC 822.
 278 \[std11.el]"
 279   (cond ((eq (car address) 'group)
 280          (mapconcat (function std11-address-string)
 281                     (car (cdr address))
 282                     ", ")
 283          )
 284         ((eq (car address) 'mailbox)
 285          (let ((addr (nth 1 address)))
 286            (std11-addr-to-string
 287             (if (eq (car addr) 'phrase-route-addr)
 288                 (nth 2 addr)
 289               (cdr addr)
 290               )
 291             )))))
 292
 293 (defun std11-full-name-string (address)
 294   "Return string of full-name part from parsed ADDRESS of RFC 822.
 295 \[std11.el]"
 296   (cond ((eq (car address) 'group)
 297          (mapconcat (function
 298                      (lambda (token)
 299                        (cdr token)
 300                        ))
 301                     (nth 1 address) "")
 302          )
 303         ((eq (car address) 'mailbox)
 304          (let ((addr (nth 1 address))
 305                (comment (nth 2 address))
 306                phrase)
 307            (if (eq (car addr) 'phrase-route-addr)
 308                (setq phrase
 309                      (mapconcat
 310                       (function
 311                        (lambda (token)
 312                          (let ((type (car token)))
 313                            (cond ((eq type 'quoted-string)
 314                                   (std11-strip-quoted-pair (cdr token))
 315                                   )
 316                                  ((eq type 'comment)
 317                                   (concat
 318                                    "("
 319                                    (std11-strip-quoted-pair (cdr token))
 320                                    ")")
 321                                   )
 322                                  (t
 323                                   (cdr token)
 324                                   )))))
 325                       (nth 1 addr) ""))
 326              )
 327            (cond ((> (length phrase) 0) phrase)
 328                  (comment (std11-strip-quoted-pair comment))
 329                  )
 330            ))))
 331
 332
 333 ;;; @ parser
 334 ;;;
 335
 336 (defun std11-parse-address-string (string)
 337   "Parse STRING as mail address. [std11.el]"
 338   (std11-parse-address (std11-lexical-analyze string))
 339   )
 340
 341 (defun std11-parse-addresses-string (string)
 342   "Parse STRING as mail address list. [std11.el]"
 343   (std11-parse-addresses (std11-lexical-analyze string))
 344   )
 345
 346 (defun std11-extract-address-components (string)
 347   "Extract full name and canonical address from STRING.
 348 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 349 If no name can be extracted, FULL-NAME will be nil. [std11.el]"
 350   (let* ((structure (car (std11-parse-address-string
 351                           (std11-unfold-string string))))
 352          (phrase  (std11-full-name-string structure))
 353          (address (std11-address-string structure))
 354          )
 355     (list phrase address)
 356     ))
 357
 358 (provide 'std11)
 359
 360 (mapcar (function
 361          (lambda (func)
 362            (autoload func "std11-parse")
 363            ))
 364         '(std11-lexical-analyze
 365           std11-parse-address std11-parse-addresses
 366           std11-parse-address-string))
 367
 368
 369 ;;; @ end
 370 ;;;
 371
 372 ;;; std11.el ends here