From: tomo Date: Wed, 11 Mar 1998 12:28:12 +0000 (+0000) Subject: This commit was manufactured by cvs2svn to create tag 'tm-7_101'. X-Git-Tag: tm-7_101 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=fcb12da7b6d5b4c6b45aee236dd89e9d483311dd;p=elisp%2Fapel.git This commit was manufactured by cvs2svn to create tag 'tm-7_101'. --- diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 index b46cbe7..0000000 --- a/ChangeLog +++ /dev/null @@ -1,76 +0,0 @@ -1997-03-14 MORIOKA Tomohiko - - * APEL: Version 3.2 was released. - -Fri Mar 14 09:54:04 1997 MORIOKA Tomohiko - - * file-detect.el (get-latest-path): Check directory is exist or not. - -Fri Mar 14 09:25:15 1997 MORIOKA Tomohiko - - * APEL-ELS: Add install.el. - -Fri Mar 14 07:24:37 1997 MORIOKA Tomohiko - - * Makefile, APEL-MK, APEL-CFG: New file. - -1997-03-10 MORIOKA Tomohiko - - * atype.el (field-unify): fixed. - -1997-03-10 MORIOKA Tomohiko - - * filename.el (filename-filters): Use `exec-installed-p' instead - of `file-installed-p' to search "kakasi". - -1997-03-10 MORIOKA Tomohiko - - * file-detect.el (module-installed-p): Use function - `exec-installed-p'. - - * file-detect.el (exec-suffix-list): New variable. - (exec-installed-p): New function. - -1997-03-04 MORIOKA Tomohiko - - * APEL-ELS (apel-modules): Add filename.el. - - * APEL-ELS: Initial revision - -1997-03-04 MORIOKA Tomohiko - - * filename.el (filename-replacement-alist): Don't use function - `string-to-char-list' and `expand-char-ranges'; Don't require - tl-str. - (filename-special-filter): Use function `assoc-if' instead of - `ASSOC'; Require cl instead of tl-list. - (poly-funcall): New inline-function; copied from tl-list.el. - -1997-03-03 MORIOKA Tomohiko - - * atype.el: Alias `fetch-field', `fetch-field-value', `put-field' - and `delete-field' were abolished. - - Don't require tl-str and tl-list. - - Require alist. - - (field-unify): Don't use function `symbol-concat'. - (assoc-unify): Use function `assoc' directly; use function - `put-alist' directly; use function `del-alist' directly. - - * atype.el: Function `put-fields' was abolished. - - * atype.el: tl-atype.el was renamed to atype.el. - -1997-03-03 MORIOKA Tomohiko - - * atype.el: tl-atype.el was renamed to atype.el. - -1997-03-03 MORIOKA Tomohiko - - * file-detect.el (file-installed-p): Fixed DOC-string. - -1997-02-28 Tomohiko Morioka - - * alist.el: New module; separated from tl-list.el. diff --git a/Makefile b/Makefile deleted file mode 100644 index c2677c2..0000000 --- a/Makefile +++ /dev/null @@ -1,30 +0,0 @@ -# -# $Id: Makefile,v 0.0 1997/03/14 07:24:37 morioka Exp morioka $ -# - -EMACS = emacs -FLAGS = -batch -q -no-site-file -l APEL-MK - -PREFIX = - -FILES = emu/Makefile emu/EMU-MK emu/EMU-CFG emu/EMU-ELS \ - emu/*.el emu/README.?? \ - apel/Makefile apel/APEL-MK apel/APEL-CFG apel/APEL-ELS \ - apel/*.el - -TARFILE = apel-0.1.tar - - -elc: - $(EMACS) $(FLAGS) -f compile-apel - -install: elc - $(EMACS) $(FLAGS) -f install-apel $(PREFIX) - - -clean: - -rm *.elc - - -tar: - cd ..; tar cvf $(TARFILE) $(FILES); gzip -best $(TARFILE) 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/file-detect.el b/file-detect.el deleted file mode 100644 index 1abd8c5..0000000 --- a/file-detect.el +++ /dev/null @@ -1,163 +0,0 @@ -;;; file-detect.el --- Emacs Lisp file detection utility - -;; Copyright (C) 1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Version: -;; $Id: file-detect.el,v 3.2 1997/03/14 09:54:04 morioka Exp $ -;; Keywords: install, module - -;; This file is part of tl (Tiny 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: - -(defvar default-load-path load-path) - -(defun add-path (path &rest options) - "Add PATH to `load-path' if it exists under `default-load-path' -directories and it does not exist in `load-path'. - -You can use following PATH styles: - load-path relative: \"PATH/\" - (it is searched from `defaul-load-path') - home directory relative: \"~/PATH/\" \"~USER/PATH/\" - absolute path: \"/HOO/BAR/BAZ/\" - -You can specify following OPTIONS: - 'all-paths search from `load-path' - instead of `default-load-path' - 'append add PATH to the last of `load-path' - -\[file-detect.el]" - (let ((rest (if (memq 'all-paths options) - load-path - default-load-path)) - p) - (if (and (catch 'tag - (while rest - (setq p (expand-file-name path (car rest))) - (if (file-directory-p p) - (throw 'tag p) - ) - (setq rest (cdr rest)) - )) - (not (member p load-path)) - ) - (setq load-path - (if (memq 'append options) - (append load-path (list p)) - (cons p load-path) - )) - ))) - -(defun add-latest-path (pattern &optional all-paths) - "Add latest path matched by PATTERN to `load-path' -if it exists under `default-load-path' directories -and it does not exist in `load-path'. - -If optional argument ALL-PATHS is specified, it is searched from all -of load-path instead of default-load-path. [file-detect.el]" - (let ((path (get-latest-path pattern all-paths))) - (if path - (add-to-list 'load-path path) - ))) - -(defun get-latest-path (pat &optional all-paths) - "Return latest directory in default-load-path -which is matched to regexp PAT. -If optional argument ALL-PATHS is specified, -it is searched from all of load-path instead of default-load-path." - (catch 'tag - (let ((paths (if all-paths - load-path - default-load-path)) - dir) - (while (setq dir (car paths)) - (if (and (file-exists-p dir) - (file-directory-p dir) - ) - (let ((files (sort (directory-files dir t pat t) - (function file-newer-than-file-p))) - file) - (while (setq file (car files)) - (if (file-directory-p file) - (throw 'tag file) - ) - (setq files (cdr files)) - ))) - (setq paths (cdr paths)) - )))) - -(defun file-installed-p (file &optional paths) - "Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `load-path' is used. [file-detect.el]" - (if (null paths) - (setq paths load-path) - ) - (catch 'tag - (let (path) - (while paths - (setq path (expand-file-name file (car paths))) - (if (file-exists-p path) - (throw 'tag path) - ) - (setq paths (cdr paths)) - )))) - -(defvar exec-suffix-list '("") - "*List of suffixes for executable.") - -(defun exec-installed-p (file &optional paths suffixes) - "Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `exec-path' is used. -If suffixes is omitted, `exec-suffix-list' is used. [file-detect.el]" - (or paths - (setq paths exec-path) - ) - (or suffixes - (setq suffixes exec-suffix-list) - ) - (catch 'tag - (while paths - (let ((stem (expand-file-name file (car paths))) - (sufs suffixes) - ) - (while sufs - (let ((file (concat stem (car sufs)))) - (if (file-exists-p file) - (throw 'tag file) - )) - (setq sufs (cdr sufs)) - )) - (setq paths (cdr paths)) - ))) - -(defun module-installed-p (module &optional paths) - "Return t if module is provided or exists in PATHS. -If PATHS is omitted, `load-path' is used. [file-detect.el]" - (or (featurep module) - (exec-installed-p (symbol-name module) load-path '(".elc" ".el")) - )) - - -;;; @ end -;;; - -(provide 'file-detect) - -;;; file-detect.el ends here diff --git a/filename.el b/filename.el deleted file mode 100644 index e2a59b4..0000000 --- a/filename.el +++ /dev/null @@ -1,150 +0,0 @@ -;;; filename.el --- file name filter - -;; Copyright (C) 1996,1997 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Version: $Id: filename.el,v 1.4 1997/03/10 13:53:38 morioka Exp $ -;; Keywords: file name, string - -;; 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 'cl) -(require 'file-detect) - -(defsubst poly-funcall (functions arg) - (while functions - (setq arg (funcall (car functions) arg) - functions (cdr functions)) - ) - arg) - - -;;; @ variables -;;; - -(defvar filename-limit-length 21) - -(defvar filename-replacement-alist - '(((?\ ?\t) . "_") - ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/ - ?: ?; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_") - (filename-control-p . "") - )) - -(defvar filename-filters - (nconc - (and (exec-installed-p "kakasi") - '(filename-japanese-to-roman-string) - ) - '(filename-special-filter - filename-eliminate-top-low-lines - filename-canonicalize-low-lines - filename-maybe-truncate-by-size - filename-eliminate-bottom-low-lines - ))) - - -;;; @ filters -;;; - -(defun filename-japanese-to-roman-string (str) - (save-excursion - (set-buffer (get-buffer-create " *temp kakasi*")) - (erase-buffer) - (insert str) - (call-process-region (point-min)(point-max) "kakasi" t t t - "-Ha" "-Ka" "-Ja" "-Ea" "-ka") - (buffer-string) - )) - -(defun filename-control-p (character) - (let ((code (char-int character))) - (or (< code 32)(= code 127)) - )) - -(defun filename-special-filter (string) - (let (dest - (i 0) - (len (length string)) - (b 0) - ) - (while (< i len) - (let* ((chr (sref string i)) - (ret (assoc-if (function - (lambda (key) - (if (functionp key) - (funcall key chr) - (memq chr key) - ))) - filename-replacement-alist)) - ) - (if ret - (setq dest (concat dest (substring string b i)(cdr ret)) - i (+ i (char-length chr)) - b i) - (setq i (+ i (char-length chr))) - ))) - (concat dest (substring string b)) - )) - -(defun filename-eliminate-top-low-lines (string) - (if (string-match "^_+" string) - (substring string (match-end 0)) - string)) - -(defun filename-canonicalize-low-lines (string) - (let (dest) - (while (string-match "__+" string) - (setq dest (concat dest (substring string 0 (1+ (match-beginning 0))))) - (setq string (substring string (match-end 0))) - ) - (concat dest string) - )) - -(defun filename-maybe-truncate-by-size (string) - (if (and (> (length string) filename-limit-length) - (string-match "_" string filename-limit-length) - ) - (substring string 0 (match-beginning 0)) - string)) - -(defun filename-eliminate-bottom-low-lines (string) - (if (string-match "_+$" string) - (substring string 0 (match-beginning 0)) - string)) - - -;;; @ interface -;;; - -(defun replace-as-filename (string) - "Return safety filename from STRING. [filename.el]" - (and string - (poly-funcall filename-filters string) - )) - - -;;; @ end -;;; - -(provide 'filename) - -;;; filename.el ends here diff --git a/install.el b/install.el deleted file mode 100644 index b5db039..0000000 --- a/install.el +++ /dev/null @@ -1,204 +0,0 @@ -;;; install.el --- Emacs Lisp package install utility - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Created: 1996/8/18 -;; Version: $Id: install.el,v 3.1 1996/11/26 19:55:55 shuhei-k Exp $ -;; Keywords: install - -;; This file is part of tl (Tiny 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 'file-detect) - -;;; @ compile Emacs Lisp files -;;; - -(defun compile-elisp-module (module &optional path every-time) - (setq module (expand-file-name (symbol-name module) path)) - (let ((el-file (concat module ".el")) - (elc-file (concat module ".elc")) - ) - (if (or every-time - (file-newer-than-file-p el-file elc-file)) - (byte-compile-file el-file) - ) - )) - -(defun compile-elisp-modules (modules &optional path every-time) - (mapcar (function - (lambda (module) - (compile-elisp-module module path every-time) - )) - modules)) - - -;;; @ install files -;;; - -(defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4)) - -(defun install-file (file src dest &optional move overwrite) - (let ((src-file (expand-file-name file src))) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name file dest))) - (if (and (file-exists-p full-path) overwrite) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (if move - (catch 'tag - (while (and (file-exists-p src-file) - (file-writable-p src-file)) - (condition-case err - (progn - (delete-file src-file) - (throw 'tag nil) - ) - (error (princ (format "%s\n" (nth 1 err)))) - )))) - (princ (format "%s -> %s\n" file dest)) - )) - )) - -(defun install-files (files src dest &optional move overwrite) - (or (file-exists-p dest) - (make-directory dest t) - ) - (mapcar (function (lambda (file) - (install-file file src dest move overwrite) - )) - files)) - - -;;; @@ install Emacs Lisp files -;;; - -(defun install-elisp-module (module src dest) - (let (el-file elc-file) - (let ((name (symbol-name module))) - (setq el-file (concat name ".el")) - (setq elc-file (concat name ".elc")) - ) - (let ((src-file (expand-file-name el-file src))) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name el-file dest))) - (if (file-exists-p full-path) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (princ (format "%s -> %s\n" el-file dest)) - )) - (setq src-file (expand-file-name elc-file src)) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name elc-file dest))) - (if (file-exists-p full-path) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (catch 'tag - (while (file-exists-p src-file) - (condition-case err - (progn - (delete-file src-file) - (throw 'tag nil) - ) - (error (princ (format "%s\n" (nth 1 err)))) - ))) - (princ (format "%s -> %s\n" elc-file dest)) - )) - ))) - -(defun install-elisp-modules (modules src dest) - (or (file-exists-p dest) - (make-directory dest t) - ) - (mapcar (function (lambda (module) - (install-elisp-module module src dest) - )) - modules)) - - -;;; @ detect install path -;;; - -(defvar install-prefix - (if (or running-emacs-18 running-xemacs) - (expand-file-name "../../.." exec-directory) - (expand-file-name "../../../.." data-directory) - )) ; install to shared directory (maybe "/usr/local") - -(defvar install-elisp-prefix - (if (>= emacs-major-version 19) - "site-lisp" - "local.lisp")) - -(defun install-detect-elisp-directory (&optional prefix elisp-prefix - allow-version-specific) - (or prefix - (setq prefix install-prefix) - ) - (or elisp-prefix - (setq elisp-prefix install-elisp-prefix) - ) - (or - (catch 'tag - (let ((rest default-load-path) - dir) - (while (setq dir (car rest)) - (if (string-match - (concat "^" - (expand-file-name (concat ".*/" elisp-prefix) prefix) - "$") - dir) - (if (or allow-version-specific - (not (string-match (format "%d\\.%d" - emacs-major-version - emacs-minor-version) dir)) - ) - (throw 'tag dir) - )) - (setq rest (cdr rest)) - ))) - (expand-file-name (concat - (if running-emacs-19_29-or-later - "share/" - "lib/") - (cond ((boundp 'NEMACS) "nemacs/") - ((boundp 'MULE) "mule/") - (running-xemacs - (if (featurep 'mule) - "xmule/" - "xemacs/")) - (t "emacs/")) - elisp-prefix) prefix) - )) - -(defvar install-default-elisp-directory - (install-detect-elisp-directory)) - - -;;; @ end -;;; - -(provide 'install) - -;;; install.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