From 24febc0a2434ea9dbf0b72dbe1f068f1c5c1286e Mon Sep 17 00:00:00 2001 From: akr Date: Fri, 8 May 1998 09:23:41 +0000 Subject: [PATCH] Sync up with flim-1_1_0 to flim-1_2_0. --- ChangeLog | 55 +++++++ FLIM-ELS | 10 +- Makefile | 2 +- README.en | 6 +- eword-decode.el | 23 ++- mailcap.el | 92 +++++++++-- mel-u.el | 2 +- mel.el | 10 +- mime-def.el | 31 +++- std11-parse.el | 461 ------------------------------------------------------- std11.el | 442 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 11 files changed, 617 insertions(+), 517 deletions(-) delete mode 100644 std11-parse.el diff --git a/ChangeLog b/ChangeLog index bc745ad..4f03a87 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +1998-05-08 Tanaka Akira + + * Sync up with flim-1_1_0 to flim-1_2_0. + 1998-05-06 Tanaka Akira * Sync up with flim-1_0_1 to flim-1_1_0. @@ -84,6 +88,57 @@ * Sync up with flim-1_0_0 to flim-1_0_1. +1998-05-06 MORIOKA Tomohiko + + * FLIM: Version 1.2.0 (J-Dþjò) was released.-A + + * README.en (What's FLIM): Delete description about + std11-parse.el; add description about mailcap.el. + +1998-05-06 MORIOKA Tomohiko + + * eword-decode.el (eword-decode-encoded-word-error-handler): New + variable. + (eword-decode-encoded-word-default-error-handler): New function. + (eword-decode-encoded-word): Use + 'eword-decode-encoded-word-error-handler. + +1998-05-06 MORIOKA Tomohiko + + * mailcap.el: Require 'mime-def. + + * mime-def.el (mime-type/subtype-string): New function (moved from + semi/mime-parse.el). + +1998-05-06 MORIOKA Tomohiko + + * std11-parse.el: Abolish std11-parse.el. + + * FLIM-ELS (flim-modules): Abolish 'std11-parse. + + * eword-decode.el: Require 'std11 instead of 'std11-parse. + + * std11.el: Merge std11-parse.el. + +1998-05-06 MORIOKA Tomohiko + + * mime-def.el (mime-temp-directory): Use 'defcustom. + + * mel-u.el: Require 'mime-def instead of 'mel. + + * mime-def.el (mime-temp-directory): New variable (moved from + mel.el). + + * mel.el: Move definition of 'mime-temp-directory to mime-def.el. + +1998-05-06 MORIOKA Tomohiko + + * mailcap.el (mailcap-format-command): New function. + + * mailcap.el (mailcap-look-at-mtext): Don't strip quoted character + again. + + 1998-05-05 MORIOKA Tomohiko * FLIM: Version 1.1.0 (T-Dòji) was released.-A diff --git a/FLIM-ELS b/FLIM-ELS index 7695f0d..e388991 100644 --- a/FLIM-ELS +++ b/FLIM-ELS @@ -4,11 +4,11 @@ ;;; Code: -(setq flim-modules '(std11 std11-parse - mel mel-dl mel-b mel-q mel-u mel-g - mime-def eword-decode eword-encode - mailcap - )) +(setq flim-modules '(std11 + mime-def + mel mel-dl mel-b mel-q mel-u mel-g + eword-decode eword-encode + mailcap)) (if (fboundp 'dynamic-link) (setq flim-modules (cons 'mel-dl flim-modules)) diff --git a/Makefile b/Makefile index 3abdaf6..a40664c 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ # Makefile for FLIM. # -VERSION = 1.1.0 +VERSION = 1.2.0 TAR = tar RM = /bin/rm -f diff --git a/README.en b/README.en index 33a7565..d7c06e1 100644 --- a/README.en +++ b/README.en @@ -7,9 +7,7 @@ What's FLIM representation or encoding. It consists of following modules: - std11: RFC 822/STD 11 parser and utility - std11.el --- main module - std11-parse.el --- parser + std11.el --- STD 11 (RFC 822) parser and utility mime-def.el --- Definitions about MIME format @@ -28,6 +26,8 @@ What's FLIM eword-decode.el --- encoded-word decoder eword-encode.el --- encoded-word encoder + mailcap.el --- mailcap parser and utility + Installation ============ diff --git a/eword-decode.el b/eword-decode.el index 55bf8b5..938d666 100644 --- a/eword-decode.el +++ b/eword-decode.el @@ -32,7 +32,7 @@ ;;; Code: -(require 'std11-parse) +(require 'std11) (require 'mel) (require 'mime-def) @@ -452,7 +452,18 @@ If SEPARATOR is not nil, it is used as header separator." ;;; @ encoded-word decoder ;;; -(defvar eword-warning-face nil "Face used for invalid encoded-word.") +(defvar eword-decode-encoded-word-error-handler + 'eword-decode-encoded-word-default-error-handler) + +(defvar eword-warning-face nil + "Face used for invalid encoded-word.") + +(defun eword-decode-encoded-word-default-error-handler (word signal) + (and (add-text-properties 0 (length word) + (and eword-warning-face + (list 'face eword-warning-face)) + word) + word)) (defun eword-decode-encoded-word (word &optional must-unfold) "Decode WORD if it is an encoded-word. @@ -477,12 +488,8 @@ as a version of Net$cape)." (condition-case err (eword-decode-encoded-text charset encoding text must-unfold) (error - (and - (add-text-properties 0 (length word) - (and eword-warning-face - (list 'face eword-warning-face)) - word) - word))) + (funcall eword-decode-encoded-word-error-handler word err) + )) )) word)) diff --git a/mailcap.el b/mailcap.el index a27be3e..76b3812 100644 --- a/mailcap.el +++ b/mailcap.el @@ -25,6 +25,9 @@ ;;; Code: +(require 'mime-def) + + ;;; @ comment ;;; @@ -99,19 +102,10 @@ ))) (defsubst mailcap-look-at-mtext () - (let ((p0 (point)) - dest) - (while (cond ((mailcap-look-at-qchar) - (setq dest - (concat dest - (buffer-substring p0 (- (point) 2)) - (char-to-string (char-before (point))) - ) - p0 (point)) - ) - ((mailcap-look-at-schar) - t))) - (concat dest (buffer-substring p0 (point))) + (let ((beg (point))) + (while (or (mailcap-look-at-qchar) + (mailcap-look-at-schar))) + (buffer-substring beg (point)) )) @@ -191,6 +185,78 @@ order. Otherwise result is not sorted." (mailcap-parse-buffer (current-buffer) order) )) +(defun mailcap-format-command (mtext situation) + "Return formated command string from MTEXT and SITUATION. + +MTEXT is a command text of mailcap specification, such as +view-command. + +SITUATION is an association-list about information of entity. Its key +may be: + + 'type primary media-type + 'subtype media-subtype + 'filename filename + STRING parameter of Content-Type field" + (let ((i 0) + (len (length mtext)) + (p 0) + dest) + (while (< i len) + (let ((chr (aref mtext i))) + (cond ((eq chr ?%) + (setq i (1+ i) + chr (aref mtext i)) + (cond ((eq chr ?s) + (let ((file (cdr (assq 'filename situation)))) + (if (null file) + (error "'filename is not specified in situation.") + (setq dest (concat dest + (substring mtext p (1- i)) + file) + i (1+ i) + p i) + ))) + ((eq chr ?t) + (let ((type (or (mime-type/subtype-string + (cdr (assq 'type situation)) + (cdr (assq 'subtype situation))) + "text/plain"))) + (setq dest (concat dest + (substring mtext p (1- i)) + type) + i (1+ i) + p i) + )) + ((eq chr ?\{) + (setq i (1+ i)) + (if (not (string-match "}" mtext i)) + (error "parse error!!!") + (let* ((me (match-end 0)) + (attribute (substring mtext i (1- me))) + (parameter (cdr (assoc attribute situation)))) + (if (null parameter) + (error "\"%s\" is not specified in situation." + attribute) + (setq dest (concat dest + (substring mtext p (- i 2)) + parameter) + i me + p i) + ) + ))) + (t (error "Invalid sequence `%%%c'." chr)) + )) + ((eq chr ?\\) + (setq dest (concat dest (substring mtext p i)) + p (1+ i) + i (+ i 2)) + ) + (t (setq i (1+ i))) + ))) + (concat dest (substring mtext p)) + )) + ;;; @ end ;;; diff --git a/mel-u.el b/mel-u.el index 0c49f62..46e9efa 100644 --- a/mel-u.el +++ b/mel-u.el @@ -26,7 +26,7 @@ ;;; Code: (require 'emu) -(require 'mel) +(require 'mime-def) ;;; @ variables diff --git a/mel.el b/mel.el index be8a26f..01efaf2 100644 --- a/mel.el +++ b/mel.el @@ -28,20 +28,12 @@ (require 'emu) -(defconst mel-version "7.4") +(defconst mel-version "7.5") ;;; @ variable ;;; -(defvar mime-temp-directory (or (getenv "MIME_TMP_DIR") - (getenv "TM_TMP_DIR") - (getenv "TMPDIR") - (getenv "TMP") - (getenv "TEMP") - "/tmp/") - "*Directory for temporary files.") - (defvar base64-dl-module (and (fboundp 'dynamic-link) (let ((path (expand-file-name "base64.so" exec-directory))) diff --git a/mime-def.el b/mime-def.el index 3b3156a..40c5270 100644 --- a/mime-def.el +++ b/mime-def.el @@ -25,7 +25,11 @@ ;;; Code: (defconst mime-spadework-module-version-string - "FLIM-FLAM 1.1.0 - \"$B4Z9H2V(B\" 4.0R4.0/14.0") + "FLIM-FLAM 1.2.0 - \"$BEm2V(B\" 2.5R6.0/10.0") + + +;;; @ variables +;;; (require 'custom) @@ -37,6 +41,20 @@ (custom-handle-keyword 'default-mime-charset :group 'mime 'custom-variable) +(defcustom mime-temp-directory (or (getenv "MIME_TMP_DIR") + (getenv "TM_TMP_DIR") + (getenv "TMPDIR") + (getenv "TMP") + (getenv "TEMP") + "/tmp/") + "*Directory for temporary files." + :group 'mime + :type 'directory) + + +;;; @ required functions +;;; + (unless (fboundp 'butlast) (defun butlast (x &optional n) "Returns a copy of LIST with the last N elements removed." @@ -81,6 +99,17 @@ "][" quoted-printable-hex-chars "]")) +;;; @ utility +;;; + +(defsubst mime-type/subtype-string (type &optional subtype) + "Return type/subtype string from TYPE and SUBTYPE." + (if type + (if subtype + (format "%s/%s" type subtype) + (format "%s" type)))) + + ;;; @ end ;;; diff --git a/std11-parse.el b/std11-parse.el deleted file mode 100644 index 3abf0f1..0000000 --- a/std11-parse.el +++ /dev/null @@ -1,461 +0,0 @@ -;;; std11-parse.el --- STD 11 parser for GNU Emacs - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: mail, news, RFC 822, STD 11 -;; Version: $Id: std11-parse.el,v 1.1 1998-04-10 14:55:56 morioka Exp $ - -;; This file is part of MU (Message Utilities). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'std11) -(require 'emu) - - -;;; @ lexical analyze -;;; - -(defconst std11-space-chars " \t\n") -(defconst std11-spaces-regexp (` (, (concat "[" std11-space-chars "]+")))) -(defconst std11-special-char-list '(?\] ?\[ - ?\( ?\) ?< ?> ?@ - ?, ?\; ?: ?\\ ?\" - ?.)) -(defconst std11-atom-regexp - (` (, (concat "^[^" std11-special-char-list std11-space-chars "]+")))) - -(defun std11-analyze-spaces (string) - (if (and (string-match std11-spaces-regexp string) - (= (match-beginning 0) 0)) - (let ((end (match-end 0))) - (cons (cons 'spaces (substring string 0 end)) - (substring string end) - )))) - -(defun std11-analyze-special (str) - (if (and (> (length str) 0) - (memq (aref str 0) std11-special-char-list)) - (cons (cons 'specials (substring str 0 1)) - (substring str 1) - ))) - -(defun std11-analyze-atom (str) - (if (string-match std11-atom-regexp str) - (let ((end (match-end 0))) - (cons (cons 'atom (substring str 0 end)) - (substring str end) - )))) - -(defun std11-check-enclosure (str open close &optional recursive from) - (let ((len (length str)) - (i (or from 0)) - ) - (if (and (> len i) - (eq (aref str i) open)) - (let (p chr) - (setq i (1+ i)) - (catch 'tag - (while (< i len) - (setq chr (aref str i)) - (cond ((eq chr ?\\) - (setq i (1+ i)) - (if (>= i len) - (throw 'tag nil) - ) - (setq i (1+ i)) - ) - ((eq chr close) - (throw 'tag (1+ i)) - ) - ((eq chr open) - (if (and recursive - (setq p (std11-check-enclosure - str open close recursive i)) - ) - (setq i p) - (throw 'tag nil) - )) - (t - (setq i (1+ i)) - )) - )))))) - -(defun std11-analyze-quoted-string (str) - (let ((p (std11-check-enclosure str ?\" ?\"))) - (if p - (cons (cons 'quoted-string (substring str 1 (1- p))) - (substring str p)) - ))) - -(defun std11-analyze-domain-literal (str) - (let ((p (std11-check-enclosure str ?\[ ?\]))) - (if p - (cons (cons 'domain-literal (substring str 1 (1- p))) - (substring str p)) - ))) - -(defun std11-analyze-comment (str) - (let ((p (std11-check-enclosure str ?\( ?\) t))) - (if p - (cons (cons 'comment (substring str 1 (1- p))) - (substring str p)) - ))) - -(defun std11-lexical-analyze (str) - (let (dest ret) - (while (not (string-equal str "")) - (setq ret - (or (std11-analyze-quoted-string str) - (std11-analyze-domain-literal str) - (std11-analyze-comment str) - (std11-analyze-spaces str) - (std11-analyze-special str) - (std11-analyze-atom str) - '((error) . "") - )) - (setq dest (cons (car ret) dest)) - (setq str (cdr ret)) - ) - (nreverse dest) - )) - - -;;; @ parser -;;; - -(defun std11-ignored-token-p (token) - (let ((type (car token))) - (or (eq type 'spaces)(eq type 'comment)) - )) - -(defun std11-parse-token (lal) - (let (token itl) - (while (and lal - (progn - (setq token (car lal)) - (std11-ignored-token-p token) - )) - (setq lal (cdr lal)) - (setq itl (cons token itl)) - ) - (cons (nreverse (cons token itl)) - (cdr lal)) - )) - -(defun std11-parse-ascii-token (lal) - (let (token itl parsed token-value) - (while (and lal - (setq token (car lal)) - (or (std11-ignored-token-p token) - (if (and (setq token-value (cdr token)) - (find-non-ascii-charset-string token-value) - ) - (setq token nil) - ))) - (setq lal (cdr lal)) - (setq itl (cons token itl)) - ) - (if (and token - (setq parsed (nreverse (cons token itl))) - ) - (cons parsed (cdr lal)) - ))) - -(defun std11-parse-token-or-comment (lal) - (let (token itl) - (while (and lal - (progn - (setq token (car lal)) - (eq (car token) 'spaces) - )) - (setq lal (cdr lal)) - (setq itl (cons token itl)) - ) - (cons (nreverse (cons token itl)) - (cdr lal)) - )) - -(defun std11-parse-word (lal) - (let ((ret (std11-parse-ascii-token lal))) - (if ret - (let ((elt (car ret)) - (rest (cdr ret)) - ) - (if (or (assq 'atom elt) - (assq 'quoted-string elt)) - (cons (cons 'word elt) rest) - ))))) - -(defun std11-parse-word-or-comment (lal) - (let ((ret (std11-parse-token-or-comment lal))) - (if ret - (let ((elt (car ret)) - (rest (cdr ret)) - ) - (cond ((or (assq 'atom elt) - (assq 'quoted-string elt)) - (cons (cons 'word elt) rest) - ) - ((assq 'comment elt) - (cons (cons 'comment-word elt) rest) - )) - )))) - -(defun std11-parse-phrase (lal) - (let (ret phrase) - (while (setq ret (std11-parse-word-or-comment lal)) - (setq phrase (append phrase (cdr (car ret)))) - (setq lal (cdr ret)) - ) - (if phrase - (cons (cons 'phrase phrase) lal) - ))) - -(defun std11-parse-local-part (lal) - (let ((ret (std11-parse-word lal))) - (if ret - (let ((local-part (cdr (car ret))) dot) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq dot (car ret)) - (string-equal (cdr (assq 'specials dot)) ".") - (setq ret (std11-parse-word (cdr ret))) - (setq local-part - (append local-part dot (cdr (car ret))) - ) - (setq lal (cdr ret)) - )) - (cons (cons 'local-part local-part) lal) - )))) - -(defun std11-parse-sub-domain (lal) - (let ((ret (std11-parse-ascii-token lal))) - (if ret - (let ((sub-domain (car ret))) - (if (or (assq 'atom sub-domain) - (assq 'domain-literal sub-domain) - ) - (cons (cons 'sub-domain sub-domain) - (cdr ret) - ) - ))))) - -(defun std11-parse-domain (lal) - (let ((ret (std11-parse-sub-domain lal))) - (if ret - (let ((domain (cdr (car ret))) dot) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq dot (car ret)) - (string-equal (cdr (assq 'specials dot)) ".") - (setq ret (std11-parse-sub-domain (cdr ret))) - (setq domain - (append domain dot (cdr (car ret))) - ) - (setq lal (cdr ret)) - )) - (cons (cons 'domain domain) lal) - )))) - -(defun std11-parse-at-domain (lal) - (let ((ret (std11-parse-ascii-token lal)) at-sign) - (if (and ret - (setq at-sign (car ret)) - (string-equal (cdr (assq 'specials at-sign)) "@") - (setq ret (std11-parse-domain (cdr ret))) - ) - (cons (cons 'at-domain (append at-sign (cdr (car ret)))) - (cdr ret)) - ))) - -(defun std11-parse-addr-spec (lal) - (let ((ret (std11-parse-local-part lal)) - addr) - (if (and ret - (prog1 - (setq addr (cdr (car ret))) - (setq lal (cdr ret)) - (and (setq ret (std11-parse-at-domain lal)) - (setq addr (append addr (cdr (car ret)))) - (setq lal (cdr ret)) - ))) - (cons (cons 'addr-spec addr) lal) - ))) - -(defun std11-parse-route (lal) - (let ((ret (std11-parse-at-domain lal)) - route comma colon) - (if (and ret - (progn - (setq route (cdr (car ret))) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq comma (car ret)) - (string-equal (cdr (assq 'specials comma)) ",") - (setq ret (std11-parse-at-domain (cdr ret))) - ) - (setq route (append route comma (cdr (car ret)))) - (setq lal (cdr ret)) - ) - (and (setq ret (std11-parse-ascii-token lal)) - (setq colon (car ret)) - (string-equal (cdr (assq 'specials colon)) ":") - (setq route (append route colon)) - ) - )) - (cons (cons 'route route) - (cdr ret) - ) - ))) - -(defun std11-parse-route-addr (lal) - (let ((ret (std11-parse-ascii-token lal)) - < route addr-spec >) - (if (and ret - (setq < (car ret)) - (string-equal (cdr (assq 'specials <)) "<") - (setq lal (cdr ret)) - (progn (and (setq ret (std11-parse-route lal)) - (setq route (cdr (car ret))) - (setq lal (cdr ret)) - ) - (setq ret (std11-parse-addr-spec lal)) - ) - (setq addr-spec (cdr (car ret))) - (setq lal (cdr ret)) - (setq ret (std11-parse-ascii-token lal)) - (setq > (car ret)) - (string-equal (cdr (assq 'specials >)) ">") - ) - (cons (cons 'route-addr (append route addr-spec)) - (cdr ret) - ) - ))) - -(defun std11-parse-phrase-route-addr (lal) - (let ((ret (std11-parse-phrase lal)) phrase) - (if ret - (progn - (setq phrase (cdr (car ret))) - (setq lal (cdr ret)) - )) - (if (setq ret (std11-parse-route-addr lal)) - (cons (list 'phrase-route-addr - phrase - (cdr (car ret))) - (cdr ret)) - ))) - -(defun std11-parse-mailbox (lal) - (let ((ret (or (std11-parse-phrase-route-addr lal) - (std11-parse-addr-spec lal))) - mbox comment) - (if (and ret - (prog1 - (setq mbox (car ret)) - (setq lal (cdr ret)) - (if (and (setq ret (std11-parse-token-or-comment lal)) - (setq comment (cdr (assq 'comment (car ret)))) - ) - (setq lal (cdr ret)) - ))) - (cons (list 'mailbox mbox comment) - lal) - ))) - -(defun std11-parse-group (lal) - (let ((ret (std11-parse-phrase lal)) - phrase colon comma mbox semicolon) - (if (and ret - (setq phrase (cdr (car ret))) - (setq lal (cdr ret)) - (setq ret (std11-parse-ascii-token lal)) - (setq colon (car ret)) - (string-equal (cdr (assq 'specials colon)) ":") - (setq lal (cdr ret)) - (progn - (and (setq ret (std11-parse-mailbox lal)) - (setq mbox (list (car ret))) - (setq lal (cdr ret)) - (progn - (while (and (setq ret (std11-parse-ascii-token lal)) - (setq comma (car ret)) - (string-equal - (cdr (assq 'specials comma)) ",") - (setq lal (cdr ret)) - (setq ret (std11-parse-mailbox lal)) - (setq mbox (cons (car ret) mbox)) - (setq lal (cdr ret)) - ) - ))) - (and (setq ret (std11-parse-ascii-token lal)) - (setq semicolon (car ret)) - (string-equal (cdr (assq 'specials semicolon)) ";") - ))) - (cons (list 'group phrase (nreverse mbox)) - (cdr ret) - ) - ))) - -(defun std11-parse-address (lal) - (or (std11-parse-group lal) - (std11-parse-mailbox lal) - )) - -(defun std11-parse-addresses (lal) - (let ((ret (std11-parse-address lal))) - (if ret - (let ((dest (list (car ret)))) - (setq lal (cdr ret)) - (while (and (setq ret (std11-parse-ascii-token lal)) - (string-equal (cdr (assq 'specials (car ret))) ",") - (setq ret (std11-parse-address (cdr ret))) - ) - (setq dest (cons (car ret) dest)) - (setq lal (cdr ret)) - ) - (nreverse dest) - )))) - -(defun std11-parse-msg-id (lal) - (let ((ret (std11-parse-ascii-token lal)) - < addr-spec >) - (if (and ret - (setq < (car ret)) - (string-equal (cdr (assq 'specials <)) "<") - (setq lal (cdr ret)) - (setq ret (std11-parse-addr-spec lal)) - (setq addr-spec (car ret)) - (setq lal (cdr ret)) - (setq ret (std11-parse-ascii-token lal)) - (setq > (car ret)) - (string-equal (cdr (assq 'specials >)) ">") - ) - (cons (cons 'msg-id (cdr addr-spec)) - (cdr ret)) - ))) - - -;;; @ end -;;; - -(provide 'std11-parse) - -;;; std11-parse.el ends here diff --git a/std11.el b/std11.el index 1a70c5e..f36830d 100644 --- a/std11.el +++ b/std11.el @@ -27,10 +27,6 @@ (autoload 'buffer-substring-no-properties "emu") (autoload 'member "emu") -(eval-when-compile - (provide 'std11) - (require 'std11-parse)) - ;;; @ field ;;; @@ -258,6 +254,430 @@ If BOUNDARY is not nil, it is used as message header separator. string))) +;;; @ lexical analyze +;;; + +(defconst std11-space-chars " \t\n") +(defconst std11-spaces-regexp (` (, (concat "[" std11-space-chars "]+")))) +(defconst std11-special-char-list '(?\] ?\[ + ?\( ?\) ?< ?> ?@ + ?, ?\; ?: ?\\ ?\" + ?.)) +(defconst std11-atom-regexp + (` (, (concat "^[^" std11-special-char-list std11-space-chars "]+")))) + +(defun std11-analyze-spaces (string) + (if (and (string-match std11-spaces-regexp string) + (= (match-beginning 0) 0)) + (let ((end (match-end 0))) + (cons (cons 'spaces (substring string 0 end)) + (substring string end) + )))) + +(defun std11-analyze-special (str) + (if (and (> (length str) 0) + (memq (aref str 0) std11-special-char-list)) + (cons (cons 'specials (substring str 0 1)) + (substring str 1) + ))) + +(defun std11-analyze-atom (str) + (if (string-match std11-atom-regexp str) + (let ((end (match-end 0))) + (cons (cons 'atom (substring str 0 end)) + (substring str end) + )))) + +(defun std11-check-enclosure (str open close &optional recursive from) + (let ((len (length str)) + (i (or from 0)) + ) + (if (and (> len i) + (eq (aref str i) open)) + (let (p chr) + (setq i (1+ i)) + (catch 'tag + (while (< i len) + (setq chr (aref str i)) + (cond ((eq chr ?\\) + (setq i (1+ i)) + (if (>= i len) + (throw 'tag nil) + ) + (setq i (1+ i)) + ) + ((eq chr close) + (throw 'tag (1+ i)) + ) + ((eq chr open) + (if (and recursive + (setq p (std11-check-enclosure + str open close recursive i)) + ) + (setq i p) + (throw 'tag nil) + )) + (t + (setq i (1+ i)) + )) + )))))) + +(defun std11-analyze-quoted-string (str) + (let ((p (std11-check-enclosure str ?\" ?\"))) + (if p + (cons (cons 'quoted-string (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-analyze-domain-literal (str) + (let ((p (std11-check-enclosure str ?\[ ?\]))) + (if p + (cons (cons 'domain-literal (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-analyze-comment (str) + (let ((p (std11-check-enclosure str ?\( ?\) t))) + (if p + (cons (cons 'comment (substring str 1 (1- p))) + (substring str p)) + ))) + +(defun std11-lexical-analyze (str) + (let (dest ret) + (while (not (string-equal str "")) + (setq ret + (or (std11-analyze-quoted-string str) + (std11-analyze-domain-literal str) + (std11-analyze-comment str) + (std11-analyze-spaces str) + (std11-analyze-special str) + (std11-analyze-atom str) + '((error) . "") + )) + (setq dest (cons (car ret) dest)) + (setq str (cdr ret)) + ) + (nreverse dest) + )) + + +;;; @ parser +;;; + +(defun std11-ignored-token-p (token) + (let ((type (car token))) + (or (eq type 'spaces)(eq type 'comment)) + )) + +(defun std11-parse-token (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (std11-ignored-token-p token) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-ascii-token (lal) + (let (token itl parsed token-value) + (while (and lal + (setq token (car lal)) + (or (std11-ignored-token-p token) + (if (and (setq token-value (cdr token)) + (find-non-ascii-charset-string token-value) + ) + (setq token nil) + ))) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (if (and token + (setq parsed (nreverse (cons token itl))) + ) + (cons parsed (cdr lal)) + ))) + +(defun std11-parse-token-or-comment (lal) + (let (token itl) + (while (and lal + (progn + (setq token (car lal)) + (eq (car token) 'spaces) + )) + (setq lal (cdr lal)) + (setq itl (cons token itl)) + ) + (cons (nreverse (cons token itl)) + (cdr lal)) + )) + +(defun std11-parse-word (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (if (or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ))))) + +(defun std11-parse-word-or-comment (lal) + (let ((ret (std11-parse-token-or-comment lal))) + (if ret + (let ((elt (car ret)) + (rest (cdr ret)) + ) + (cond ((or (assq 'atom elt) + (assq 'quoted-string elt)) + (cons (cons 'word elt) rest) + ) + ((assq 'comment elt) + (cons (cons 'comment-word elt) rest) + )) + )))) + +(defun std11-parse-phrase (lal) + (let (ret phrase) + (while (setq ret (std11-parse-word-or-comment lal)) + (setq phrase (append phrase (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (if phrase + (cons (cons 'phrase phrase) lal) + ))) + +(defun std11-parse-local-part (lal) + (let ((ret (std11-parse-word lal))) + (if ret + (let ((local-part (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-word (cdr ret))) + (setq local-part + (append local-part dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'local-part local-part) lal) + )))) + +(defun std11-parse-sub-domain (lal) + (let ((ret (std11-parse-ascii-token lal))) + (if ret + (let ((sub-domain (car ret))) + (if (or (assq 'atom sub-domain) + (assq 'domain-literal sub-domain) + ) + (cons (cons 'sub-domain sub-domain) + (cdr ret) + ) + ))))) + +(defun std11-parse-domain (lal) + (let ((ret (std11-parse-sub-domain lal))) + (if ret + (let ((domain (cdr (car ret))) dot) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq dot (car ret)) + (string-equal (cdr (assq 'specials dot)) ".") + (setq ret (std11-parse-sub-domain (cdr ret))) + (setq domain + (append domain dot (cdr (car ret))) + ) + (setq lal (cdr ret)) + )) + (cons (cons 'domain domain) lal) + )))) + +(defun std11-parse-at-domain (lal) + (let ((ret (std11-parse-ascii-token lal)) at-sign) + (if (and ret + (setq at-sign (car ret)) + (string-equal (cdr (assq 'specials at-sign)) "@") + (setq ret (std11-parse-domain (cdr ret))) + ) + (cons (cons 'at-domain (append at-sign (cdr (car ret)))) + (cdr ret)) + ))) + +(defun std11-parse-addr-spec (lal) + (let ((ret (std11-parse-local-part lal)) + addr) + (if (and ret + (prog1 + (setq addr (cdr (car ret))) + (setq lal (cdr ret)) + (and (setq ret (std11-parse-at-domain lal)) + (setq addr (append addr (cdr (car ret)))) + (setq lal (cdr ret)) + ))) + (cons (cons 'addr-spec addr) lal) + ))) + +(defun std11-parse-route (lal) + (let ((ret (std11-parse-at-domain lal)) + route comma colon) + (if (and ret + (progn + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal (cdr (assq 'specials comma)) ",") + (setq ret (std11-parse-at-domain (cdr ret))) + ) + (setq route (append route comma (cdr (car ret)))) + (setq lal (cdr ret)) + ) + (and (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq route (append route colon)) + ) + )) + (cons (cons 'route route) + (cdr ret) + ) + ))) + +(defun std11-parse-route-addr (lal) + (let ((ret (std11-parse-ascii-token lal)) + < route addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (progn (and (setq ret (std11-parse-route lal)) + (setq route (cdr (car ret))) + (setq lal (cdr ret)) + ) + (setq ret (std11-parse-addr-spec lal)) + ) + (setq addr-spec (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'route-addr (append route addr-spec)) + (cdr ret) + ) + ))) + +(defun std11-parse-phrase-route-addr (lal) + (let ((ret (std11-parse-phrase lal)) phrase) + (if ret + (progn + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + )) + (if (setq ret (std11-parse-route-addr lal)) + (cons (list 'phrase-route-addr + phrase + (cdr (car ret))) + (cdr ret)) + ))) + +(defun std11-parse-mailbox (lal) + (let ((ret (or (std11-parse-phrase-route-addr lal) + (std11-parse-addr-spec lal))) + mbox comment) + (if (and ret + (prog1 + (setq mbox (car ret)) + (setq lal (cdr ret)) + (if (and (setq ret (std11-parse-token-or-comment lal)) + (setq comment (cdr (assq 'comment (car ret)))) + ) + (setq lal (cdr ret)) + ))) + (cons (list 'mailbox mbox comment) + lal) + ))) + +(defun std11-parse-group (lal) + (let ((ret (std11-parse-phrase lal)) + phrase colon comma mbox semicolon) + (if (and ret + (setq phrase (cdr (car ret))) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq colon (car ret)) + (string-equal (cdr (assq 'specials colon)) ":") + (setq lal (cdr ret)) + (progn + (and (setq ret (std11-parse-mailbox lal)) + (setq mbox (list (car ret))) + (setq lal (cdr ret)) + (progn + (while (and (setq ret (std11-parse-ascii-token lal)) + (setq comma (car ret)) + (string-equal + (cdr (assq 'specials comma)) ",") + (setq lal (cdr ret)) + (setq ret (std11-parse-mailbox lal)) + (setq mbox (cons (car ret) mbox)) + (setq lal (cdr ret)) + ) + ))) + (and (setq ret (std11-parse-ascii-token lal)) + (setq semicolon (car ret)) + (string-equal (cdr (assq 'specials semicolon)) ";") + ))) + (cons (list 'group phrase (nreverse mbox)) + (cdr ret) + ) + ))) + +(defun std11-parse-address (lal) + (or (std11-parse-group lal) + (std11-parse-mailbox lal) + )) + +(defun std11-parse-addresses (lal) + (let ((ret (std11-parse-address lal))) + (if ret + (let ((dest (list (car ret)))) + (setq lal (cdr ret)) + (while (and (setq ret (std11-parse-ascii-token lal)) + (string-equal (cdr (assq 'specials (car ret))) ",") + (setq ret (std11-parse-address (cdr ret))) + ) + (setq dest (cons (car ret) dest)) + (setq lal (cdr ret)) + ) + (nreverse dest) + )))) + +(defun std11-parse-msg-id (lal) + (let ((ret (std11-parse-ascii-token lal)) + < addr-spec >) + (if (and ret + (setq < (car ret)) + (string-equal (cdr (assq 'specials <)) "<") + (setq lal (cdr ret)) + (setq ret (std11-parse-addr-spec lal)) + (setq addr-spec (car ret)) + (setq lal (cdr ret)) + (setq ret (std11-parse-ascii-token lal)) + (setq > (car ret)) + (string-equal (cdr (assq 'specials >)) ">") + ) + (cons (cons 'msg-id (cdr addr-spec)) + (cdr ret)) + ))) + + ;;; @ composer ;;; @@ -376,7 +796,7 @@ represents addr-spec of RFC 822. [std11.el]" dest)) -;;; @ parser +;;; @ parser with lexical analyzer ;;; (defun std11-parse-address-string (string) @@ -401,18 +821,10 @@ If no name can be extracted, FULL-NAME will be nil. [std11.el]" (list phrase address) )) -(provide 'std11) - -(mapcar (function - (lambda (func) - (autoload func "std11-parse") - )) - '(std11-lexical-analyze - std11-parse-address std11-parse-addresses - std11-parse-address-string)) - ;;; @ end ;;; +(provide 'std11) + ;;; std11.el ends here -- 1.7.10.4