std11.el

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