cgit.sxemacs.org Git - packages/blob - xemacs-packages/apel/std11.el

   1 ;;; std11.el --- STD 11 functions for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 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.40 1997/03/03 08:03:06 shuhei-k 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                 (let ((name (car token)))
 267                   (cond
 268                    ((eq name 'spaces) "")
 269                    ((eq name 'comment) "")
 270                    ((eq name 'quoted-string)
 271                     (concat "\"" (cdr token) "\""))
 272                    (t (cdr token)))
 273                   )))
 274              seq "")
 275   )
 276
 277 (defun std11-address-string (address)
 278   "Return string of address part from parsed ADDRESS of RFC 822.
 279 \[std11.el]"
 280   (cond ((eq (car address) 'group)
 281          (mapconcat (function std11-address-string)
 282                     (car (cdr address))
 283                     ", ")
 284          )
 285         ((eq (car address) 'mailbox)
 286          (let ((addr (nth 1 address)))
 287            (std11-addr-to-string
 288             (if (eq (car addr) 'phrase-route-addr)
 289                 (nth 2 addr)
 290               (cdr addr)
 291               )
 292             )))))
 293
 294 (defun std11-full-name-string (address)
 295   "Return string of full-name part from parsed ADDRESS of RFC 822.
 296 \[std11.el]"
 297   (cond ((eq (car address) 'group)
 298          (mapconcat (function
 299                      (lambda (token)
 300                        (cdr token)
 301                        ))
 302                     (nth 1 address) "")
 303          )
 304         ((eq (car address) 'mailbox)
 305          (let ((addr (nth 1 address))
 306                (comment (nth 2 address))
 307                phrase)
 308            (if (eq (car addr) 'phrase-route-addr)
 309                (setq phrase
 310                      (mapconcat
 311                       (function
 312                        (lambda (token)
 313                          (let ((type (car token)))
 314                            (cond ((eq type 'quoted-string)
 315                                   (std11-strip-quoted-pair (cdr token))
 316                                   )
 317                                  ((eq type 'comment)
 318                                   (concat
 319                                    "("
 320                                    (std11-strip-quoted-pair (cdr token))
 321                                    ")")
 322                                   )
 323                                  (t
 324                                   (cdr token)
 325                                   )))))
 326                       (nth 1 addr) ""))
 327              )
 328            (cond ((> (length phrase) 0) phrase)
 329                  (comment (std11-strip-quoted-pair comment))
 330                  )
 331            ))))
 332
 333
 334 ;;; @ parser
 335 ;;;
 336
 337 (defun std11-parse-address-string (string)
 338   "Parse STRING as mail address. [std11.el]"
 339   (std11-parse-address (std11-lexical-analyze string))
 340   )
 341
 342 (defun std11-parse-addresses-string (string)
 343   "Parse STRING as mail address list. [std11.el]"
 344   (std11-parse-addresses (std11-lexical-analyze string))
 345   )
 346
 347 (defun std11-extract-address-components (string)
 348   "Extract full name and canonical address from STRING.
 349 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
 350 If no name can be extracted, FULL-NAME will be nil. [std11.el]"
 351   (let* ((structure (car (std11-parse-address-string
 352                           (std11-unfold-string string))))
 353          (phrase  (std11-full-name-string structure))
 354          (address (std11-address-string structure))
 355          )
 356     (list phrase address)
 357     ))
 358
 359 (provide 'std11)
 360
 361 (mapcar (function
 362          (lambda (func)
 363            (autoload func "std11-parse")
 364            ))
 365         '(std11-lexical-analyze
 366           std11-parse-address std11-parse-addresses
 367           std11-parse-address-string))
 368
 369
 370 ;;; @ end
 371 ;;;
 372
 373 ;;; std11.el ends here