From: tomo Date: Wed, 11 Mar 1998 13:14:40 +0000 (+0000) Subject: This commit was manufactured by cvs2svn to create tag 'morioka-last- X-Git-Tag: morioka-last-snapshot- X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=22ee988792e67fe97c4d5886d1d587fbe5a65be9;p=elisp%2Fapel.git This commit was manufactured by cvs2svn to create tag 'morioka-last- snapshot-'. --- diff --git a/alist.el b/alist.el deleted file mode 100644 index 288f412..0000000 --- a/alist.el +++ /dev/null @@ -1,101 +0,0 @@ -;;; alist.el --- utility functions about assoc-list - -;; Copyright (C) 1993,1994,1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: -;; $Id: alist.el,v 0.0 1997-02-28 02:18:23 tmorioka Exp $ -;; Keywords: alist - -;; This file is part of SEMI (SEMI is Emacs MIME Interfaces). - -;; 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: - -(defun put-alist (item value alist) - "Modify ALIST to set VALUE to ITEM. -If there is a pair whose car is ITEM, replace its cdr by VALUE. -If there is not such pair, create new pair (ITEM . VALUE) and -return new alist whose car is the new pair and cdr is ALIST. -\[tomo's ELIS like function]" - (let ((pair (assoc item alist))) - (if pair - (progn - (setcdr pair value) - alist) - (cons (cons item value) alist) - ))) - -(defun del-alist (item alist) - "If there is a pair whose key is ITEM, delete it from ALIST. -\[tomo's ELIS emulating function]" - (if (equal item (car (car alist))) - (cdr alist) - (let ((pr alist) - (r (cdr alist)) - ) - (catch 'tag - (while (not (null r)) - (if (equal item (car (car r))) - (progn - (rplacd pr (cdr r)) - (throw 'tag alist))) - (setq pr r) - (setq r (cdr r)) - ) - alist)))) - -(defun set-alist (symbol item value) - "Modify a alist indicated by SYMBOL to set VALUE to ITEM." - (or (boundp symbol) - (set symbol nil) - ) - (set symbol (put-alist item value (symbol-value symbol))) - ) - -(defun remove-alist (symbol item) - "Remove ITEM from the alist indicated by SYMBOL." - (and (boundp symbol) - (set symbol (del-alist item (symbol-value symbol))) - )) - -(defun modify-alist (modifier default) - "Modify alist DEFAULT into alist MODIFIER." - (mapcar (function - (lambda (as) - (setq default (put-alist (car as)(cdr as) default)) - )) - modifier) - default) - -(defun set-modified-alist (sym modifier) - "Modify a value of a symbol SYM into alist MODIFIER. -The symbol SYM should be alist. If it is not bound, -its value regard as nil." - (if (not (boundp sym)) - (set sym nil) - ) - (set sym (modify-alist modifier (eval sym))) - ) - - -;;; @ end -;;; - -(provide 'alist) - -;;; alist.el ends here diff --git a/atype.el b/atype.el deleted file mode 100644 index e82f40f..0000000 --- a/atype.el +++ /dev/null @@ -1,189 +0,0 @@ -;;; atype.el --- atype functions - -;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Id: atype.el,v 6.6 1997/03/10 14:11:23 morioka Exp $ -;; Keywords: atype - -;; This file is part of APEL (A Portable Emacs Library). - -;; 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 'emu) -(require 'alist) - - -;;; @ field unifier -;;; - -(defun field-unifier-for-default (a b) - (let ((ret - (cond ((equal a b) a) - ((null (cdr b)) a) - ((null (cdr a)) b) - ))) - (if ret - (list nil ret nil) - ))) - -(defun field-unify (a b) - (let ((f - (let ((type (car a))) - (and (symbolp type) - (intern (concat "field-unifier-for-" (symbol-name type))) - )))) - (or (fboundp f) - (setq f (function field-unifier-for-default)) - ) - (funcall f a b) - )) - - -;;; @ type unifier -;;; - -(defun assoc-unify (class instance) - (catch 'tag - (let ((cla (copy-alist class)) - (ins (copy-alist instance)) - (r class) - cell aret ret prev rest) - (while r - (setq cell (car r)) - (setq aret (assoc (car cell) ins)) - (if aret - (if (setq ret (field-unify cell aret)) - (progn - (if (car ret) - (setq prev (put-alist (car (car ret)) - (cdr (car ret)) - prev)) - ) - (if (nth 2 ret) - (setq rest (put-alist (car (nth 2 ret)) - (cdr (nth 2 ret)) - rest)) - ) - (setq cla (put-alist (car cell)(cdr (nth 1 ret)) cla)) - (setq ins (del-alist (car cell) ins)) - ) - (throw 'tag nil) - )) - (setq r (cdr r)) - ) - (setq r (copy-alist ins)) - (while r - (setq cell (car r)) - (setq aret (assoc (car cell) cla)) - (if aret - (if (setq ret (field-unify cell aret)) - (progn - (if (car ret) - (setq prev (put-alist (car (car ret)) - (cdr (car ret)) - prev)) - ) - (if (nth 2 ret) - (setq rest (put-alist (car (nth 2 ret)) - (cdr (nth 2 ret)) - rest)) - ) - (setq cla (del-alist (car cell) cla)) - (setq ins (put-alist (car cell)(cdr (nth 1 ret)) ins)) - ) - (throw 'tag nil) - )) - (setq r (cdr r)) - ) - (list prev (append cla ins) rest) - ))) - -(defun get-unified-alist (db al) - (let ((r db) ret) - (catch 'tag - (while r - (if (setq ret (nth 1 (assoc-unify (car r) al))) - (throw 'tag ret) - ) - (setq r (cdr r)) - )))) - - -;;; @ utilities -;;; - -(defun delete-atype (atl al) - (let* ((r atl) ret oal) - (setq oal - (catch 'tag - (while r - (if (setq ret (nth 1 (assoc-unify (car r) al))) - (throw 'tag (car r)) - ) - (setq r (cdr r)) - ))) - (delete oal atl) - )) - -(defun remove-atype (sym al) - (and (boundp sym) - (set sym (delete-atype (eval sym) al)) - )) - -(defun replace-atype (atl old-al new-al) - (let* ((r atl) ret oal) - (if (catch 'tag - (while r - (if (setq ret (nth 1 (assoc-unify (car r) old-al))) - (throw 'tag (rplaca r new-al)) - ) - (setq r (cdr r)) - )) - atl))) - -(defun set-atype (sym al &rest options) - (if (null (boundp sym)) - (set sym al) - (let* ((replacement (memq 'replacement options)) - (ignore-fields (car (cdr (memq 'ignore options)))) - (remove (or (car (cdr (memq 'remove options))) - (let ((ral (copy-alist al))) - (mapcar (function - (lambda (type) - (setq ral (del-alist type ral)) - )) - ignore-fields) - ral))) - ) - (set sym - (or (if replacement - (replace-atype (eval sym) remove al) - ) - (cons al - (delete-atype (eval sym) remove) - ) - ))))) - - -;;; @ end -;;; - -(provide 'atype) - -;;; atype.el ends here diff --git a/emu-20.el b/emu-20.el deleted file mode 100644 index 7c09911..0000000 --- a/emu-20.el +++ /dev/null @@ -1,170 +0,0 @@ -;;; emu-20.el --- emu API implementation for Emacs 20 and XEmacs/mule - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Id: emu-20.el,v 7.18 1997/11/04 08:36:40 morioka Exp $ -;; Keywords: emulation, compatibility, Mule - -;; This file is part of emu. - -;; 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. - -;;; Commentary: - -;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule) -;; or later. - -;;; Code: - -(require 'custom) - - -;;; @ binary access -;;; - -(defmacro as-binary-process (&rest body) - `(let (selective-display ; Disable ^M to nl translation. - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - ,@body)) - -(defmacro as-binary-input-file (&rest body) - `(let ((coding-system-for-read 'binary)) - ,@body)) - -(defmacro as-binary-output-file (&rest body) - `(let ((coding-system-for-write 'binary)) - ,@body)) - -(defun insert-binary-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally', q.v., but don't code conversion. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let ((coding-system-for-read 'binary)) - (insert-file-contents-literally filename visit beg end replace) - )) - -;;; @@ Mule emulating aliases -;;; -;;; You should not use it. - -(defconst *noconv* 'binary - "Coding-system for binary. -This constant is defined to emulate old MULE anything older than MULE -2.3. It is obsolete, so don't use it.") - - -;;; @ MIME charset -;;; - -(defvar mime-charset-coding-system-alist - `,(let ((rest - '((us-ascii . iso-8859-1) - (gb2312 . cn-gb-2312) - (iso-2022-jp-2 . iso-2022-7bit-ss2) - (x-ctext . ctext) - )) - dest) - (while rest - (let ((pair (car rest))) - (or (find-coding-system (car pair)) - (setq dest (cons pair dest)) - )) - (setq rest (cdr rest)) - ) - dest) - "Alist MIME CHARSET vs CODING-SYSTEM. -MIME CHARSET and CODING-SYSTEM must be symbol.") - -(defsubst mime-charset-to-coding-system (charset &optional lbt) - "Return coding-system corresponding with CHARSET. -CHARSET is a symbol whose name is MIME charset. -If optional argument LBT (`unix', `dos' or `mac') is specified, it is -used as line break code type of coding-system." - (if (stringp charset) - (setq charset (intern (downcase charset))) - ) - (let ((ret (assq charset mime-charset-coding-system-alist))) - (if ret - (setq charset (cdr ret)) - )) - (if lbt - (setq charset (intern (format "%s-%s" charset lbt))) - ) - (if (find-coding-system charset) - charset)) - -(defsubst mime-charset-list () - "Return a list of all existing MIME-charset." - (nconc (mapcar (function car) mime-charset-coding-system-alist) - (coding-system-list))) - - -(defvar widget-mime-charset-prompt-value-history nil - "History of input to `widget-mime-charset-prompt-value'.") - -(define-widget 'mime-charset 'coding-system - "A mime-charset." - :format "%{%t%}: %v" - :tag "MIME-charset" - :prompt-history 'widget-mime-charset-prompt-value-history - :prompt-value 'widget-mime-charset-prompt-value - :action 'widget-mime-charset-action) - -(defun widget-mime-charset-prompt-value (widget prompt value unbound) - ;; Read mime-charset from minibuffer. - (intern - (completing-read (format "%s (default %s) " prompt value) - (mapcar (function - (lambda (sym) - (list (symbol-name sym)) - )) - (mime-charset-list))))) - -(defun widget-mime-charset-action (widget &optional event) - ;; Read a mime-charset from the minibuffer. - (let ((answer - (widget-mime-charset-prompt-value - widget - (widget-apply widget :menu-tag-get) - (widget-value widget) - t))) - (widget-value-set widget answer) - (widget-apply widget :notify widget event) - (widget-setup))) - -(defcustom default-mime-charset 'x-ctext - "Default value of MIME-charset. -It is used when MIME-charset is not specified. -It must be symbol." - :group 'i18n - :type 'mime-charset) - -(defsubst detect-mime-charset-region (start end) - "Return MIME charset for region between START and END." - (charsets-to-mime-charset (find-charset-region start end))) - - -;;; @ end -;;; - -(provide 'emu-20) - -;;; emu-20.el ends here diff --git a/mule-caesar.el b/mule-caesar.el deleted file mode 100644 index 785db3a..0000000 --- a/mule-caesar.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; mule-caesar.el --- ROT 13-47 Caesar rotation utility - -;; Copyright (C) 1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: $Id: mule-caesar.el,v 1.3 1997-05-09 02:47:55 morioka Exp $ -;; Keywords: ROT 13-47, caesar, mail, news, text/x-rot13-47 - -;; This file is part of APEL (A Portable Emacs Library). - -;; 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: - -(defun char-to-octet-list (character) - "Return list of octets in code table of graphic character set." - (let* ((code (char-int character)) - (dim (charset-dimension (char-charset code))) - dest) - (while (> dim 0) - (setq dest (cons (logand code 127) dest) - dim (1- dim) - code (lsh code -7)) - ) - dest)) - -(defun mule-caesar-region (start end &optional stride-ascii) - "Caesar rotation of current region. -Optional argument STRIDE-ASCII is rotation-size for Latin alphabet -\(A-Z and a-z). For non-ASCII text, ROT-N/2 will be performed in any -case (N=charset-chars; 94 for 94 or 94x94 graphic character set; 96 -for 96 or 96x96 graphic character set)." - (interactive "r\nP") - (setq stride-ascii (if stride-ascii - (mod stride-ascii 26) - 13)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char start) - (while (< (point)(point-max)) - (let* ((chr (char-after (point))) - (charset (char-charset chr)) - ) - (if (eq charset 'ascii) - (cond ((and (<= ?A chr) (<= chr ?Z)) - (setq chr (+ chr stride-ascii)) - (if (> chr ?Z) - (setq chr (- chr 26)) - ) - (delete-char 1) - (insert chr) - ) - ((and (<= ?a chr) (<= chr ?z)) - (setq chr (+ chr stride-ascii)) - (if (> chr ?z) - (setq chr (- chr 26)) - ) - (delete-char 1) - (insert chr) - ) - (t - (forward-char) - )) - (let* ((stride (lsh (charset-chars charset) -1)) - (ret (mapcar (function - (lambda (octet) - (if (< octet 80) - (+ octet stride) - (- octet stride) - ))) - (char-to-octet-list chr)))) - (delete-char 1) - (insert (make-char (char-charset chr) - (car ret)(car (cdr ret)))) - ))))))) - - -(provide 'mule-caesar) - -;;; mule-caesar.el ends here diff --git a/std11-parse.el b/std11-parse.el deleted file mode 100644 index 10912b0..0000000 --- a/std11-parse.el +++ /dev/null @@ -1,442 +0,0 @@ -;;; std11-parse.el --- STD 11 parser for GNU Emacs - -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: mail, news, RFC 822, STD 11 -;; Version: -;; $Id: std11-parse.el,v 0.15 1996-11-28 19:38:27 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-chars "][()<>@,;:\\<>.\"") -(defconst std11-atom-regexp - (concat "^[^" std11-special-chars 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) - (find (aref str 0) std11-special-chars) - ) - (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)) - (if (and (setq token-value (cdr token)) - (find-non-ascii-charset-string token-value) - ) - (setq token nil) - (std11-ignored-token-p token) - )) - (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) - )))) - - -;;; @ end -;;; - -(provide 'std11-parse) - -;;; std11-parse.el ends here diff --git a/std11.el b/std11.el deleted file mode 100644 index c051a16..0000000 --- a/std11.el +++ /dev/null @@ -1,373 +0,0 @@ -;;; std11.el --- STD 11 functions 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.el,v 0.40 1997-03-03 08:03:06 shuhei-k 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: - -(autoload 'buffer-substring-no-properties "emu") -(autoload 'member "emu") - - -;;; @ field -;;; - -(defconst std11-field-name-regexp "[!-9;-~]+") -(defconst std11-field-head-regexp - (concat "^" std11-field-name-regexp ":")) -(defconst std11-next-field-head-regexp - (concat "\n" std11-field-name-regexp ":")) - -(defun std11-field-end () - "Move to end of field and return this point. [std11.el]" - (if (re-search-forward std11-next-field-head-regexp nil t) - (goto-char (match-beginning 0)) - (if (re-search-forward "^$" nil t) - (goto-char (1- (match-beginning 0))) - (end-of-line) - )) - (point) - ) - -(defun std11-field-body (name &optional boundary) - "Return body of field NAME. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (re-search-forward (concat "^" name ":[ \t]*") nil t) - (buffer-substring-no-properties (match-end 0) (std11-field-end)) - ))))) - -(defun std11-find-field-body (field-names &optional boundary) - "Return the first found field-body specified by FIELD-NAMES -of the message header in current buffer. If BOUNDARY is not nil, it is -used as message header separator. [std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (let ((case-fold-search t) - field-name) - (catch 'tag - (while (setq field-name (car field-names)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) - (throw 'tag - (buffer-substring-no-properties - (match-end 0) (std11-field-end))) - ) - (setq field-names (cdr field-names)) - )))))) - -(defun std11-field-bodies (field-names &optional default-value boundary) - "Return list of each field-bodies of FIELD-NAMES of the message header -in current buffer. If BOUNDARY is not nil, it is used as message -header separator. [std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (let* ((case-fold-search t) - (dest (make-list (length field-names) default-value)) - (s-rest field-names) - (d-rest dest) - field-name) - (while (setq field-name (car s-rest)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t) - (setcar d-rest - (buffer-substring-no-properties - (match-end 0) (std11-field-end))) - ) - (setq s-rest (cdr s-rest) - d-rest (cdr d-rest)) - ) - dest)))) - - -;;; @ unfolding -;;; - -(defun std11-unfold-string (string) - "Unfold STRING as message header field. [std11.el]" - (let ((dest "")) - (while (string-match "\n\\([ \t]\\)" string) - (setq dest (concat dest - (substring string 0 (match-beginning 0)) - (match-string 1 string) - )) - (setq string (substring string (match-end 0))) - ) - (concat dest string) - )) - - -;;; @ header -;;; - -(defun std11-narrow-to-header (&optional boundary) - "Narrow to the message header. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (narrow-to-region - (goto-char (point-min)) - (if (re-search-forward - (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$") - nil t) - (match-beginning 0) - (point-max) - ))) - -(defun std11-header-string (regexp &optional boundary) - "Return string of message header fields matched by REGEXP. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (let ((case-fold-search t)) - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let (field header) - (while (re-search-forward std11-field-head-regexp nil t) - (setq field - (buffer-substring (match-beginning 0) (std11-field-end))) - (if (string-match regexp field) - (setq header (concat header field "\n")) - )) - header) - )))) - -(defun std11-header-string-except (regexp &optional boundary) - "Return string of message header fields not matched by REGEXP. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (let ((case-fold-search t)) - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let (field header) - (while (re-search-forward std11-field-head-regexp nil t) - (setq field - (buffer-substring (match-beginning 0) (std11-field-end))) - (if (not (string-match regexp field)) - (setq header (concat header field "\n")) - )) - header) - )))) - -(defun std11-collect-field-names (&optional boundary) - "Return list of all field-names of the message header in current buffer. -If BOUNDARY is not nil, it is used as message header separator. -\[std11.el]" - (save-excursion - (save-restriction - (std11-narrow-to-header boundary) - (goto-char (point-min)) - (let (dest name) - (while (re-search-forward std11-field-head-regexp nil t) - (setq name (buffer-substring-no-properties - (match-beginning 0)(1- (match-end 0)))) - (or (member name dest) - (setq dest (cons name dest)) - ) - ) - dest)))) - - -;;; @ quoted-string -;;; - -(defun std11-wrap-as-quoted-pairs (string specials) - (let (dest - (i 0) - (b 0) - (len (length string)) - ) - (while (< i len) - (let ((chr (aref string i))) - (if (memq chr specials) - (setq dest (concat dest (substring string b i) "\\") - b i) - )) - (setq i (1+ i)) - ) - (concat dest (substring string b)) - )) - -(defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n)) - -(defun std11-wrap-as-quoted-string (string) - "Wrap STRING as RFC 822 quoted-string. [std11.el]" - (concat "\"" - (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list) - "\"")) - -(defun std11-strip-quoted-pair (string) - "Strip quoted-pairs in STRING. [std11.el]" - (let (dest - (b 0) - (i 0) - (len (length string)) - ) - (while (< i len) - (let ((chr (aref string i))) - (if (eq chr ?\\) - (setq dest (concat dest (substring string b i)) - b (1+ i) - i (+ i 2)) - (setq i (1+ i)) - ))) - (concat dest (substring string b)) - )) - -(defun std11-strip-quoted-string (string) - "Strip quoted-string STRING. [std11.el]" - (let ((len (length string))) - (or (and (>= len 2) - (let ((max (1- len))) - (and (eq (aref string 0) ?\") - (eq (aref string max) ?\") - (std11-strip-quoted-pair (substring string 1 max)) - ))) - string))) - - -;;; @ composer -;;; - -(defun std11-addr-to-string (seq) - "Return string from lexical analyzed list SEQ -represents addr-spec of RFC 822. [std11.el]" - (mapconcat (function - (lambda (token) - (let ((name (car token))) - (cond - ((eq name 'spaces) "") - ((eq name 'comment) "") - ((eq name 'quoted-string) - (concat "\"" (cdr token) "\"")) - (t (cdr token))) - ))) - seq "") - ) - -(defun std11-address-string (address) - "Return string of address part from parsed ADDRESS of RFC 822. -\[std11.el]" - (cond ((eq (car address) 'group) - (mapconcat (function std11-address-string) - (car (cdr address)) - ", ") - ) - ((eq (car address) 'mailbox) - (let ((addr (nth 1 address))) - (std11-addr-to-string - (if (eq (car addr) 'phrase-route-addr) - (nth 2 addr) - (cdr addr) - ) - ))))) - -(defun std11-full-name-string (address) - "Return string of full-name part from parsed ADDRESS of RFC 822. -\[std11.el]" - (cond ((eq (car address) 'group) - (mapconcat (function - (lambda (token) - (cdr token) - )) - (nth 1 address) "") - ) - ((eq (car address) 'mailbox) - (let ((addr (nth 1 address)) - (comment (nth 2 address)) - phrase) - (if (eq (car addr) 'phrase-route-addr) - (setq phrase - (mapconcat - (function - (lambda (token) - (let ((type (car token))) - (cond ((eq type 'quoted-string) - (std11-strip-quoted-pair (cdr token)) - ) - ((eq type 'comment) - (concat - "(" - (std11-strip-quoted-pair (cdr token)) - ")") - ) - (t - (cdr token) - ))))) - (nth 1 addr) "")) - ) - (cond ((> (length phrase) 0) phrase) - (comment (std11-strip-quoted-pair comment)) - ) - )))) - - -;;; @ parser -;;; - -(defun std11-parse-address-string (string) - "Parse STRING as mail address. [std11.el]" - (std11-parse-address (std11-lexical-analyze string)) - ) - -(defun std11-parse-addresses-string (string) - "Parse STRING as mail address list. [std11.el]" - (std11-parse-addresses (std11-lexical-analyze string)) - ) - -(defun std11-extract-address-components (string) - "Extract full name and canonical address from STRING. -Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). -If no name can be extracted, FULL-NAME will be nil. [std11.el]" - (let* ((structure (car (std11-parse-address-string - (std11-unfold-string string)))) - (phrase (std11-full-name-string structure)) - (address (std11-address-string structure)) - ) - (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 -;;; - -;;; std11.el ends here