--- /dev/null
+;;; alist.el --- utility functions about association-list
+
+;; Copyright (C) 1993,1994,1995,1996,1998,2000 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; 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
--- /dev/null
+;;; 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 <tomo@m17n.org>
+;; 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
--- /dev/null
+;;; filename.el --- file name filter
+
+;; Copyright (C) 1996,1997 MORIOKA Tomohiko
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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
--- /dev/null
+;;; install.el --- Emacs Lisp package install utility
+
+;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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
--- /dev/null
+;;; path-util.el --- Emacs Lisp file detection utility
+
+;; Copyright (C) 1996,1997,1999 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; 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
--- /dev/null
+;;; smtp.el --- basic functions to send mail with SMTP server
+
+;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
+
+;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
+;; Simon Leinen <simon@switch.ch> (ESMTP support)
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; 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:<sender>
+ (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:<recipient>
+ (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:<address>."
+ (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
--- /dev/null
+;;; richtext.el -- read and save files in text/richtext format
+
+;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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 '(("<" . "<lt>")))
+ (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 "<nl>\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]*<nl>[ \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
projects / elisp / lemi.git / commitdiff