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.19 1996-08-28 21:01:41 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-find-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-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 ;;; @ parser
 178 ;;;
 179
 180 (provide 'std11)
 181
 182 (mapcar (function
 183          (lambda (func)
 184            (autoload func "std11-parse")
 185            ))
 186         '(std11-lexical-analyze
 187           std11-parse-address std11-parse-addresses
 188           std11-parse-address-string))
 189
 190 (defun std11-parse-address-string (string)
 191   "Parse STRING as mail address. [std11.el]"
 192   (std11-parse-address (std11-lexical-analyze string))
 193   )
 194
 195 (defun std11-addr-to-string (seq)
 196   (mapconcat (function
 197               (lambda (token)
 198                 (if (eq (car token) 'spaces)
 199                     ""
 200                   (cdr token)
 201                   )))
 202              seq "")
 203   )
 204
 205 (defun std11-address-string (address)
 206   (cond ((eq (car address) 'group)
 207          (mapconcat (function std11-address-string)
 208                     (car (cdr address))
 209                     ", ")
 210          )
 211         ((eq (car address) 'mailbox)
 212          (let ((addr (nth 1 address)))
 213            (std11-addr-to-string
 214             (if (eq (car addr) 'phrase-route-addr)
 215                 (nth 2 addr)
 216               (cdr addr)
 217               )
 218             )))))
 219
 220
 221 ;;; @ end
 222 ;;;
 223
 224 ;;; std11.el ends here