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.24 1996-08-30 06:11:58 morioka Exp $
   8
   9 ;; This file is part of tl (Tiny Library).
  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 This program; see the file COPYING.  If not, write to
  23 ;; the 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-field-bodies (field-names &optional default-value boundary)
  66   "Return list of each field-bodies of FIELD-NAMES of the message header
  67 in current buffer. If BOUNDARY is not nil, it is used as message
  68 header separator. [std11.el]"
  69   (save-excursion
  70     (save-restriction
  71       (std11-narrow-to-header boundary)
  72       (let* ((case-fold-search t)
  73              (dest (make-list (length field-names) default-value))
  74              (s-rest field-names)
  75              (d-rest dest)
  76              field-name)
  77         (while (setq field-name (car s-rest))
  78           (goto-char (point-min))
  79           (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
  80               (setcar d-rest
  81                       (buffer-substring-no-properties
  82                        (match-end 0) (std11-field-end)))
  83             )
  84           (setq s-rest (cdr s-rest)
  85                 d-rest (cdr d-rest))
  86           )
  87         dest))))
  88
  89
  90 ;;; @ unfolding
  91 ;;;
  92
  93 (defun std11-unfold-string (string)
  94   "Unfold STRING as message header field. [std11.el]"
  95   (let ((dest ""))
  96     (while (string-match "\n\\s +" string)
  97       (setq dest (concat dest (substring string 0 (match-beginning 0)) " "))
  98       (setq string (substring string (match-end 0)))
  99       )
 100     (concat dest string)
 101     ))
 102
 103
 104 ;;; @ header
 105 ;;;
 106
 107 (defun std11-narrow-to-header (&optional boundary)
 108   "Narrow to the message header.
 109 If BOUNDARY is not nil, it is used as message header separator.
 110 \[std11.el]"
 111   (narrow-to-region
 112    (goto-char (point-min))
 113    (if (re-search-forward
 114         (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$")
 115         nil t)
 116        (match-beginning 0)
 117      (point-max)
 118      )))
 119
 120 (defun std11-header-string (regexp &optional boundary)
 121   "Return string of message header fields matched by REGEXP.
 122 If BOUNDARY is not nil, it is used as message header separator.
 123 \[std11.el]"
 124   (let ((case-fold-search t))
 125     (save-excursion
 126       (save-restriction
 127         (std11-narrow-to-header boundary)
 128         (goto-char (point-min))
 129         (let (field header)
 130           (while (re-search-forward std11-field-head-regexp nil t)
 131             (setq field
 132                   (buffer-substring (match-beginning 0) (std11-field-end)))
 133             (if (string-match regexp field)
 134                 (setq header (concat header field "\n"))
 135               ))
 136           header)
 137         ))))
 138
 139 (defun std11-header-string-except (regexp &optional boundary)
 140   "Return string of message header fields not matched by REGEXP.
 141 If BOUNDARY is not nil, it is used as message header separator.
 142 \[std11.el]"
 143   (let ((case-fold-search t))
 144     (save-excursion
 145       (save-restriction
 146         (std11-narrow-to-header boundary)
 147         (goto-char (point-min))
 148         (let (field header)
 149           (while (re-search-forward std11-field-head-regexp nil t)
 150             (setq field
 151                   (buffer-substring (match-beginning 0) (std11-field-end)))
 152             (if (not (string-match regexp field))
 153                 (setq header (concat header field "\n"))
 154               ))
 155           header)
 156         ))))
 157
 158 (defun std11-collect-field-names (&optional boundary)
 159   "Return list of all field-names of the message header in current buffer.
 160 If BOUNDARY is not nil, it is used as message header separator.
 161 \[std11.el]"
 162   (save-excursion
 163     (save-restriction
 164       (std11-narrow-to-header boundary)
 165       (goto-char (point-min))
 166       (let (dest name)
 167         (while (re-search-forward std11-field-head-regexp nil t)
 168           (setq name (buffer-substring-no-properties
 169                       (match-beginning 0)(1- (match-end 0))))
 170           (or (member name dest)
 171               (setq dest (cons name dest))
 172               )
 173           )
 174         dest))))
 175
 176
 177 ;;; @ composer
 178 ;;;
 179
 180 (defun std11-addr-to-string (seq)
 181   "Return string from lexical analyzed list SEQ
 182 represents addr-spec of RFC 822. [std11.el]"
 183   (mapconcat (function
 184               (lambda (token)
 185                 (if (let ((name (car token)))
 186                       (or (eq name 'spaces)
 187                           (eq name 'comment)
 188                           ))
 189                     ""
 190                   (cdr token)
 191                   )))
 192              seq "")
 193   )
 194
 195 (defun std11-address-string (address)
 196   "Return string of address part from parsed ADDRESS of RFC 822.
 197 \[std11.el]"
 198   (cond ((eq (car address) 'group)
 199          (mapconcat (function std11-address-string)
 200                     (car (cdr address))
 201                     ", ")
 202          )
 203         ((eq (car address) 'mailbox)
 204          (let ((addr (nth 1 address)))
 205            (std11-addr-to-string
 206             (if (eq (car addr) 'phrase-route-addr)
 207                 (nth 2 addr)
 208               (cdr addr)
 209               )
 210             )))))
 211
 212 (defun std11-full-name-string (address)
 213   "Return string of full-name part from parsed ADDRESS of RFC 822.
 214 \[std11.el]"
 215   (cond ((eq (car address) 'group)
 216          (mapconcat (function
 217                      (lambda (token)
 218                        (cdr token)
 219                        ))
 220                     (nth 1 address) "")
 221          )
 222         ((eq (car address) 'mailbox)
 223          (let ((addr (nth 1 address))
 224                (comment (nth 2 address))
 225                phrase)
 226            (if (eq (car addr) 'phrase-route-addr)
 227                (setq phrase (mapconcat (function
 228                                         (lambda (token)
 229                                           (cdr token)
 230                                           ))
 231                                        (nth 1 addr) ""))
 232              )
 233            (or phrase comment)
 234            ))))
 235
 236
 237 ;;; @ parser
 238 ;;;
 239
 240 (defun std11-parse-address-string (string)
 241   "Parse STRING as mail address. [std11.el]"
 242   (std11-parse-address (std11-lexical-analyze string))
 243   )
 244
 245 (defun std11-parse-addresses-string (string)
 246   "Parse STRING as mail address list. [std11.el]"
 247   (std11-parse-addresses (std11-lexical-analyze string))
 248   )
 249
 250 (provide 'std11)
 251
 252 (mapcar (function
 253          (lambda (func)
 254            (autoload func "std11-parse")
 255            ))
 256         '(std11-lexical-analyze
 257           std11-parse-address std11-parse-addresses
 258           std11-parse-address-string))
 259
 260
 261 ;;; @ end
 262 ;;;
 263
 264 ;;; std11.el ends here