From: handa Date: Sat, 12 Aug 2000 02:45:46 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: semi21-2000-08-12 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=7e4f44ee0153373a38525796247aa6fd250ab644;p=elisp%2Flemi.git *** empty log message *** --- diff --git a/emacs-lisp/alist.el b/emacs-lisp/alist.el new file mode 100644 index 0000000..4ac3169 --- /dev/null +++ b/emacs-lisp/alist.el @@ -0,0 +1,120 @@ +;;; alist.el --- utility functions about association-list + +;; Copyright (C) 1993,1994,1995,1996,1998,2000 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: alist + +;; 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: + +;;;###autoload +(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) + ))) + +;;;###autoload +(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)))) + +;;;###autoload +(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))) + ) + +;;;###autoload +(defun remove-alist (symbol item) + "Remove ITEM from the alist indicated by SYMBOL." + (and (boundp symbol) + (set symbol (del-alist item (symbol-value symbol))) + )) + +;;;###autoload +(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) + +;;;###autoload +(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))) + ) + + +;;; @ association-vector-list +;;; + +;;;###autoload +(defun vassoc (key avlist) + "Search AVLIST for a vector whose first element is equal to KEY. +See also `assoc'." + (let (v) + (while (and (setq v (car avlist)) + (not (equal key (aref v 0)))) + (setq avlist (cdr avlist))) + v)) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'alist) (require 'apel-ver)) + +;;; alist.el ends here diff --git a/emacs-lisp/calist.el b/emacs-lisp/calist.el new file mode 100644 index 0000000..fbef680 --- /dev/null +++ b/emacs-lisp/calist.el @@ -0,0 +1,331 @@ +;;; calist.el --- Condition functions + +;; Copyright (C) 1998 Free Software Foundation, Inc. +;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN. +;; Licensed to the Free Software Foundation. + +;; Author: MORIOKA Tomohiko +;; Keywords: condition, alist, tree + +;; 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: + +(eval-when-compile (require 'cl)) + +(require 'alist) + +(defvar calist-package-alist nil) +(defvar calist-field-match-method-obarray nil) + +(defun find-calist-package (name) + "Return a calist-package by NAME." + (cdr (assq name calist-package-alist))) + +(defun define-calist-field-match-method (field-type function) + "Set field-match-method for FIELD-TYPE to FUNCTION." + (fset (intern (symbol-name field-type) calist-field-match-method-obarray) + function)) + +(defun use-calist-package (name) + "Make the symbols of package NAME accessible in the current package." + (mapatoms (lambda (sym) + (if (intern-soft (symbol-name sym) + calist-field-match-method-obarray) + (signal 'conflict-of-calist-symbol + (list (format "Conflict of symbol %s"))) + (if (fboundp sym) + (define-calist-field-match-method + sym (symbol-function sym)) + ))) + (find-calist-package name))) + +(defun make-calist-package (name &optional use) + "Create a new calist-package." + (let ((calist-field-match-method-obarray (make-vector 7 0))) + (set-alist 'calist-package-alist name + calist-field-match-method-obarray) + (use-calist-package (or use 'standard)) + calist-field-match-method-obarray)) + +(defun in-calist-package (name) + "Set the current calist-package to a new or existing calist-package." + (setq calist-field-match-method-obarray + (or (find-calist-package name) + (make-calist-package name)))) + +(in-calist-package 'standard) + +(defun calist-default-field-match-method (calist field-type field-value) + (let ((s-field (assoc field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist) + ) + ((eq field-value t) + calist) + ((equal (cdr s-field) field-value) + calist)))) + +(define-calist-field-match-method t (function calist-default-field-match-method)) + +(defsubst calist-field-match-method (field-type) + (symbol-function + (or (intern-soft (if (symbolp field-type) + (symbol-name field-type) + field-type) + calist-field-match-method-obarray) + (intern-soft "t" calist-field-match-method-obarray)))) + +(defsubst calist-field-match (calist field-type field-value) + (funcall (calist-field-match-method field-type) + calist field-type field-value)) + +(defun ctree-match-calist (rule-tree alist) + "Return matched condition-alist if ALIST matches RULE-TREE." + (if (null rule-tree) + alist + (let ((type (car rule-tree)) + (choices (cdr rule-tree)) + default) + (catch 'tag + (while choices + (let* ((choice (car choices)) + (choice-value (car choice))) + (if (eq choice-value t) + (setq default choice) + (let ((ret-alist (calist-field-match alist type (car choice)))) + (if ret-alist + (throw 'tag + (if (cdr choice) + (ctree-match-calist (cdr choice) ret-alist) + ret-alist)) + )))) + (setq choices (cdr choices))) + (if default + (let ((ret-alist (calist-field-match alist type t))) + (if ret-alist + (if (cdr default) + (ctree-match-calist (cdr default) ret-alist) + ret-alist)))) + )))) + +(defun ctree-match-calist-partially (rule-tree alist) + "Return matched condition-alist if ALIST matches RULE-TREE." + (if (null rule-tree) + alist + (let ((type (car rule-tree)) + (choices (cdr rule-tree)) + default) + (catch 'tag + (while choices + (let* ((choice (car choices)) + (choice-value (car choice))) + (if (eq choice-value t) + (setq default choice) + (let ((ret-alist (calist-field-match alist type (car choice)))) + (if ret-alist + (throw 'tag + (if (cdr choice) + (ctree-match-calist-partially + (cdr choice) ret-alist) + ret-alist)) + )))) + (setq choices (cdr choices))) + (if default + (let ((ret-alist (calist-field-match alist type t))) + (if ret-alist + (if (cdr default) + (ctree-match-calist-partially (cdr default) ret-alist) + ret-alist))) + (calist-field-match alist type t)) + )))) + +(defun ctree-find-calist (rule-tree alist &optional all) + "Return list of condition-alist which matches ALIST in RULE-TREE. +If optional argument ALL is specified, default rules are not ignored +even if other rules are matched for ALIST." + (if (null rule-tree) + (list alist) + (let ((type (car rule-tree)) + (choices (cdr rule-tree)) + default dest) + (while choices + (let* ((choice (car choices)) + (choice-value (car choice))) + (if (eq choice-value t) + (setq default choice) + (let ((ret-alist (calist-field-match alist type (car choice)))) + (if ret-alist + (if (cdr choice) + (let ((ret (ctree-find-calist + (cdr choice) ret-alist all))) + (while ret + (let ((elt (car ret))) + (or (member elt dest) + (setq dest (cons elt dest)) + )) + (setq ret (cdr ret)) + )) + (or (member ret-alist dest) + (setq dest (cons ret-alist dest))) + ))))) + (setq choices (cdr choices))) + (or (and (not all) dest) + (if default + (let ((ret-alist (calist-field-match alist type t))) + (if ret-alist + (if (cdr default) + (let ((ret (ctree-find-calist + (cdr default) ret-alist all))) + (while ret + (let ((elt (car ret))) + (or (member elt dest) + (setq dest (cons elt dest)) + )) + (setq ret (cdr ret)) + )) + (or (member ret-alist dest) + (setq dest (cons ret-alist dest))) + )))) + ) + dest))) + +(defun calist-to-ctree (calist) + "Convert condition-alist CALIST to condition-tree." + (if calist + (let* ((cell (car calist))) + (cons (car cell) + (list (cons (cdr cell) + (calist-to-ctree (cdr calist)) + )))))) + +(defun ctree-add-calist-strictly (ctree calist) + "Add condition CALIST to condition-tree CTREE without default clause." + (cond ((null calist) ctree) + ((null ctree) + (calist-to-ctree calist) + ) + (t + (let* ((type (car ctree)) + (values (cdr ctree)) + (ret (assoc type calist))) + (if ret + (catch 'tag + (while values + (let ((cell (car values))) + (if (equal (car cell)(cdr ret)) + (throw 'tag + (setcdr cell + (ctree-add-calist-strictly + (cdr cell) + (delete ret (copy-alist calist))) + )))) + (setq values (cdr values))) + (setcdr ctree (cons (cons (cdr ret) + (calist-to-ctree + (delete ret (copy-alist calist)))) + (cdr ctree))) + ) + (catch 'tag + (while values + (let ((cell (car values))) + (setcdr cell + (ctree-add-calist-strictly (cdr cell) calist)) + ) + (setq values (cdr values)))) + ) + ctree)))) + +(defun ctree-add-calist-with-default (ctree calist) + "Add condition CALIST to condition-tree CTREE with default clause." + (cond ((null calist) ctree) + ((null ctree) + (let* ((cell (car calist)) + (type (car cell)) + (value (cdr cell))) + (cons type + (list (list t) + (cons value (calist-to-ctree (cdr calist))))) + )) + (t + (let* ((type (car ctree)) + (values (cdr ctree)) + (ret (assoc type calist))) + (if ret + (catch 'tag + (while values + (let ((cell (car values))) + (if (equal (car cell)(cdr ret)) + (throw 'tag + (setcdr cell + (ctree-add-calist-with-default + (cdr cell) + (delete ret (copy-alist calist))) + )))) + (setq values (cdr values))) + (if (assq t (cdr ctree)) + (setcdr ctree + (cons (cons (cdr ret) + (calist-to-ctree + (delete ret (copy-alist calist)))) + (cdr ctree))) + (setcdr ctree + (list* (list t) + (cons (cdr ret) + (calist-to-ctree + (delete ret (copy-alist calist)))) + (cdr ctree))) + )) + (catch 'tag + (while values + (let ((cell (car values))) + (setcdr cell + (ctree-add-calist-with-default (cdr cell) calist)) + ) + (setq values (cdr values))) + (let ((cell (assq t (cdr ctree)))) + (if cell + (setcdr cell + (ctree-add-calist-with-default (cdr cell) + calist)) + (let ((elt (cons t (calist-to-ctree calist)))) + (or (member elt (cdr ctree)) + (setcdr ctree (cons elt (cdr ctree))) + )) + ))) + ) + ctree)))) + +(defun ctree-set-calist-strictly (ctree-var calist) + "Set condition CALIST in CTREE-VAR without default clause." + (set ctree-var + (ctree-add-calist-strictly (symbol-value ctree-var) calist))) + +(defun ctree-set-calist-with-default (ctree-var calist) + "Set condition CALIST to CTREE-VAR with default clause." + (set ctree-var + (ctree-add-calist-with-default (symbol-value ctree-var) calist))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'calist) (require 'apel-ver)) + +;;; calist.el ends here diff --git a/emacs-lisp/filename.el b/emacs-lisp/filename.el new file mode 100644 index 0000000..ea11042 --- /dev/null +++ b/emacs-lisp/filename.el @@ -0,0 +1,153 @@ +;;; filename.el --- file name filter + +;; Copyright (C) 1996,1997 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; Version: $Id: filename.el,v 1.1.2.1 2000/02/03 02:26:43 tomo 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) ; for backward compatibility. +(require 'poe) ; functionp. +(require 'poem) ; char-int, and char-length. +(require 'path-util) + +(defsubst poly-funcall (functions argument) + "Apply initial ARGUMENT to sequence of FUNCTIONS. +FUNCTIONS is list of functions. + +(poly-funcall '(f1 f2 .. fn) arg) is as same as +(fn .. (f2 (f1 arg)) ..). + +For example, (poly-funcall '(car number-to-string) '(100)) returns +\"100\"." + (while functions + (setq argument (funcall (car functions) argument) + functions (cdr functions))) + argument) + + +;;; @ variables +;;; + +(defvar filename-limit-length 21 "Limit size of file-name.") + +(defvar filename-replacement-alist + '(((?\ ?\t) . "_") + ((?! ?\" ?# ?$ ?% ?& ?' ?\( ?\) ?* ?/ + ?: ?\; ?< ?> ?? ?\[ ?\\ ?\] ?` ?{ ?| ?}) . "_") + (filename-control-p . "")) + "Alist list of characters vs. string as replacement. +List of characters represents characters not allowed as file-name.") + +(defvar filename-filters + (let ((filters '(filename-special-filter + filename-eliminate-top-low-lines + filename-canonicalize-low-lines + filename-maybe-truncate-by-size + filename-eliminate-bottom-low-lines + ))) + (if (exec-installed-p "kakasi") + (cons 'filename-japanese-to-roman-string filters) + filters)) + "List of functions for file-name filter.") + + +;;; @ 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 ((len (length string)) + (b 0)(i 0) + (dest "")) + (while (< i len) + (let ((chr (sref string i)) + (lst filename-replacement-alist) + ret) + (while (and lst (not ret)) + (if (if (functionp (car (car lst))) + (setq ret (funcall (car (car lst)) chr)) + (setq ret (memq chr (car (car lst))))) + t ; quit this loop. + (setq lst (cdr lst)))) + (if ret + (setq dest (concat dest (substring string b i)(cdr (car lst))) + 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. +It refers variable `filename-filters' and default filters refers +`filename-limit-length', `filename-replacement-alist'." + (and string + (poly-funcall filename-filters string))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'filename) (require 'apel-ver)) + +;;; filename.el ends here diff --git a/emacs-lisp/install.el b/emacs-lisp/install.el new file mode 100644 index 0000000..2d9dd41 --- /dev/null +++ b/emacs-lisp/install.el @@ -0,0 +1,200 @@ +;;; install.el --- Emacs Lisp package install utility + +;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1996/08/18 +;; Keywords: install, byte-compile, directory detection + +;; 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 'poe) ; make-directory for v18 +(require 'path-util) ; default-load-path + + +;;; @ 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)) ; 0644 + +(defun install-file (file src dest &optional move overwrite just-print) + (if just-print + (princ (format "%s -> %s\n" file dest)) + (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 just-print) + (or (file-exists-p dest) + (make-directory dest t)) + (mapcar + (function + (lambda (file) + (install-file file src dest move overwrite just-print))) + files)) + + +;;; @@ install Emacs Lisp files +;;; + +(defun install-elisp-module (module src dest &optional just-print) + (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 (not (file-exists-p src-file)) + nil + (if just-print + (princ (format "%s -> %s\n" el-file dest)) + (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 (not (file-exists-p src-file)) + nil + (if just-print + (princ (format "%s -> %s\n" elc-file dest)) + (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 &optional just-print) + (or (file-exists-p dest) + (make-directory dest t)) + (mapcar + (function + (lambda (module) + (install-elisp-module module src dest just-print))) + modules)) + + +;;; @ detect install path +;;; + +;; install to shared directory (maybe "/usr/local") +(defvar install-prefix + (if (or (<= emacs-major-version 18) + (featurep 'xemacs) + (and (boundp 'system-configuration-options) ; 19.29 or later + (string= system-configuration-options "NT"))) ; for Meadow + (expand-file-name "../../.." exec-directory) + (expand-file-name "../../../.." data-directory))) + +(defvar install-elisp-prefix + (if (>= emacs-major-version 19) + "site-lisp" + ;; v18 does not have standard site directory. + "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) + (regexp (concat "^" + (expand-file-name (concat ".*/" elisp-prefix) + prefix) + "/?$"))) + (while rest + (if (string-match regexp (car rest)) + (if (or allow-version-specific + (not (string-match (format "/%d\\.%d" + emacs-major-version + emacs-minor-version) + (car rest)))) + (throw 'tag (car rest)))) + (setq rest (cdr rest))))) + (expand-file-name (concat (if (and (not (featurep 'xemacs)) + (or (>= emacs-major-version 20) + (and (= emacs-major-version 19) + (> emacs-minor-version 28)))) + "share/" + "lib/") + (cond + ((featurep 'xemacs) + (if (featurep 'mule) + "xmule/" + "xemacs/")) + ;; unfortunately, unofficial mule based on + ;; 19.29 and later use "emacs/" by default. + ((boundp 'MULE) "mule/") + ((boundp 'NEMACS) "nemacs/") + (t "emacs/")) + elisp-prefix) + prefix))) + +(defvar install-default-elisp-directory + (install-detect-elisp-directory)) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'install) (require 'apel-ver)) + +;;; install.el ends here diff --git a/emacs-lisp/path-util.el b/emacs-lisp/path-util.el new file mode 100644 index 0000000..d774642 --- /dev/null +++ b/emacs-lisp/path-util.el @@ -0,0 +1,203 @@ +;;; path-util.el --- Emacs Lisp file detection utility + +;; Copyright (C) 1996,1997,1999 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Keywords: file detection, install, module + +;; 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 'poe) + +(defvar default-load-path load-path + "*Base of `load-path'. +It is used as default value of target path to search file or +subdirectory under load-path.") + +;;;###autoload +(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'" + (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) + )) + ))) + +;;;###autoload +(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." + (let ((path (get-latest-path pattern all-paths))) + (if path + (add-to-list 'load-path path) + ))) + +;;;###autoload +(defun get-latest-path (pattern &optional all-paths) + "Return latest directory in default-load-path +which is matched to regexp PATTERN. +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 pattern 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)) + )))) + +;;;###autoload +(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." + (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)) + )))) + +;;;###autoload +(defvar exec-suffix-list '("") + "*List of suffixes for executable.") + +;;;###autoload +(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." + (or paths + (setq paths exec-path) + ) + (or suffixes + (setq suffixes exec-suffix-list) + ) + (let (files) + (catch 'tag + (while suffixes + (let ((suf (car suffixes))) + (if (and (not (string= suf "")) + (string-match (concat (regexp-quote suf) "$") file)) + (progn + (setq files (list file)) + (throw 'tag nil) + ) + (setq files (cons (concat file suf) files)) + ) + (setq suffixes (cdr suffixes)) + ))) + (setq files (nreverse files)) + (catch 'tag + (while paths + (let ((path (car paths)) + (files files) + ) + (while files + (setq file (expand-file-name (car files) path)) + (if (file-executable-p file) + (throw 'tag file) + ) + (setq files (cdr files)) + ) + (setq paths (cdr paths)) + ))))) + +;;;###autoload +(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." + (or (featurep module) + (let ((file (symbol-name module))) + (or paths + (setq paths load-path) + ) + (catch 'tag + (while paths + (let ((stem (expand-file-name file (car paths))) + (sufs '(".elc" ".el")) + ) + (while sufs + (let ((file (concat stem (car sufs)))) + (if (file-exists-p file) + (throw 'tag file) + )) + (setq sufs (cdr sufs)) + )) + (setq paths (cdr paths)) + ))))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'path-util) (require 'apel-ver)) + +;;; path-util.el ends here diff --git a/mail/smtp.el b/mail/smtp.el new file mode 100644 index 0000000..27a0b99 --- /dev/null +++ b/mail/smtp.el @@ -0,0 +1,412 @@ +;;; smtp.el --- basic functions to send mail with SMTP server + +;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. + +;; Author: Tomoji Kagatani +;; Simon Leinen (ESMTP support) +;; Shuhei KOBAYASHI +;; Keywords: SMTP, mail + +;; This file is part of FLIM (Faithful Library about Internet Message). + +;; 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 this program; 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 'poe) +(require 'poem) +(require 'pcustom) +(require 'mail-utils) ; mail-strip-quoted-names + +(eval-when-compile (require 'cl)) ; push + +(defgroup smtp nil + "SMTP protocol for sending mail." + :group 'mail) + +(defcustom smtp-default-server nil + "*Specify default SMTP server." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server) + "*The name of the host running SMTP server. It can also be a function +called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS." + :type '(choice (string :tag "Name") + (function :tag "Function")) + :group 'smtp) + +(defcustom smtp-service "smtp" + "*SMTP service port number. \"smtp\" or 25." + :type '(choice (integer :tag "25" 25) + (string :tag "smtp" "smtp")) + :group 'smtp) + +(defcustom smtp-use-8bitmime t + "*If non-nil, use ESMTP 8BITMIME if available." + :type 'boolean + :group 'smtp) + +(defcustom smtp-local-domain nil + "*Local domain name without a host name. +If the function (system-name) returns the full internet address, +don't define this value." + :type '(choice (const nil) string) + :group 'smtp) + +(defcustom smtp-debug-info nil + "*smtp debug info printout. messages and process buffer." + :type 'boolean + :group 'smtp) + +(defcustom smtp-notify-success nil + "*If non-nil, notification for successful mail delivery is returned + to user (RFC1891)." + :type 'boolean + :group 'smtp) + +(defvar smtp-read-point nil) + +(defun smtp-make-fqdn () + "Return user's fully qualified domain name." + (let ((system-name (system-name))) + (cond + (smtp-local-domain + (concat system-name "." smtp-local-domain)) + ((string-match "[^.]\\.[^.]" system-name) + system-name) + (t + (error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly."))))) + +(defun smtp-via-smtp (sender recipients smtp-text-buffer) + (let ((server (if (functionp smtp-server) + (funcall smtp-server sender recipients) + smtp-server)) + process response extensions) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of SMTP session to %s*" server))) + (erase-buffer) + (make-local-variable 'smtp-read-point) + (setq smtp-read-point (point-min)) + + (unwind-protect + (catch 'done + (setq process (open-network-stream-as-binary + "SMTP" (current-buffer) server smtp-service)) + (or process (throw 'done nil)) + + (set-process-filter process 'smtp-process-filter) + + ;; Greeting + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))) + + ;; EHLO + (smtp-send-command process + (format "EHLO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (progn + ;; HELO + (smtp-send-command process + (format "HELO %s" (smtp-make-fqdn))) + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response))))) + (let ((extension-lines (cdr (cdr response)))) + (while extension-lines + (push (intern (downcase (substring (car extension-lines) 4))) + extensions) + (setq extension-lines (cdr extension-lines))))) + + ;; ONEX --- One message transaction only (sendmail extension?) + (if (or (memq 'onex extensions) + (memq 'xone extensions)) + (progn + (smtp-send-command process "ONEX") + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))))) + + ;; VERB --- Verbose (sendmail extension?) + (if (and smtp-debug-info + (or (memq 'verb extensions) + (memq 'xvrb extensions))) + (progn + (smtp-send-command process "VERB") + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))))) + + ;; XUSR --- Initial (user) submission (sendmail extension?) + (if (memq 'xusr extensions) + (progn + (smtp-send-command process "XUSR") + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))))) + + ;; MAIL FROM: + (smtp-send-command + process + (format "MAIL FROM:<%s>%s%s" + sender + ;; SIZE --- Message Size Declaration (RFC1870) + (if (memq 'size extensions) + (format " SIZE=%d" + (save-excursion + (set-buffer smtp-text-buffer) + (+ (- (point-max) (point-min)) + ;; Add one byte for each change-of-line + ;; because or CR-LF representation: + (count-lines (point-min) (point-max)) + ;; For some reason, an empty line is + ;; added to the message. Maybe this + ;; is a bug, but it can't hurt to add + ;; those two bytes anyway: + 2))) + "") + ;; 8BITMIME --- 8bit-MIMEtransport (RFC1652) + (if (and (memq '8bitmime extensions) + smtp-use-8bitmime) + " BODY=8BITMIME" + ""))) + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))) + + ;; RCPT TO: + (while recipients + (smtp-send-command process + (format + (if smtp-notify-success + "RCPT TO:<%s> NOTIFY=SUCCESS" + "RCPT TO:<%s>") + (car recipients))) + (setq recipients (cdr recipients)) + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response))))) + + ;; DATA + (smtp-send-command process "DATA") + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))) + + ;; Mail contents + (smtp-send-data process smtp-text-buffer) + + ;; DATA end "." + (smtp-send-command process ".") + (setq response (smtp-read-response process)) + (if (or (null (car response)) + (not (integerp (car response))) + (>= (car response) 400)) + (throw 'done (car (cdr response)))) + + t) + + (if (and process + (eq (process-status process) 'open)) + (progn + ;; QUIT + (smtp-send-command process "QUIT") + (smtp-read-response process) + (delete-process process))))))) + +(defun smtp-process-filter (process output) + (save-excursion + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert output))) + +(defun smtp-read-response (process) + (let ((case-fold-search nil) + (response-strings nil) + (response-continue t) + (return-value '(nil ())) + match-end) + + (while response-continue + (goto-char smtp-read-point) + (while (not (search-forward "\r\n" nil t)) + (accept-process-output process) + (goto-char smtp-read-point)) + + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtp-read-point (- match-end 2)) + response-strings)) + + (goto-char smtp-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtp-debug-info + (message "%s" (car response-strings))) + + (setq smtp-read-point match-end) + + ;; ignore lines that start with "0" + (if (looking-at "0[0-9]+ ") + nil + (setq response-continue nil) + (setq return-value + (cons (string-to-int + (buffer-substring begin end)) + (nreverse response-strings))))) + + (if (looking-at "[0-9]+-") + (progn (if smtp-debug-info + (message "%s" (car response-strings))) + (setq smtp-read-point match-end) + (setq response-continue t)) + (progn + (setq smtp-read-point match-end) + (setq response-continue nil) + (setq return-value + (cons nil (nreverse response-strings))))))) + (setq smtp-read-point match-end) + return-value)) + +(defun smtp-send-command (process command) + (goto-char (point-max)) + (insert command "\r\n") + (setq smtp-read-point (point)) + (process-send-string process command) + (process-send-string process "\r\n")) + +(defun smtp-send-data-1 (process data) + (goto-char (point-max)) + (if smtp-debug-info + (insert data "\r\n")) + (setq smtp-read-point (point)) + ;; Escape "." at start of a line. + (if (eq (string-to-char data) ?.) + (process-send-string process ".")) + (process-send-string process data) + (process-send-string process "\r\n")) + +(defun smtp-send-data (process buffer) + (let ((data-continue t) + (sending-data nil) + this-line + this-line-end) + + (save-excursion + (set-buffer buffer) + (goto-char (point-min))) + + (while data-continue + (save-excursion + (set-buffer buffer) + (beginning-of-line) + (setq this-line (point)) + (end-of-line) + (setq this-line-end (point)) + (setq sending-data nil) + (setq sending-data (buffer-substring this-line this-line-end)) + (if (or (/= (forward-line 1) 0) (eobp)) + (setq data-continue nil))) + + (smtp-send-data-1 process sending-data)))) + +(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end) + "Get address list suitable for smtp RCPT TO:
." + (let ((simple-address-list "") + this-line + this-line-end + addr-regexp + (smtp-address-buffer (generate-new-buffer " *smtp-mail*"))) + (unwind-protect + (save-excursion + ;; + (set-buffer smtp-address-buffer) + (setq case-fold-search t) + (erase-buffer) + (insert (save-excursion + (set-buffer smtp-text-buffer) + (buffer-substring-no-properties header-start header-end))) + (goto-char (point-min)) + ;; RESENT-* fields should stop processing of regular fields. + (save-excursion + (if (re-search-forward "^RESENT-TO:" header-end t) + (setq addr-regexp + "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") + (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) + + (while (re-search-forward addr-regexp header-end t) + (replace-match "") + (setq this-line (match-beginning 0)) + (forward-line 1) + ;; get any continuation lines. + (while (and (looking-at "^[ \t]+") (< (point) header-end)) + (forward-line 1)) + (setq this-line-end (point-marker)) + (setq simple-address-list + (concat simple-address-list " " + (mail-strip-quoted-names + (buffer-substring this-line this-line-end))))) + (erase-buffer) + (insert-string " ") + (insert-string simple-address-list) + (insert-string "\n") + ;; newline --> blank + (subst-char-in-region (point-min) (point-max) 10 ? t) + ;; comma --> blank + (subst-char-in-region (point-min) (point-max) ?, ? t) + ;; tab --> blank + (subst-char-in-region (point-min) (point-max) 9 ? t) + + (goto-char (point-min)) + ;; tidyness in case hook is not robust when it looks at this + (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) + + (goto-char (point-min)) + (let (recipient-address-list) + (while (re-search-forward " \\([^ ]+\\) " (point-max) t) + (backward-char 1) + (setq recipient-address-list + (cons (buffer-substring (match-beginning 1) (match-end 1)) + recipient-address-list))) + recipient-address-list)) + (kill-buffer smtp-address-buffer)))) + +(provide 'smtp) + +;;; smtp.el ends here diff --git a/richtext.el b/richtext.el new file mode 100644 index 0000000..8b1718c --- /dev/null +++ b/richtext.el @@ -0,0 +1,185 @@ +;;; richtext.el -- read and save files in text/richtext format + +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; Created: 1995/7/15 +;; Version: $Id: richtext.el,v 1.1.2.1 2000/02/03 05:01:36 tomo Exp $ +;; Keywords: wp, faces, MIME, multimedia + +;; This file is not part of GNU Emacs yet. + +;; 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 'enriched) + + +;;; @ variables +;;; + +(defconst richtext-initial-annotation + (lambda () + (format "Content-Type: text/richtext\nText-Width: %d\n\n" + (enriched-text-width))) + "What to insert at the start of a text/richtext file. +If this is a string, it is inserted. If it is a list, it should be a lambda +expression, which is evaluated to get the string to insert.") + +(defconst richtext-annotation-regexp + "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*" + "Regular expression matching richtext annotations.") + +(defconst richtext-translations + '((face (bold-italic "bold" "italic") + (bold "bold") + (italic "italic") + (underline "underline") + (fixed "fixed") + (excerpt "excerpt") + (default ) + (nil enriched-encode-other-face)) + (invisible (t "comment")) + (left-margin (4 "indent")) + (right-margin (4 "indentright")) + (justification (right "flushright") + (left "flushleft") + (full "flushboth") + (center "center")) + ;; The following are not part of the standard: + (FUNCTION (enriched-decode-foreground "x-color") + (enriched-decode-background "x-bg-color")) + (read-only (t "x-read-only")) + (unknown (nil format-annotate-value)) +; (font-size (2 "bigger") ; unimplemented +; (-2 "smaller")) +) + "List of definitions of text/richtext annotations. +See `format-annotate-region' and `format-deannotate-region' for the definition +of this structure.") + + +;;; @ encoder +;;; + +;;;###autoload +(defun richtext-encode (from to) + (if enriched-verbose (message "Richtext: encoding document...")) + (save-restriction + (narrow-to-region from to) + (delete-to-left-margin) + (unjustify-region) + (goto-char from) + (format-replace-strings '(("<" . ""))) + (format-insert-annotations + (format-annotate-region from (point-max) richtext-translations + 'enriched-make-annotation enriched-ignore)) + (goto-char from) + (insert (if (stringp enriched-initial-annotation) + richtext-initial-annotation + (funcall richtext-initial-annotation))) + (enriched-map-property-regions 'hard + (lambda (v b e) + (goto-char b) + (if (eolp) + (while (search-forward "\n" nil t) + (replace-match "\n") + ))) + (point) nil) + (if enriched-verbose (message nil)) + ;; Return new end. + (point-max))) + + +;;; @ decoder +;;; + +(defun richtext-next-annotation () + "Find and return next text/richtext annotation. +Return value is \(begin end name positive-p), or nil if none was found." + (catch 'tag + (while (re-search-forward richtext-annotation-regexp nil t) + (let* ((beg0 (match-beginning 0)) + (end0 (match-end 0)) + (beg (match-beginning 1)) + (end (match-end 1)) + (name (downcase (buffer-substring + (match-beginning 3) (match-end 3)))) + (pos (not (match-beginning 2))) + ) + (cond ((equal name "lt") + (delete-region beg end) + (goto-char beg) + (insert "<") + ) + ((equal name "comment") + (if pos + (throw 'tag (list beg0 end name pos)) + (throw 'tag (list beg end0 name pos)) + ) + ) + (t + (throw 'tag (list beg end name pos)) + )) + )))) + +;;;###autoload +(defun richtext-decode (from to) + (if enriched-verbose (message "Richtext: decoding document...")) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char from) + (let ((file-width (enriched-get-file-width)) + (use-hard-newlines t)) + (enriched-remove-header) + + (goto-char from) + (while (re-search-forward "\n\n+" nil t) + (replace-match "\n") + ) + + ;; Deal with newlines + (goto-char from) + (while (re-search-forward "[ \t\n]*[ \t\n]*" nil t) + (replace-match "\n") + (put-text-property (match-beginning 0) (point) 'hard t) + (put-text-property (match-beginning 0) (point) 'front-sticky nil) + ) + + ;; Translate annotations + (format-deannotate-region from (point-max) richtext-translations + 'richtext-next-annotation) + + ;; Fill paragraphs + (if (and file-width ; possible reasons not to fill: + (= file-width (enriched-text-width))) ; correct wd. + ;; Minimally, we have to insert indentation and justification. + (enriched-insert-indentation) + (if enriched-verbose (message "Filling paragraphs...")) + (fill-region (point-min) (point-max)))) + (if enriched-verbose (message nil)) + (point-max)))) + + +;;; @ end +;;; + +(require 'product) +(product-provide (provide 'richtext) (require 'apel-ver)) + +;;; richtext.el ends here