adding wanderlust (and required prerequisites: apel, flim, semi)
This commit is contained in:
Kai Tetzlaff
parent
80459bbecd
commit
7fae4e12f1
88
apel-10.7/APEL-CFG
Normal file
88
apel-10.7/APEL-CFG
Normal file
@ -0,0 +1,88 @@
|
||||
;;; APEL-CFG --- user customizations for APEL installation. -*-Emacs-Lisp-*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Use this file to override variables defined in APEL-MK.
|
||||
;;
|
||||
;; The following variables are used in APEL-MK.
|
||||
;; Note that you cannot use them in this file.
|
||||
;;
|
||||
;; For Emacs, or XEmacs without package system:
|
||||
;;
|
||||
;; PREFIX: Normally, "/usr/local".
|
||||
;; Installer will try to detect it automatically.
|
||||
;; LISPDIR: "PREFIX/share/emacs/site-lisp" if Emacs 19.29 and later.
|
||||
;; "PREFIX/lib/emacs/site-lisp" if Emacs 19.28 and earlier.
|
||||
;; Installer will try to detect it from PREFIX.
|
||||
;; VERSION_SPECIFIC_LISPDIR: "PREFIX/share/emacs/VERSION/site-lisp"
|
||||
;; if Emacs 19.31 and later, otherwise, same as LISPDIR.
|
||||
;;
|
||||
;; APEL_PREFIX: subdirectory of LISPDIR where APEL modules will be
|
||||
;; installed, or "" if you don't want to make subdirectory.
|
||||
;; EMU_PREFIX: subdirectory of VERSION_SPECIFIC_LISPDIR where EMU
|
||||
;; modules will be installed, or "" if you don't want to
|
||||
;; make subdirectory.
|
||||
;;
|
||||
;; APEL_DIR: The directory where APEL modules will be installed.
|
||||
;; Generated from LISPDIR and APEL_PREFIX if it is not set.
|
||||
;; EMU_DIR: The directory where EMU modules will be installed.
|
||||
;; Generated from VERSION_SPECIFIC_LISPDIR and EMU_PREFIX
|
||||
;; if it is not set.
|
||||
;;
|
||||
;; For XEmacs with package system:
|
||||
;;
|
||||
;; PACKAGEDIR: "/usr/local/lib/xemacs/xemacs-packages"
|
||||
;; Installer will try to detect it automatically.
|
||||
;;
|
||||
;; APEL_PREFIX: subdirectory of PACKAGEDIR where both APEL and EMU
|
||||
;; modules will be installed.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; "custom" library.
|
||||
|
||||
;; If you want to use "new custom" but do not use "subdirs.el" to add
|
||||
;; "custom" directory to your load-path, uncomment and edit this.
|
||||
;; (setq load-path
|
||||
;; (cons "/usr/local/share/emacs/19.34/site-lisp/custom" load-path))
|
||||
|
||||
|
||||
;;; Install to home directory.
|
||||
|
||||
;; If you want to install APEL to your home directory and you already
|
||||
;; have the standard hierarchy such as "~/share/emacs/site-lisp" and
|
||||
;; "~/share/emacs/VERSION/site-lisp", uncomment and edit this.
|
||||
;; (setq PREFIX "~/")
|
||||
|
||||
;; Or, you can specify APEL_DIR and EMU_DIR directly.
|
||||
;; (setq APEL_DIR "~/lib/emacs/lisp/apel")
|
||||
;; (setq EMU_DIR "~/lib/emacs/lisp/emu")
|
||||
|
||||
|
||||
;;; Install to site-lisp directories.
|
||||
|
||||
;; (setq PREFIX "/usr/local")
|
||||
|
||||
;; Mule based on Emacs 19.28 and earlier.
|
||||
;; (setq LISPDIR "/usr/local/share/mule/site-lisp")
|
||||
;; Mule based on Emacs 19.29 and later.
|
||||
;; (setq LISPDIR "/usr/local/share/emacs/site-lisp")
|
||||
;; (setq LISPDIR "/usr/local/share/mule/site-lisp")
|
||||
;; (setq VERSION_SPECIFIC_LISPDIR "/usr/local/share/emacs/19.34/site-lisp")
|
||||
;; (setq VERSION_SPECIFIC_LISPDIR "/usr/local/share/mule/19.34/site-lisp")
|
||||
|
||||
;; XEmacs 21.0 and later.
|
||||
;; (setq PACKAGEDIR "/usr/local/lib/xemacs/xemacs-packages")
|
||||
|
||||
;; (setq APEL_PREFIX "apel")
|
||||
;; (setq EMU_PREFIX "emu")
|
||||
|
||||
;; If you want to install all of APEL modules to VERSION_SPECIFIC_LISPDIR,
|
||||
;; uncomment and edit this.
|
||||
;; (setq APEL_DIR "/usr/local/share/emacs/19.34/site-lisp/apel")
|
||||
|
||||
;; You can specify APEL_DIR and EMU_DIR directly. Uncomment and edit this.
|
||||
;; (setq APEL_DIR "/usr/local/share/emacs/site-lisp/apel")
|
||||
;; (setq EMU_DIR "/usr/local/share/emacs/19.34/site-lisp/emu")
|
||||
|
||||
;;; APEL-CFG ends here
|
||||
19
apel-10.7/APEL-ELS
Normal file
19
apel-10.7/APEL-ELS
Normal file
@ -0,0 +1,19 @@
|
||||
;;; APEL-ELS --- list of APEL modules to install. -*-Emacs-Lisp-*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; APEL-MK imports `apel-modules' from here.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar apel-modules '(alist calist path-util filename install
|
||||
;; "mule-caesar" is version-dependent.
|
||||
;; moved to EMU-ELS.
|
||||
;; mule-caesar
|
||||
|
||||
;; [obsoleted modules] If you would like to
|
||||
;; install following, please activate them.
|
||||
;; atype file-detect
|
||||
))
|
||||
|
||||
;;; APEL-ELS ends here
|
||||
197
apel-10.7/APEL-MK
Normal file
197
apel-10.7/APEL-MK
Normal file
@ -0,0 +1,197 @@
|
||||
;;; APEL-MK --- installer for APEL. -*-Emacs-Lisp-*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; DON'T EDIT THIS FILE; edit APEL-CFG instead.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; Configuration variables.
|
||||
|
||||
;; Set these four variables in "APEL-CFG" or in "Makefile".
|
||||
|
||||
;; This variable will be detected automatically.
|
||||
(defvar PREFIX nil)
|
||||
|
||||
;; This variable will be detected automatically using PREFIX.
|
||||
;; v18: (no standard site-lisp directory)
|
||||
;; Emacs 19.28 and earlier: "PREFIX/lib/emacs/site-lisp"
|
||||
;; Emacs 19.29 and later: "PREFIX/share/emacs/site-lisp"
|
||||
(defvar LISPDIR nil)
|
||||
|
||||
;; This variable will be detected automatically using PREFIX.
|
||||
;; Emacs 19.31 and later: "PREFIX/share/emacs/VERSION/site-lisp"
|
||||
(defvar VERSION_SPECIFIC_LISPDIR nil)
|
||||
|
||||
;; This variable will be detected automatically.
|
||||
;; XEmacs 21.0 and later: "/usr/local/lib/xemacs/xemacs-packages"
|
||||
(defvar PACKAGEDIR nil)
|
||||
|
||||
;; Install APEL modules to "apel" subdirectory.
|
||||
(defvar APEL_PREFIX "apel")
|
||||
|
||||
;; Install EMU modules to "emu" subdirectory if emacs supports some features.
|
||||
;; If your emacs does not have `normal-top-level-add-subdirs-to-load-path'
|
||||
;; but have `normal-top-level-add-to-load-path' and you want to use it in
|
||||
;; "subdirs.el", put the following line to "APEL-CFG".
|
||||
;; (setq EMU_PREFIX "emu")
|
||||
(defvar EMU_PREFIX
|
||||
(if (or (featurep 'xemacs)
|
||||
(fboundp 'normal-top-level-add-subdirs-to-load-path))
|
||||
;; Make "emu" subdirectory.
|
||||
"emu"
|
||||
;; Don't make "emu" subdirectory.
|
||||
""))
|
||||
|
||||
;; The directories where APEL and EMU modules will be installed.
|
||||
;; These two variables will be generated from other variables above.
|
||||
(defvar APEL_DIR nil) ; LISPDIR/APEL_PREFIX
|
||||
(defvar EMU_DIR nil) ; VERSION_SPECIFIC_LISPDIR/EMU_PREFIX
|
||||
|
||||
|
||||
;;; Configure, Compile, and Install.
|
||||
|
||||
(defun config-apel ()
|
||||
;; Override everything you want.
|
||||
(load-file "APEL-CFG")
|
||||
;; Override PREFIX, LISPDIR, and VERSION_SPECIFIC_LISPDIR with
|
||||
;; command-line options.
|
||||
(let (prefix lisp-dir version-specific-lisp-dir)
|
||||
(and (setq prefix
|
||||
;; Avoid using `pop'.
|
||||
;; (pop command-line-args-left)
|
||||
(prog1
|
||||
(car command-line-args-left)
|
||||
(setq command-line-args-left
|
||||
(cdr command-line-args-left))))
|
||||
(or (string-equal "NONE" prefix)
|
||||
(setq PREFIX prefix)))
|
||||
(and (setq lisp-dir
|
||||
;; Avoid using `pop'.
|
||||
;; (pop command-line-args-left)
|
||||
(prog1
|
||||
(car command-line-args-left)
|
||||
(setq command-line-args-left
|
||||
(cdr command-line-args-left))))
|
||||
(or (string-equal "NONE" lisp-dir)
|
||||
(setq LISPDIR lisp-dir)))
|
||||
(and (setq version-specific-lisp-dir
|
||||
;; Avoid using `pop'.
|
||||
;; (pop command-line-args-left)
|
||||
(prog1
|
||||
(car command-line-args-left)
|
||||
(setq command-line-args-left
|
||||
(cdr command-line-args-left))))
|
||||
(or (string-equal "NONE" version-specific-lisp-dir)
|
||||
(setq VERSION_SPECIFIC_LISPDIR version-specific-lisp-dir))))
|
||||
;; Load some APEL modules from this directory.
|
||||
(defvar default-load-path load-path)
|
||||
(setq load-path (cons (expand-file-name ".") load-path))
|
||||
(require 'poe)
|
||||
(require 'path-util)
|
||||
(require 'install)
|
||||
|
||||
;; Import `apel-modules'.
|
||||
(load-file "APEL-ELS")
|
||||
;; Import `emu-modules' and `emu-modules-to-compile'.
|
||||
(load-file "EMU-ELS")
|
||||
|
||||
;; Set PREFIX, LISPDIR, and VERSION_SPECIFIC_LISPDIR if not set yet.
|
||||
(or PREFIX
|
||||
(setq PREFIX install-prefix))
|
||||
(or LISPDIR
|
||||
(setq LISPDIR (install-detect-elisp-directory PREFIX)))
|
||||
(or VERSION_SPECIFIC_LISPDIR
|
||||
(setq VERSION_SPECIFIC_LISPDIR
|
||||
(install-detect-elisp-directory PREFIX nil 'version-specific)))
|
||||
;; The directories where APEL and EMU will be installed.
|
||||
(or APEL_DIR
|
||||
(setq APEL_DIR (expand-file-name APEL_PREFIX LISPDIR)))
|
||||
(or EMU_DIR
|
||||
(setq EMU_DIR (expand-file-name EMU_PREFIX VERSION_SPECIFIC_LISPDIR)))
|
||||
(princ (format "\nLISPDIR=%s\n" LISPDIR))
|
||||
(princ (format "VERSION_SPECIFIC_LISPDIR=%s\n" VERSION_SPECIFIC_LISPDIR)))
|
||||
|
||||
(defun compile-apel ()
|
||||
(config-apel)
|
||||
;; Compile emu modules first.
|
||||
(compile-elisp-modules emu-modules-to-compile ".")
|
||||
(compile-elisp-modules apel-modules "."))
|
||||
|
||||
(defun install-apel (&optional just-print)
|
||||
(config-apel)
|
||||
(or just-print
|
||||
(setq just-print (install-just-print-p)))
|
||||
(install-elisp-modules emu-modules "." EMU_DIR just-print)
|
||||
(install-elisp-modules apel-modules "." APEL_DIR just-print))
|
||||
|
||||
;; For XEmacs package system.
|
||||
(defun config-apel-package ()
|
||||
;; Override everything you want.
|
||||
(load-file "APEL-CFG")
|
||||
;; Override PACKAGEDIR with command-line option.
|
||||
(let (package-dir)
|
||||
(and (setq package-dir
|
||||
;; Avoid using `pop'.
|
||||
;; (pop command-line-args-left)
|
||||
(prog1
|
||||
(car command-line-args-left)
|
||||
(setq command-line-args-left
|
||||
(cdr command-line-args-left))))
|
||||
(or (string= "NONE" package-dir)
|
||||
(setq PACKAGEDIR package-dir))))
|
||||
;; Load some APEL modules from this directory.
|
||||
(defvar default-load-path load-path)
|
||||
(setq load-path (cons (expand-file-name ".") load-path))
|
||||
(require 'poe)
|
||||
(require 'path-util)
|
||||
(require 'install)
|
||||
|
||||
;; Import `apel-modules'.
|
||||
(load-file "APEL-ELS")
|
||||
;; Import `emu-modules' and `emu-modules-to-compile'.
|
||||
(load-file "EMU-ELS")
|
||||
|
||||
;; Set PACKAGEDIR if not set yet.
|
||||
(or PACKAGEDIR
|
||||
(setq PACKAGEDIR (install-get-default-package-directory)))
|
||||
(if PACKAGEDIR
|
||||
(princ (format "\nPACKAGEDIR=%s\n" PACKAGEDIR))
|
||||
(error "XEmacs package system is not available")))
|
||||
|
||||
(defun compile-apel-package ()
|
||||
(config-apel-package)
|
||||
;; Compile emu modules first.
|
||||
(compile-elisp-modules emu-modules-to-compile ".")
|
||||
(compile-elisp-modules apel-modules "."))
|
||||
|
||||
(defun install-apel-package ()
|
||||
(config-apel-package)
|
||||
(let ((just-print (install-just-print-p))
|
||||
(dir (expand-file-name APEL_PREFIX
|
||||
(expand-file-name "lisp" PACKAGEDIR))))
|
||||
(install-elisp-modules emu-modules "." dir just-print)
|
||||
(install-elisp-modules apel-modules "." dir just-print)
|
||||
(install-update-package-files "apel" dir just-print)))
|
||||
|
||||
(defun what-where-apel ()
|
||||
(install-apel 'just-print)
|
||||
;; (config-apel)
|
||||
;;; (princ (format "
|
||||
;;; The files that belong to the EMU modules:
|
||||
;;; %s
|
||||
;;; -> %s
|
||||
|
||||
;;; The files that belong to the APEL modules:
|
||||
;;; %s
|
||||
;;; -> %s
|
||||
|
||||
;;; Do `make elc', `make install', `make package', or `make install-package'.
|
||||
;;; "
|
||||
;;; (mapconcat (function symbol-name) emu-modules ", ")
|
||||
;;; EMU_DIR
|
||||
;;; (mapconcat (function symbol-name) apel-modules ", ")
|
||||
;;; APEL_DIR))
|
||||
)
|
||||
|
||||
;;; APEL-MK ends here
|
||||
3900
apel-10.7/ChangeLog
Normal file
3900
apel-10.7/ChangeLog
Normal file
File diff suppressed because it is too large
Load Diff
220
apel-10.7/EMU-ELS
Normal file
220
apel-10.7/EMU-ELS
Normal file
@ -0,0 +1,220 @@
|
||||
;;; EMU-ELS --- list of EMU modules to install. -*-Emacs-Lisp-*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; APEL-MK imports `emu-modules' and `emu-modules-to-compile' from here.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar emu-modules-not-to-compile nil)
|
||||
(defvar emu-modules-to-compile nil)
|
||||
|
||||
;; We use compile-time evaluation heavily. So, order of compilation is
|
||||
;; very significant. For example, loading some module before compiling
|
||||
;; it will cause "compile-time" evaluation many times.
|
||||
(defvar emu-modules
|
||||
(nconc
|
||||
;; modules are sorted by compilation order.
|
||||
'(static broken)
|
||||
|
||||
;; product information.
|
||||
'(product apel-ver)
|
||||
|
||||
;; poe modules; poe modules depend on static.
|
||||
'(pym)
|
||||
(cond
|
||||
;; XEmacs.
|
||||
((featurep 'xemacs)
|
||||
'(poe-xemacs poe))
|
||||
;; Emacs 19.29 and earlier. (yes, includes Emacs 19.29.)
|
||||
((and (= emacs-major-version 19)
|
||||
(<= emacs-minor-version 29))
|
||||
'(localhook poe))
|
||||
;; Emacs 19.30 and later.
|
||||
((>= emacs-major-version 19)
|
||||
'(poe))
|
||||
(t
|
||||
;; v18.
|
||||
'(localhook env poe-18 poe)))
|
||||
|
||||
;; pcustom modules; pcustom modules depend on poe.
|
||||
(if (and (module-installed-p 'custom)
|
||||
;; new custom requires widget.
|
||||
(module-installed-p 'widget))
|
||||
;; if both 'custom and 'widget are found, we have new custom.
|
||||
'(pcustom)
|
||||
;; pcustom does (require 'custom) at compile-time, and tinycustom
|
||||
;; need to test existence of some custom macros at compile-time!
|
||||
;; so, we must compile tinycustom first.
|
||||
'(tinycustom pcustom))
|
||||
|
||||
;; pccl modules; pccl modules depend on broken.
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
(cond
|
||||
;; XEmacs 21 w/ mule.
|
||||
((and (featurep 'mule)
|
||||
(>= emacs-major-version 21))
|
||||
'(pccl-20 pccl))
|
||||
(t
|
||||
'(pccl))))
|
||||
((featurep 'mule)
|
||||
(cond
|
||||
;; Emacs 20.
|
||||
((>= emacs-major-version 20)
|
||||
'(pccl-20 pccl))
|
||||
;; Mule 1.* and 2.*.
|
||||
(t
|
||||
'(pccl-om pccl))))
|
||||
(t
|
||||
'(pccl)))
|
||||
|
||||
;; pces modules; pces modules depend on poe.
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
(cond
|
||||
((featurep 'mule)
|
||||
;; XEmacs w/ mule.
|
||||
;; pces-xfc depends pces-20, so we compile pces-20 first.
|
||||
'(pces-20 pces-xm pces-xfc pces))
|
||||
((featurep 'file-coding)
|
||||
;; XEmacs w/ file-coding.
|
||||
;; pces-xfc depends pces-20, so we compile pces-20 first.
|
||||
'(pces-20 pces-xfc pces))
|
||||
(t
|
||||
'(pces-raw pces))))
|
||||
((featurep 'mule)
|
||||
(cond
|
||||
;; Emacs 20.3 and later.
|
||||
((and (fboundp 'set-buffer-multibyte)
|
||||
(subrp (symbol-function 'set-buffer-multibyte)))
|
||||
;; pces-e20 depends pces-20, so we compile pces-20 first.
|
||||
'(pces-20 pces-e20 pces))
|
||||
;; Emacs 20.1 and 20.2.
|
||||
((= emacs-major-version 20)
|
||||
;; pces-e20 depends pces-20, so we compile pces-20 first.
|
||||
'(pces-20 pces-e20_2 pces-e20 pces))
|
||||
(t
|
||||
;; Mule 1.* and 2.*.
|
||||
'(pces-om pces))))
|
||||
((boundp 'NEMACS)
|
||||
;; Nemacs.
|
||||
'(pces-nemacs pces))
|
||||
(t
|
||||
'(pces-raw pces)))
|
||||
|
||||
;; poem modules; poem modules depend on pces.
|
||||
(cond
|
||||
((featurep 'mule)
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
;; XEmacs w/ mule.
|
||||
'(poem-xm poem))
|
||||
((>= emacs-major-version 20)
|
||||
(if (and (fboundp 'set-buffer-multibyte)
|
||||
(subrp (symbol-function 'set-buffer-multibyte)))
|
||||
;; Emacs 20.3 and later.
|
||||
'(poem-e20_3 poem-e20 poem)
|
||||
;; Emacs 20.1 and 20.2.
|
||||
'(poem-e20_2 poem-e20 poem)))
|
||||
(t
|
||||
;; Mule 1.* and 2.*.
|
||||
'(poem-om poem))))
|
||||
((boundp 'NEMACS)
|
||||
'(poem-nemacs poem))
|
||||
(t
|
||||
'(poem-ltn1 poem)))
|
||||
|
||||
;; mcharset modules; mcharset modules depend on poem and pcustom.
|
||||
(cond
|
||||
((featurep 'mule)
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
;; XEmacs w/ mule.
|
||||
(if (featurep 'utf-2000)
|
||||
;; XEmacs w/ UTF-2000.
|
||||
(setq emu-modules-not-to-compile
|
||||
(cons 'mcs-xmu emu-modules-not-to-compile)))
|
||||
;; mcs-xm depends mcs-20, so we compile mcs-20 first.
|
||||
'(mcs-20 mcs-xmu mcs-xm mcharset))
|
||||
((>= emacs-major-version 20)
|
||||
;; Emacs 20 and later.
|
||||
;; mcs-e20 depends mcs-20, so we compile mcs-20 first.
|
||||
'(mcs-20 mcs-e20 mcharset))
|
||||
(t
|
||||
;; Mule 1.* and 2.*.
|
||||
'(mcs-om mcharset))))
|
||||
((boundp 'NEMACS)
|
||||
;; Nemacs.
|
||||
'(mcs-nemacs mcharset))
|
||||
(t
|
||||
'(mcs-ltn1 mcharset)))
|
||||
|
||||
;; timezone.el; Some versions have Y2K problem.
|
||||
(condition-case nil
|
||||
(let ((load-path (delete (expand-file-name ".")
|
||||
(copy-sequence load-path))))
|
||||
;; v18 does not have timezone.el.
|
||||
(require 'timezone)
|
||||
;; Is timezone.el APEL version?
|
||||
(if (product-find 'timezone)
|
||||
(error "timezone.el is APEL version. Install newer version."))
|
||||
;; Y2K test.
|
||||
(or (string= (aref (timezone-parse-date "Sat, 1 Jan 00 00:00:00 GMT")
|
||||
0)
|
||||
"2000")
|
||||
(error "timezone.el has Y2K problem. Install fixed version."))
|
||||
;; Old parser test.
|
||||
(if (string=
|
||||
(aref (timezone-parse-date "Wednesday, 31-Jan-01 09:00:00 GMT")
|
||||
0)
|
||||
"0")
|
||||
(error "timezone.el has old date parser. Install fixed version."))
|
||||
;; no problem.
|
||||
'())
|
||||
(error
|
||||
'(timezone)))
|
||||
|
||||
;; invisible modules; provided for backward compatibility with old "tm".
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
;; XEmacs.
|
||||
'(inv-xemacs invisible))
|
||||
((>= emacs-major-version 19)
|
||||
;; Emacs 19 and later.
|
||||
'(inv-19 invisible))
|
||||
(t
|
||||
;; v18.
|
||||
'(inv-18 invisible)))
|
||||
|
||||
;; emu modules; provided for backward compatibility with old "tm".
|
||||
(if (and (featurep 'mule)
|
||||
(< emacs-major-version 20))
|
||||
;; Mule 1.* and 2.*.
|
||||
'(emu-mule emu)
|
||||
'(emu))
|
||||
|
||||
;; emu submodules; text/richtext and text/enriched support.
|
||||
(if (if (featurep 'xemacs)
|
||||
(or (>= emacs-major-version 20)
|
||||
(and (= emacs-major-version 19)
|
||||
(>= emacs-minor-version 14)))
|
||||
(or (>= emacs-major-version 20)
|
||||
(and (= emacs-major-version 19)
|
||||
(>= emacs-minor-version 29))))
|
||||
;; XEmacs 19.14 and later, or Emacs 19.29 and later.
|
||||
'(richtext)
|
||||
'(tinyrich))
|
||||
|
||||
;; mule-caesar.el; part of apel-modules, but it is version-dependent.
|
||||
'(mule-caesar)))
|
||||
|
||||
;; Generate `emu-modules-to-compile' from `emu-modules-not-to-compile'
|
||||
;; and `emu-modules'.
|
||||
(let ((modules emu-modules-not-to-compile))
|
||||
(setq emu-modules-to-compile (copy-sequence emu-modules))
|
||||
(while modules
|
||||
(setq emu-modules-to-compile (delq (car modules) emu-modules-to-compile)
|
||||
modules (cdr modules))))
|
||||
|
||||
;;; EMU-ELS ends here
|
||||
67
apel-10.7/Makefile
Normal file
67
apel-10.7/Makefile
Normal file
@ -0,0 +1,67 @@
|
||||
#
|
||||
# Makefile for APEL.
|
||||
#
|
||||
|
||||
VERSION = 10.7
|
||||
|
||||
TAR = tar
|
||||
RM = /bin/rm -f
|
||||
CP = /bin/cp -p
|
||||
|
||||
EMACS = emacs
|
||||
XEMACS = xemacs
|
||||
FLAGS = -batch -q -no-site-file -l APEL-MK
|
||||
|
||||
PREFIX = NONE
|
||||
LISPDIR = NONE
|
||||
PACKAGEDIR = NONE
|
||||
VERSION_SPECIFIC_LISPDIR = NONE
|
||||
|
||||
GOMI = *.elc
|
||||
|
||||
ARCHIVE_DIR_PREFIX = /home/kanji/tomo/public_html/lemi/dist
|
||||
|
||||
default: elc
|
||||
|
||||
what-where:
|
||||
$(EMACS) $(FLAGS) -f what-where-apel \
|
||||
$(PREFIX) $(LISPDIR) $(VERSION_SPECIFIC_LISPDIR)
|
||||
|
||||
elc:
|
||||
$(EMACS) $(FLAGS) -f compile-apel \
|
||||
$(PREFIX) $(LISPDIR) $(VERSION_SPECIFIC_LISPDIR)
|
||||
|
||||
install: elc
|
||||
$(EMACS) $(FLAGS) -f install-apel \
|
||||
$(PREFIX) $(LISPDIR) $(VERSION_SPECIFIC_LISPDIR) # $(MAKE)
|
||||
|
||||
package:
|
||||
$(XEMACS) $(FLAGS) -f compile-apel-package \
|
||||
$(PACKAGEDIR)
|
||||
|
||||
install-package: package
|
||||
$(XEMACS) $(FLAGS) -f install-apel-package \
|
||||
$(PACKAGEDIR) # $(MAKE)
|
||||
|
||||
|
||||
clean:
|
||||
-$(RM) $(GOMI)
|
||||
|
||||
|
||||
tar:
|
||||
cvs commit
|
||||
sh -c 'cvs tag -R apel-`echo $(VERSION) \
|
||||
| sed s/\\\\./_/ | sed s/\\\\./_/`; \
|
||||
cd /tmp; \
|
||||
cvs -d :pserver:anonymous@cvs.m17n.org:/cvs/root \
|
||||
export -d apel-$(VERSION) \
|
||||
-r apel-`echo $(VERSION) | tr . _` apel'
|
||||
cd /tmp; $(RM) apel-$(VERSION)/ftp.in apel-$(VERSION)/.cvsignore ; \
|
||||
$(TAR) cvzf apel-$(VERSION).tar.gz apel-$(VERSION)
|
||||
cd /tmp; $(RM) -r apel-$(VERSION)
|
||||
sed "s/VERSION/$(VERSION)/" < ftp.in > ftp
|
||||
|
||||
release:
|
||||
-$(RM) $(ARCHIVE_DIR_PREFIX)/apel/apel-$(VERSION).tar.gz
|
||||
mv /tmp/apel-$(VERSION).tar.gz $(ARCHIVE_DIR_PREFIX)/apel
|
||||
cd $(ARCHIVE_DIR_PREFIX)/semi/ ; ln -s ../apel/apel-$(VERSION).tar.gz .
|
||||
492
apel-10.7/README.en
Normal file
492
apel-10.7/README.en
Normal file
@ -0,0 +1,492 @@
|
||||
-*- outline -*-
|
||||
|
||||
[README for APEL (English Version)]
|
||||
|
||||
* What's APEL?
|
||||
|
||||
APEL stands for "A Portable Emacs Library". It consists of following
|
||||
modules:
|
||||
|
||||
** poe.el
|
||||
|
||||
This is an emulation module mainly for basic functions and special
|
||||
forms/macros of latest emacsen.
|
||||
|
||||
poe-xemacs.el --- for XEmacs
|
||||
poe-18.el --- for Emacs 18/Nemacs
|
||||
env.el --- env.el for Emacs 18
|
||||
localhook.el --- hook functions for Emacs 19.28 and earlier.
|
||||
pym.el --- macros for poe.
|
||||
|
||||
** poem.el
|
||||
|
||||
This module provides basic functions to write portable MULE programs.
|
||||
|
||||
poem-nemacs.el --- for Nemacs
|
||||
poem-ltn1.el --- for Emacs 19/XEmacs without MULE
|
||||
poem-om.el --- for MULE 1.*, 2.*
|
||||
poem-20.el --- shared module between Emacs 20 and XEmacs-MULE
|
||||
poem-e20_2.el --- for Emacs 20.1/20.2
|
||||
poem-e20_3.el --- for Emacs 20.3
|
||||
poem-xm.el --- for XEmacs-MULE
|
||||
|
||||
** pces.el
|
||||
|
||||
This module provides portable character encoding scheme
|
||||
(coding-system) features.
|
||||
|
||||
pces-20.el --- for Emacs 20 and XEmacs with coding-system.
|
||||
pces-e20.el --- for Emacs 20.
|
||||
pces-e20_2.el --- for Emacs 20.1 and 20.2.
|
||||
pces-nemacs.el --- for Nemacs.
|
||||
pces-om.el --- for Mule 1.* and Mule 2.*.
|
||||
pces-raw.el --- for emacsen without coding-system features.
|
||||
pces-xfc.el --- for XEmacs with file coding.
|
||||
pces-xm.el --- for XEmacs-mule.
|
||||
|
||||
** invisible.el
|
||||
|
||||
This modules provides features about invisible region.
|
||||
|
||||
inv-18.el --- for Emacs 18
|
||||
inv-19.el --- for Emacs 19
|
||||
inv-xemacs.el --- for XEmacs
|
||||
|
||||
** mcharset.el
|
||||
|
||||
This modules provides MIME charset related features.
|
||||
|
||||
mcs-nemacs.el --- for Nemacs
|
||||
mcs-ltn1.el --- for Emacs 19/XEmacs without MULE
|
||||
mcs-om.el --- for MULE 1.*, 2.*
|
||||
mcs-20.el --- shared module between Emacs 20 and XEmacs-MULE
|
||||
mcs-e20.el --- for Emacs 20
|
||||
mcs-xm.el --- for XEmacs-MULE
|
||||
mcs-xmu.el --- for XEmacs-MULE to unify ISO646 characters
|
||||
|
||||
** static.el --- utility for static evaluation
|
||||
|
||||
** broken.el --- provide information of broken facilities of Emacs
|
||||
|
||||
** pccl.el --- utility to write portable CCL program
|
||||
|
||||
pccl-om.el --- for MULE 2.*
|
||||
pccl-20.el --- for Emacs 20/XEmacs-21-MULE
|
||||
|
||||
** alist.el: utility for Association-list
|
||||
|
||||
** calist.el: utility for condition tree and condition/situation-alist
|
||||
|
||||
** path-util.el: utility for path management or file detection
|
||||
|
||||
** filename.el: utility to make file-name
|
||||
|
||||
** install.el: utility to install emacs-lisp package
|
||||
|
||||
** mule-caesar.el: ROT 13-47-48 Caesar rotation utility
|
||||
|
||||
** emu.el
|
||||
|
||||
This module provides emu bundled in tm-7.106 compatibility. It
|
||||
required poe, poem and mcharset.
|
||||
|
||||
emu-mule: --- for MULE 1.*, 2.*.
|
||||
richtext.el --- text/richtext module for Emacs 19.29 or later,
|
||||
XEmacs 19.14 or later
|
||||
tinyrich.el --- text/richtext module for old emacsen
|
||||
|
||||
** pcustom.el --- provide portable custom environment
|
||||
|
||||
tinycustom.el --- emulation module of custom.el
|
||||
|
||||
** timezone.el
|
||||
|
||||
This is a utility of time zone. This is a Y2K fixed version. This
|
||||
works with old GNUS 3.14.4 under version 18 of Emacs, too.
|
||||
|
||||
** product.el --- Functions for product version information.
|
||||
|
||||
* Installation
|
||||
|
||||
** run in expanded place
|
||||
|
||||
If you don't want to install other directories, please do only
|
||||
following (You can use make.bat for MS-DOS OS family. If you want to
|
||||
use it, see `make.bat (for MS-DOS family)'):
|
||||
|
||||
% make
|
||||
|
||||
You can specify the emacs command name, for example
|
||||
|
||||
% make EMACS=xemacs
|
||||
|
||||
If `EMACS=...' is omitted, EMACS=emacs is used.
|
||||
|
||||
** make install
|
||||
|
||||
If you want to install other directories, please do following:
|
||||
|
||||
% make install
|
||||
|
||||
You can specify the emacs command name, for example
|
||||
|
||||
% make install EMACS=xemacs
|
||||
|
||||
If `EMACS=...' is omitted, EMACS=emacs is used.
|
||||
|
||||
You can specify the prefix of the directory tree for Emacs Lisp
|
||||
programs and shell scripts, for example:
|
||||
|
||||
% make install PREFIX=~/
|
||||
|
||||
If `PREFIX=...' is omitted, the prefix of the directory tree of the
|
||||
specified emacs command is used (perhaps /usr/local).
|
||||
|
||||
For example, if PREFIX=/usr/local and Emacs 20.2 is specified, it
|
||||
will create the following directory tree:
|
||||
|
||||
/usr/local/share/emacs/20.2/site-lisp/ --- emu
|
||||
/usr/local/share/emacs/site-lisp/apel/ --- APEL
|
||||
|
||||
You can specify the lisp directory for Emacs Lisp programs,
|
||||
for example:
|
||||
|
||||
% make install LISPDIR=~/elisp
|
||||
|
||||
You can also specify the version specific lisp directory where the
|
||||
emu modules will be installed in, for example:
|
||||
|
||||
% make install VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
If you would like to know what files belong to the emu modules or
|
||||
the apel modules, or where they will be installed in, for example,
|
||||
please type the following command.
|
||||
|
||||
% make what-where LISPDIR=~/elisp VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
You can specify other optional settings by editing the file
|
||||
APEL-CFG. Please read comments in it.
|
||||
|
||||
** install as a XEmacs package
|
||||
|
||||
If you want to install to XEmacs package directory, please do
|
||||
following:
|
||||
|
||||
% make install-package
|
||||
|
||||
You can specify the emacs command name, for example
|
||||
|
||||
% make install-package XEMACS=xemacs-21
|
||||
|
||||
If `XEMACS=...' is omitted, XEMACS=xemacs is used.
|
||||
|
||||
You can specify the package directory, for example:
|
||||
|
||||
% make install PACKAGEDIR=~/.xemacs
|
||||
|
||||
If `PACKAGEDIR=...' is omitted, the first existing package
|
||||
directory is used.
|
||||
|
||||
Notice that XEmacs package system requires XEmacs 21.0 or later.
|
||||
|
||||
|
||||
** make.bat (for MS-DOS family)
|
||||
|
||||
make.bat is available for MS-DOS family. You have to edit
|
||||
make.bat if you want to use it. If you use cygwin environment,
|
||||
you can use make.exe and Makefile instead of make.bat.
|
||||
|
||||
In make.bat, a line which contain `rem' in its beginning is a
|
||||
comment. You have to insert or delete `rem', if necessary.
|
||||
|
||||
Default setups of make.bat is;
|
||||
|
||||
set MEADOWVER=1.10
|
||||
set PREFIX=c:\usr\meadow
|
||||
set EMACS=%PREFIX%\%MEADOWVER%\bin\meadow95.exe
|
||||
set LISPDIR=%PREFIX%\site-lisp
|
||||
set VLISPDIR=%PREFIX%\%MEADOWVER%\site-lisp
|
||||
|
||||
It assumes that meadow executable binary exists in
|
||||
c:\usr\meadow\1.10\bin\meadow95.exe. On such basis make.bat will
|
||||
try to install meadow version independent modules of APEL to;
|
||||
|
||||
c:\usr\meadow\site-lisp
|
||||
|
||||
and meadow version dependent modules to;
|
||||
|
||||
c:\usr\meadow\1.10\site-lisp
|
||||
|
||||
Please edit make.bat for your own environment and run make.bat
|
||||
|
||||
Emacs 19.3x or earlier does not have (e.x. Mule for Windows based on
|
||||
19.28) an Emacs version dependent site-lisp directory
|
||||
(e.x. c:\usr\meadow\1.10\site-lisp), and its load-path does not refer
|
||||
to such directory by default. If you want install APEL to such an Emacs
|
||||
you may install all APEL modules to an Emacs version independent
|
||||
site-lisp directory such as c:\usr\mule\site-lisp.
|
||||
|
||||
We cannot provide you with a Demacs example for make.bat. If you install
|
||||
APEL to Demacs, please send us such an example to apel-en@m17n.org (you
|
||||
can post a message to the ML, even if you are not a member).
|
||||
|
||||
If you checkout APEL by using Windows native cvs.exe (not cygwin
|
||||
version), cvs.exe will regularize end of line codes, LF to CRLF. And
|
||||
it also will try to convert CRLF to CRCRLF. make.bat of which eol
|
||||
code is CRCRLF does not work, so if you get such a make.bat, edit it
|
||||
to really regularize eol codes to CRLF. If you need further
|
||||
information, see the following URL (n.b. Japanese only)
|
||||
|
||||
http://openlab.ring.gr.jp/skk/cvswin-ja.html
|
||||
|
||||
* load-path (for Emacs or MULE)
|
||||
|
||||
If you are using Emacs or Mule, please add directory of apel to
|
||||
load-path. If you install by default setting with Emacs 19.29 or
|
||||
later or Emacs 20.1/20.2, you can write subdirs.el for example:
|
||||
|
||||
--------------------------------------------------------------------
|
||||
(normal-top-level-add-to-load-path '("apel"))
|
||||
--------------------------------------------------------------------
|
||||
|
||||
If you are using Emacs 20.3 or later or XEmacs, there are no need to
|
||||
set up load-path with normal installation.
|
||||
|
||||
|
||||
* Version specific information
|
||||
|
||||
** For Emacs 18 users: "old byte-compiler" vs "new byte-compiler"
|
||||
|
||||
In this package, we use compile-time evaluation heavily.
|
||||
Unfortunately, the byte-compiler bundled with Emacs 18 (the "old
|
||||
byte-compiler") does not have features such as `eval-when-compile'
|
||||
and `eval-and-compile', and our emulation version of these macros
|
||||
evaluate "compile-time evaluation" at load-time or at run-time!
|
||||
In addition, the "old byte-compiler" cannot compile top-level use of
|
||||
macros and leaves most of our code uncompiled.
|
||||
|
||||
Therefore, we recommend you to use the "new" optimizing byte-compiler.
|
||||
It is the origin of byte-compiler bundled with Emacs 19 and later.
|
||||
|
||||
Optimizing byte-compiler for Emacs 18 is available from the Emacs
|
||||
Lisp Archive and its mirrors.
|
||||
|
||||
In Mule 1.* days, "contrib" package for Mule 1.* was distributed and
|
||||
it contained the "new byte-compiler" for Mule. But, I think it is
|
||||
difficult to obtain this package now.
|
||||
|
||||
AFAIK, the "new byte-compiler" for Emacs 18 is also bundled with SKK
|
||||
9.6 or SKK 10.62a. You can get SKK 10.62a from the following URL;
|
||||
|
||||
http://openlab.ring.gr.jp/skk/maintrunk
|
||||
|
||||
They include patch for Mule 1.*.
|
||||
|
||||
|
||||
** For Emacs 19.34 and XEmacs 19.14 users: "old custom" vs "new custom"
|
||||
|
||||
"custom" library bundled with Emacs 19.32 - 19.34, XEmacs 19.14, and
|
||||
Gnus 5.2/5.3 is "old", its API is incompatible with "new custom"
|
||||
bundled with Emacs 20.1, XEmacs 19.15, or newer, and Gnus 5.4/5.5.
|
||||
|
||||
"new custom" for Emacs 19.34 and XEmacs 19.15 - 20.2 is available
|
||||
from the following URL.
|
||||
|
||||
ftp://ftp.dina.kvl.dk/pub/Staff/Per.Abrahamsen/custom/custom-1.9962.tar.gz
|
||||
|
||||
(Note that "new custom" bundled with XEmacs 19.15 - 20.2, and Gnus
|
||||
5.4/5.5 is older than this version.)
|
||||
|
||||
Before installing "new custom", you should check the following points.
|
||||
|
||||
1) If you stick to Gnus 5.2/5.3 (or any other applications which
|
||||
use "old custom"), you should not install "new custom".
|
||||
|
||||
2) If you use Mule (based on Emacs 19), you must apply this patch
|
||||
to "new custom".
|
||||
|
||||
----8<------8<------8<------8<------8<------8<------8<------8<----
|
||||
--- custom-1.9962/cus-face.el~ Wed Mar 4 19:52:39 1998
|
||||
+++ custom-1.9962/cus-face.el Mon Mar 9 08:05:33 1998
|
||||
@@ -96,7 +96,7 @@
|
||||
"Define a new FACE on all frames, ignoring X resources."
|
||||
(interactive "SMake face: ")
|
||||
(or (internal-find-face name)
|
||||
- (let ((face (make-vector 8 nil)))
|
||||
+ (let ((face (make-vector face-vector-length nil)))
|
||||
(aset face 0 'face)
|
||||
(aset face 1 name)
|
||||
(let* ((frames (frame-list))
|
||||
----8<------8<------8<------8<------8<------8<------8<------8<----
|
||||
|
||||
3) Applications compiled with "custom" require the same version of
|
||||
"custom" at load-time (and run-time). Therefore, if you use "new
|
||||
custom", you must always include "new custom" in your load-path.
|
||||
The easiest way to achieve this is "subdirs.el"; if you installed
|
||||
"new custom" in "/usr/local/share/emacs/19.34/site-lisp/custom/",
|
||||
put the following line to "/usr/local/share/emacs/19.34/site-lisp/subdirs.el".
|
||||
|
||||
(normal-top-level-add-to-load-path '("custom"))
|
||||
|
||||
|
||||
* How to use
|
||||
|
||||
** alist
|
||||
|
||||
*** Function 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.
|
||||
|
||||
*** Function del-alist (ITEM ALIST)
|
||||
|
||||
If there is a pair whose key is ITEM, delete it from ALIST.
|
||||
|
||||
*** Function set-alist (SYMBOL ITEM VALUE)
|
||||
|
||||
Modify a alist indicated by SYMBOL to set VALUE to ITEM.
|
||||
|
||||
Ex. (set-alist 'auto-mode-alist "\\.pln$" 'text-mode)
|
||||
|
||||
*** Function modify-alist (MODIFIER DEFAULT)
|
||||
|
||||
Modify alist DEFAULT into alist MODIFIER.
|
||||
|
||||
*** Function set-modified-alist (SYMBOL MODIFIER)
|
||||
|
||||
Modify a value of a SYMBOL into alist MODIFIER. The SYMBOL should be
|
||||
alist. If it is not bound, its value regard as nil.
|
||||
|
||||
** path-util
|
||||
|
||||
*** Function 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 `default-load-path')
|
||||
|
||||
home directory relative: "~/PATH" "~USER/PATH"
|
||||
|
||||
absolute path: "/FOO/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'
|
||||
|
||||
*** Function add-latest-path (PATTERN &optional ALL-PATHS)
|
||||
|
||||
Add latest path matched by regexp PATTERN to `load-path' if it
|
||||
exists under `default-load-path' directories and it does not exist
|
||||
in `load-path'.
|
||||
|
||||
For example, if there is bbdb-1.50 and bbdb-1.51 under site-lisp,
|
||||
and if bbdb-1.51 is newer than bbdb-1.50, and site-lisp is
|
||||
/usr/local/share/emacs/site-lisp,
|
||||
|
||||
(add-latest-path "bbdb")
|
||||
|
||||
it adds "/usr/local/share/emacs/site-lisp/bbdb-1.51" to top of
|
||||
`load-path'.
|
||||
|
||||
If optional argument ALL-PATHS is specified, it is searched from all
|
||||
of `load-path' instead of `default-load-path'.
|
||||
|
||||
*** Function 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.
|
||||
|
||||
Ex. (let ((gnus-path (get-latest-path "gnus")))
|
||||
(add-path (expand-file-name "lisp" gnus-path))
|
||||
(add-to-list 'Info-default-directory-list
|
||||
(expand-file-name "texi" gnus-path)))
|
||||
|
||||
*** Function file-installed-p (FILE &optional PATHS)
|
||||
|
||||
Return absolute-path of FILE if FILE exists in PATHS. If PATHS is
|
||||
omitted, `load-path' is used.
|
||||
|
||||
*** Function 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.
|
||||
|
||||
*** Function module-installed-p (MODULE &optional PATHS)
|
||||
|
||||
Return non-nil if MODULE is provided or exists in PATHS. If PATHS is
|
||||
omitted, `load-path' is used.
|
||||
|
||||
** filename
|
||||
|
||||
*** Function replace-as-filename (string)
|
||||
|
||||
Return safety file-name from STRING.
|
||||
|
||||
It refers variable `filename-filters'. It is list of functions for
|
||||
file-name filter. Default filter refers following variables:
|
||||
|
||||
**** Variable filename-limit-length
|
||||
|
||||
Limit size of file-name.
|
||||
|
||||
**** Variable filename-replacement-alist
|
||||
|
||||
Alist list of characters vs. string as replacement. List of
|
||||
characters represents characters not allowed as file-name.
|
||||
|
||||
* Bug reports
|
||||
|
||||
If you write bug-reports and/or suggestions for improvement, please
|
||||
send them to the APEL Mailing List:
|
||||
|
||||
apel-en@m17n.org (English)
|
||||
apel-ja@m17n.org (Japanese)
|
||||
|
||||
Via the APEL ML, you can report APEL bugs, obtain the latest release
|
||||
of APEL, and discuss future enhancements to APEL. To join the APEL
|
||||
ML, send an empty e-mail to
|
||||
|
||||
apel-en-ctl@m17n.org (English)
|
||||
apel-ja-ctl@m17n.org (Japanese)
|
||||
|
||||
|
||||
* Anonymous FTP
|
||||
|
||||
Latest release of APEL can be obtained from:
|
||||
|
||||
ftp://ftp.m17n.org/pub/mule/apel/
|
||||
|
||||
|
||||
* CVS
|
||||
|
||||
Development of APEL uses CVS. So latest developing version is
|
||||
available at CVS.
|
||||
|
||||
** cvs login (first time only)
|
||||
|
||||
% cvs -d :pserver:anonymous@cvs.m17n.org:/cvs/root login
|
||||
|
||||
CVS password: [CR] # NULL string
|
||||
|
||||
** checkout
|
||||
|
||||
% cvs -d :pserver:anonymous@cvs.m17n.org:/cvs/root checkout apel
|
||||
|
||||
If you would like to join CVS based development, please send mail to
|
||||
|
||||
cvs@cvs.m17n.org
|
||||
|
||||
with your account name and your public key for ssh. cvsroot is
|
||||
:ext:cvs@cvs.m17n.org:/cvs/root.
|
||||
|
||||
We hope you will join the open development.
|
||||
585
apel-10.7/README.ja
Normal file
585
apel-10.7/README.ja
Normal file
@ -0,0 +1,585 @@
|
||||
-*- outline -*-
|
||||
|
||||
[APEL $B$N(B README ($BF|K\8lHG(B)]
|
||||
|
||||
* APEL $B$H$O!)(B
|
||||
|
||||
APEL $B$O(B "A Portable Emacs Library." $B$NN,$G$9!#$3$l$O0J2<$N%b%8%e!<%k$G(B
|
||||
$B9=@.$5$l$F$$$^$9(B:
|
||||
|
||||
** poe.el
|
||||
|
||||
$B<g$K:G?7$N(B emacs $B4D6-$N$?$a$N4pACE*$J4X?t$HFC<l7A<0(B/$B%^%/%m$N(B emulation
|
||||
$B$N%b%8%e!<%k!#(B
|
||||
|
||||
poe-xemacs.el --- XEmacs$BMQ(B
|
||||
poe-18.el --- Emacs 18/Nemacs $BMQ(B
|
||||
env.el --- Emacs 18 $BMQ$N(B env.el
|
||||
localhook.el --- Emacs 18 $B$H(B Emacs 19.28 $B0JA0MQ$N(B hook $B4X?t72(B
|
||||
pym.el --- poe $B$N$?$a$N(B macros
|
||||
|
||||
** poem.el
|
||||
|
||||
$B0\?"@-$N9b$$(B MULE $B%W%m%0%i%`$r=q$/$?$a$N4pACE*$J4X?t$rDs6!$9$k!#(B
|
||||
|
||||
poem-nemacs.el --- Nemacs $BMQ(B
|
||||
poem-ltn1.el --- MULE $B$J$7(B Emacs 19/XEmacs $BMQ(B
|
||||
poem-om.el --- MULE 1.*, 2.* $BMQ(B
|
||||
poem-20.el --- Emacs 20 $B$H(B XEmacs-MULE $B$N6&M-%b%8%e!<%k(B
|
||||
poem-e20_2.el --- Emacs 20.1/20.2 $BMQ(B
|
||||
poem-e20_3.el --- Emacs 20.3 $BMQ(B
|
||||
poem-xm.el --- XEmacs-MULE $BMQ(B
|
||||
|
||||
** pces.el
|
||||
|
||||
$B0\?"@-$N9b$$(B character encoding $B%9%-!<%`(B (coding-system) $B$rDs6!$9$k!#(B
|
||||
|
||||
pces-20.el --- coding-system $B5!G=$r;}$D(B Emacs 20 and XEmacs $BMQ(B
|
||||
pces-e20.el --- Emacs 20 $BMQ(B
|
||||
pces-e20_2.el --- Emacs 20.1 and 20.2 $BMQ(B
|
||||
pces-nemacs.el --- Nemacs $BMQ(B
|
||||
pces-om.el --- Mule 1.* and Mule 2.* $BMQ(B
|
||||
pces-raw.el --- coding-system $B5!G=$r;}$?$J$$(B emacsen $BMQ(B
|
||||
pces-xfc.el --- file coding $B5!G=$r;}$D(B XEmacs $BMQ(B
|
||||
pces-xm.el --- XEmacs-mule $BMQ(B
|
||||
|
||||
** invisible.el --- $BIT2D;k(B region $B$K4X$9$k5!G=$rDs6!$9$k(B
|
||||
|
||||
inv-18.el --- for Emacs 18
|
||||
inv-19.el --- for Emacs 19
|
||||
inv-xemacs.el --- for XEmacs
|
||||
|
||||
** mcharset.el --- MIME charset $B4XO"$N5!G=$rDs6!$9$k(B
|
||||
|
||||
mcs-nemacs.el --- Nemacs $BMQ(B
|
||||
mcs-ltn1.el --- MULE Emacs 19/XEmacs $BMQ(B
|
||||
mcs-om.el --- MULE 1.*, 2.* $BMQ(B
|
||||
mcs-20.el --- Emacs 20 $B$H(B XEmacs-MULE $BMQ$N6&M-%b%8%e!<%k(B
|
||||
mcs-e20.el --- Emacs 20 $BMQ(B
|
||||
mcs-xm.el --- XEmacs-MULE $BMQ(B
|
||||
mcs-xmu.el --- XEmacs-MULE $BMQ(B (ISO646 $BJ8;z$NC10l2=(B)
|
||||
|
||||
** static.el --- $B@EE*I>2A$N$?$a$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
** broken.el --- Emacs $B$N2u$l$F$$$k5!G=$N>pJs$rDs6!$9$k(B
|
||||
|
||||
** pccl.el --- $B0\?"2DG=$J(B CCL $B%W%m%0%i%`$r=q$/$?$a$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
pccl-om.el --- MULE 2.* $BMQ(B
|
||||
pccl-20.el --- Emacs 20/XEmacs-21-MULE $BMQ(B
|
||||
|
||||
** alist.el: $BO"A[%j%9%H$N$?$a$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
** calist.el: $B>uBVLZ$H>uBV(B/$B>u67O"A[%j%9%HMQ$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
** path-util.el: $B%Q%94IM}$H%U%!%$%kC5:w$N$?$a$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
** filename.el:$B%U%!%$%kL>$r:n$k$?$a$N%f!<%F%#%j%F%#(B
|
||||
|
||||
** install.el: emacs-lisp $B%Q%C%1!<%8%$%s%9%H!<%k$9$k$?$a$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
** mule-caesar.el: ROT 13-47-48 Caesar $BJQ49$N%f!<%F%#%j%F%#!<(B
|
||||
|
||||
** emu.el
|
||||
|
||||
tm-7.106 $B$KF~$C$F$$$?(B emu $B$H$N8_49@-$rJ]$D$?$a$N%b%8%e!<%k!#(Bpoe, poem,
|
||||
mcharset $B$r(B require $B$9$k!#(B
|
||||
|
||||
emu-mule: MULE 1.*, 2.* $BMQ(B
|
||||
|
||||
richtext.el --- Emacs 19.29 $B$+$=$l0J9_(B XEmacs 19.14 $B$+$=$l0J9_$N$?(B
|
||||
$B$a$N(B text/richtext $B%b%8%e!<%k(B
|
||||
tinyrich.el --- $B8E$$(B emacs $B4D6-$N$?$a$N(B text/richtext $B%b%8%e!<%k(B
|
||||
|
||||
** pcustom.el --- $B0\?"@-$N9b$$(B custom $B4D6-$rDs6!$9$k(B
|
||||
|
||||
tinycustom.el --- custom.el $B$N%(%_%e%l!<%7%g%s$r9T$J$&(B
|
||||
|
||||
** timezone.el
|
||||
|
||||
$B%?%$%`%>!<%s%f!<%F%#%j%F%#!#(B2000 $BG/LdBjBP1~HG!#(BEmacs 18 $B$H(B GNUS 3.14.4
|
||||
$B$G$bF0:n2D!#(B
|
||||
|
||||
** product.el --- $B%W%m%@%/%H$N%P!<%8%g%s>pJs$N$?$a$N5!G=$rDs6!$9$k%b%8%e!<%k!#(B
|
||||
|
||||
|
||||
* $B%$%s%9%H!<%k(B
|
||||
|
||||
** $BE83+$7$?>l=j$G<B9T(B
|
||||
|
||||
$BB>$N%G%#%l%/%H%j!<$K%$%s%9%H!<%k$7$?$/$J$$$J$i!"0J2<$N$3$H$@$1$r$d$C$F(B
|
||||
$B$/$@$5$$(B (MS-DOS $B7O$N(B OS $B$N$?$a$K(B MAKEIT.BAT $B$,MQ0U$5$l$F$$$^$9!#(B
|
||||
MAKEIT.BAT $B$NMxMQ$K$D$$$F$O2<5-!V(BMAKEIT.BAT $B$rMxMQ$9$k(B (MS-DOS $B7O(B OS
|
||||
$B$N>l9g(B)$B!W$r;2>H$7$F2<$5$$(B)$B!#(B:
|
||||
|
||||
% make
|
||||
|
||||
emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make EMACS=xemacs
|
||||
|
||||
`EMACS=...' $B$,>JN,$5$l$k$H!"(BEmacs=emacs $B$,;H$o$l$^$9!#(B
|
||||
|
||||
** make install
|
||||
|
||||
$BB>$N%G%#%l%/%H%j!<$K%$%s%9%H!<%k$7$?$$$J$i!"0J2<$N$3$H$r$7$F$/$@$5$$(B:
|
||||
|
||||
% make install
|
||||
|
||||
emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make install EMACS=xemacs
|
||||
|
||||
`EMACS=...' $B$,>JN,$5$l$k$H!"(BEmacs=emacs $B$,;H$o$l$^$9!#(B
|
||||
|
||||
Emacs Lisp $B%W%m%0%i%`$H%7%'%k%9%/%j%W%H$N$?$a$N%G%#%l%/%H%j!<LZ$N@\F,(B
|
||||
$B<-(B (prefix) $B$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make install PREFIX=~/
|
||||
|
||||
`PREFIX=...' $B$,>JN,$5$l$k$H!";XDj$5$l$?(B emacs $B%3%^%s%I$N%G%#%l%/%H%j!<(B
|
||||
$BLZ$N@\F,<-$,;HMQ$5$l$^$9(B ($B$*$=$i$/(B /usr/local $B$G$9(B)$B!#(B
|
||||
|
||||
$BNc$($P!"(BPREFIX=/usr/local $B$H(B Emacs 20.2 $B$,;XDj$5$l$l$P!"0J2<$N%G%#%l%/(B
|
||||
$B%H%j!<LZ$,:n@.$5$l$^$9!#(B
|
||||
|
||||
/usr/local/share/emacs/20.2/site-lisp/ --- emu
|
||||
/usr/local/share/emacs/site-lisp/apel/ --- APEL
|
||||
|
||||
Emacs Lisp $B%W%m%0%i%`$N$?$a$N(B lisp $B%G%#%l%/%H%j!<$r;XDj$9$k$3$H$,$G$-(B
|
||||
$B$^$9!#Nc$($P!"(B:
|
||||
|
||||
% make install LISPDIR=~/elisp
|
||||
|
||||
emu $B%b%8%e!<%k$,%$%s%9%H!<%k$5$l$k!"%P!<%8%g%sFCM-$N(B lisp $B%G%#%l%/%H%j!<(B
|
||||
$B$r;XDj$9$k$3$H$b$G$-$^$9!#Nc$($P!"(B:
|
||||
|
||||
% make install VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
$B$I$N%U%!%$%k$,(B emu $B%b%8%e!<%k$+(B apel $B%b%8%e!<%k$N0lIt$J$N$+!"$=$l$i$,(B
|
||||
$B$I$3$K%$%s%9%H!<%k$5$l$k$+$rCN$j$?$$$H$-$O!"<!$N$h$&$J%3%^%s%I$rF~NO$9(B
|
||||
$B$k$3$H$,$G$-$^$9!#(B
|
||||
|
||||
% make what-where LISPDIR=~/elisp VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
$B%U%!%$%k(B APEL-CFG $B$rJT=8$9$k$3$H$GB>$NA*Br<+M3$J@_Dj$r;XDj$9$k$3$H$,$G(B
|
||||
$B$-$^$9!#$=$NCf$N%3%a%s%H$rFI$s$G$/$@$5$$!#(B
|
||||
|
||||
** XEmacs $B$N%Q%C%1!<%8$H$7$F%$%s%9%H!<%k$9$k(B
|
||||
|
||||
XEmacs $B$N%Q%C%1!<%8%G%#%l%/%H%j!<$K%$%s%9%H!<%k$9$k>l9g$O!"0J2<$N$3$H(B
|
||||
$B$r$7$F$/$@$5$$(B:
|
||||
|
||||
% make install-package
|
||||
|
||||
emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make install-package XEMACS=xemacs-21
|
||||
|
||||
`XEMACS=...' $B$,>JN,$5$l$k$H!"(BXEMACS=xemacs $B$,;HMQ$5$l$^$9!#(B
|
||||
|
||||
$B%Q%C%1!<%8$N%G%#%l%/%H%j!<$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P(B:
|
||||
|
||||
% make install PACKAGEDIR=~/.xemacs
|
||||
|
||||
`PACKAGEDIR=...' $B$,>JN,$5$l$k$H!"B8:_$9$k%Q%C%1!<%8%G%#%l%/%H%j!<$N:G(B
|
||||
$B=i$N$b$N$,;H$o$l$^$9!#(B
|
||||
|
||||
XEmacs $B$N%Q%C%1!<%8%7%9%F%`$O(B XEmacs 21.0 $B$+$=$l0J9_$rMW5a$9$k$3$H$KCm(B
|
||||
$B0U$7$F$/$@$5$$!#(B
|
||||
|
||||
** MAKEIT.BAT $B$rMxMQ$9$k(B (MS-DOS $B7O(B OS $B$N>l9g(B)
|
||||
|
||||
MS-DOS $B7O$N(B OS $B$N$?$a$K(B MAKEIT.BAT $B$H(B MAKE1.BAT $B$,MQ0U$5$l$F$$$^$9(B
|
||||
(cygwin $B4D6-$rMxMQ$7$F$$$kJ}$O(B make.exe $B$H(B Makefile $B$rMxMQ$9$k$3$H$,$G(B
|
||||
$B$-$^$9(B)$B!#(BMAKEIT.BAT $B$O!"%$%s%9%H!<%k$N4D6-JQ?t$r@_Dj$7$?8e$K(B MAKE1.BAT
|
||||
$B$r8F=P$7$^$9!#(BMAKE1.BAT $B$K$h$C$F<B:]$N%$%s%9%H!<%k$KI,MW$J%3%^%s%I$,<B(B
|
||||
$B9T$5$l$^$9!#(B
|
||||
|
||||
$B$3$l$i$rMxMQ$9$k$K$O(B MAKEIT.BAT $B$rJT=8$9$k$3$H$,I,MW$G$9!#0BA4$N$?$a$9(B
|
||||
$B$Y$F$N4D6-JQ?t$N%G%U%)%k%H$NCM$O6uJ8;zNs$K$J$C$F$$$^$9!#$*;H$$$N%7%9%F(B
|
||||
$B%`$K$"$o$;$F$3$l$i$NJQ?t$r;XDj$7$F$/$@$5$$!#(B
|
||||
|
||||
$B3+H/!"F0:n3NG'$,(B Windows $B$G$7$+9T$J$o$l$F$$$J$$$?$a!"8E$$%P!<%8%g%s$N(B
|
||||
DOS $B$G$OF0:n$7$J$$2DG=@-$,$"$j$^$9!#ITET9g$rH/8+$7$?J}$O(B
|
||||
apel-ja@m17n.org $B$^$G$4O"Mm2<$5$$!#(B
|
||||
|
||||
*** MAKEIT.BAT $B$NJT=8(B
|
||||
|
||||
DOS $B$N%P%C%A%U%!%$%k$NCf$G$O(B `rem' $B$,9TF,$K$"$k9T$O%3%a%s%H$H$7$F07$o(B
|
||||
$B$l$^$9!#I,MW$K1~$8!"(BMAKEIT.BAT $B$N3F9TF,$K(B `rem' $B$rA^F~$7$?$j!"$^$?$O:o(B
|
||||
$B=|$7$?$j$7$F2<$5$$!#(B
|
||||
|
||||
$B$^$?!"%P%C%A%U%!%$%kFb$N(B `%$BJQ?tL>(B%' $B$O<B9T;~$N4D6-JQ?t$NCM$HCV$-49$($i(B
|
||||
$B$l$^$9!#(B
|
||||
|
||||
c:\usr\Meadow $B$K%$%s%9%H!<%k$5$l$F$$$k(B 1.10 $B$N(B Meadow $B$r;HMQ(B
|
||||
$B$7$F$$$k>l9g$NJQ?t@_Dj$NNc$r5s$2$^$9!#(B
|
||||
|
||||
set PREFIX=c:\usr\Meadow
|
||||
set EMACS=%PREFIX%\1.10\bin\meadow95.exe
|
||||
set EXEC_PREFIX=
|
||||
set LISPDIR=%PREFIX%\site-lisp
|
||||
set VERSION_SPECIFIC_LISPDIR=%PREFIX%\1.10\site-lisp
|
||||
set DEFAULT_MAKE_ARG=elc
|
||||
|
||||
$B>e5-$NNc$G$O!"(Bmeadow $B$N%P%$%J%j$,(B c:\usr\Meadow\1.10\bin\meadow95.exe
|
||||
$B$K%$%s%9%H!<%k$5$l$F$$$k$3$H$rA0Ds$K$7$F$$$^$9!#$=$NA0Ds$K4p$E$-!"(BAPEL
|
||||
$B$N%b%8%e!<%k$N$&$A!"(Bmeadow $B$N%P!<%8%g%s$K0MB8$7$J$$%b%8%e!<%k$r(B
|
||||
|
||||
c:\usr\Meadow\site-lisp
|
||||
|
||||
$B$K!"%P!<%8%g%s$K0MB8$9$k%b%8%e!<%k$r(B
|
||||
|
||||
c:\usr\Meadow\1.10\site-lisp
|
||||
|
||||
$B$K%$%s%9%H!<%k$7$h$&$H$7$^$9!#(B
|
||||
|
||||
19.3x $B0JA0$N(B Emacs ($BNc$($P(B 19.28 $B%Y!<%9$N(B Mule for Windows) $B$K$O%P!<%8%g(B
|
||||
$B%s0MB8$N(B site-lisp $B%G%#%l%/%H%j(B ($B>e5-$NNc$G8@$($P(B
|
||||
c:\usr\Meadow\1.10\site-lisp) $B$,B8:_$;$:!"%G%#%U%)%k%H$G$O(B load-path $B$b(B
|
||||
$BDL$C$F$$$^$;$s!#$3$N>l9g$O(B c:\usr\mule\site-lisp $B$J$I$N%P!<%8%g%sHs0MB8(B
|
||||
$B$N(B site-lisp $B%G%#%l%/%H%j$K(B APEL $B$NA4$F$N%b%8%e!<%k$rF~$l$l$PNI$$$G$7$g(B
|
||||
$B$&!#(B
|
||||
|
||||
Demacs $B$N@_DjNc$r=`Hw$9$k$3$H$,$G$-$^$;$s$G$7$?!#(BDemacs $B$K(B APEL $B$r%$%s(B
|
||||
$B%9%H!<%k$7$?J}$O!"@_DjNc$r(B apel-ja@m17n.org $B$KAw$C$F2<$5$$(B ($BHs9XFI<T$G(B
|
||||
$B$bAw?.$O$G$-$^$9(B)$B!#(B
|
||||
|
||||
|
||||
*** MAKEIT.BAT $B$NJT=8$N:]!"CN$C$F$*$/$HJXMx$J(B Tips
|
||||
|
||||
$B0z?t$r;XDj$7$J$$$G(B MAKEIT.BAT $B$r<B9T$5$;$k$H!"(BDEFAULT_MAKE_ARG $B$K;XDj(B
|
||||
$B$5$l$F$$$k(B target $B$,<B9T$5$l$^$9(B ($B%G%#%U%)%k%H$O0BA4$N$?$a$K(B target $B$,(B
|
||||
$B6u$K$J$C$F$*$j!"%a%C%;!<%8$@$1EG$$$F;_$^$k$h$&$K$J$C$F$^$9(B)$B!#(B
|
||||
|
||||
MAKEIT.BAT $B$rJT=8$7$F!"(B
|
||||
|
||||
set DEFAULT_MAKE_ARG=install
|
||||
|
||||
$B$H5-=R$7$F$*$/$3$H$G!"(BMAKEIT.BAT $B$r%@%V%k%/%j%C%/$9$k$@$1$G%$%s%9%H!<(B
|
||||
$B%k$9$k$3$H$,$G$-$^$9!#(B
|
||||
|
||||
MAKEIT.BAT $B$O!"2<5-$N$$$:$l$+$N%U%!%$%k$,B8:_$9$k$H$-$O!"$=$N%U%!%$%k(B
|
||||
$B$N@_Dj$rM%@h$7$FFI$_9~$`$N$G!"E,59JT=8$7$?(B MAKEIT.BAT $B$O2<5-$N$$$:$l$+(B
|
||||
$B$N%U%!%$%k$H$7$F!"%3%T!<$7$F%-!<%W$7$F$*$/$H!"%"%C%W%0%l!<%I$N:]$K(B
|
||||
MAKEIT.BAT $B$r:FJT=8$9$kI,MW$,$J$/JXMx$G$9!#(B
|
||||
|
||||
$BM%@h=g$KJB$Y$k$H2<5-$N$h$&$K$J$j$^$9!#2<5-$N(B 1-x $B$O(B apel $B@lMQ!"(B2-x $B$O(B
|
||||
$BF1<o$N(B MAKEIT.BAT $B$rMxMQ$7$F$$$k(B cmail, skk $B$H6&DL$7$FMxMQ$9$k$3$H$,$G(B
|
||||
$B$-$^$9!#(B
|
||||
|
||||
1-1. %HOME%\.elispmk.apel.bat
|
||||
1-2. %HOME%\elisp\elispmk.apel.bat
|
||||
1-3. %HOME%\config\elispmk.apel.bat
|
||||
1-4. c:\Program Files\Meadow\elispmk.apel.bat
|
||||
1-5. c:\Meadow\elispmk.apel.bat
|
||||
1-6. d:\Meadow\elispmk.apel.bat
|
||||
|
||||
2-1. %HOME%\.elispmk.bat
|
||||
2-2. %HOME%\elisp\elispmk.bat
|
||||
2-3. %HOME%\config\elispmk.bat
|
||||
2-4. c:\Program Files\Meadow\elispmk.bat
|
||||
2-5. c:\Meadow\elispmk.bat
|
||||
2-6. d:\Meadow\elispmk.bat
|
||||
|
||||
*** $B%P%C%A%U%!%$%k<B9T;~$NCm0U(B
|
||||
|
||||
MAKEIT.BAT, MAKE1.BAT $B$O4D6-JQ?t$rMxMQ$7$F$$$k$?$a$K!"<B9T;~$K4D6-JQ?t(B
|
||||
$B$N$?$a$N%a%b%j3dEv$F$,$G$-$:$K!"%(%i!<$K$J$k$3$H$,$"$j$^$9!#(BWindows $B$r(B
|
||||
$BMxMQ$7$F$$$k>l9g$O!"(BDOSPROMPT $B$N%W%m%Q%F%#$G4D6-JQ?t$N=i4|%5%$%:$,!V<+(B
|
||||
$BF0!W$K$J$C$F$$$k$H!"4D6-JQ?t$,@_Dj$G$-$J$$$H$$$&%(%i!<$,=P$k$N$G!"E,Ev(B
|
||||
$B$JCM(B (2048 $B$J$I(B) $B$rF~$l$F$*$/I,MW$,$"$j$^$9!#(Bnon Windows $B$N(B DOS $B$N>l9g(B
|
||||
$B$O!"(Bconfig.sys $B$K(B
|
||||
|
||||
SHELL=C:\COMMAND.COM /E:4096 /P
|
||||
|
||||
$B$J$I$H=q$-!"4D6-JQ?t$K3dEv$F2DG=$J%a%b%j$r3NJ]$7$^$9!#(BDOS $B$N%P!<%8%g%s(B
|
||||
$B$K$h$C$F(B /E:nnn $B$G;XDj$G$-$k4D6-JQ?tNN0h$N%5%$%:$N@)Ls$,0[$J$j!";XDj$N(B
|
||||
$B;EJ}$,0c$C$?$j!"FCDj$NCM$r;XDj$9$k$HIT6q9g$r@8$8$k2DG=@-$,$"$k$N$G>\$7(B
|
||||
$B$/$O$4MxMQ$N(B version $B$N%^%K%e%"%kEy$r$4Mw2<$5$$!#(B
|
||||
|
||||
*** Windows $B$N(B cvs.exe $B$G%A%'%C%/%"%&%H$7$?(B MAKEIT.BAT $B$rMxMQ$9$k>l9g$NLdBjE@(B
|
||||
|
||||
$B$J$*!"(BWindows $B%M%$%F%#%V$N(B cvs.exe (not cygwin) $B$rMxMQ$7$F(B APEL $B$r(B
|
||||
checkout $B$7$?>l9g$O!"(Bcvs.exe $B$K$h$j9TKv%3!<%I$,@55,2=$5$l$F(B CRCRLF $B$K(B
|
||||
$B$J$C$F$$$k2DG=@-$,$"$j$^$9!#$3$N$h$&$J>l9g!"(BMAKEIT.BAT, MAKE1.BAT $B$OF0(B
|
||||
$B$-$^$;$s$N$G9TKv%3!<%I$r(B CRLF $B$K=$@5$7$F$*;H$$2<$5$$!#$3$NLdBj$K$D$$$F(B
|
||||
$B>\$7$/$O!"(B
|
||||
|
||||
http://openlab.ring.gr.jp/skk/cvswin-ja.html
|
||||
|
||||
$B$r$4;2>H2<$5$$!#(B
|
||||
|
||||
* load-path$B!J(BEmacs $B$H(B MULE $B$N>l9g!K(B
|
||||
|
||||
$B$b$7(B Emacs $B$b$7$/$O(B Mule $B$r$*;H$$$J$i!"(BAPEL $B$r(B install $B$7$?>l=j$r(B
|
||||
load-path $B$KDI2C$7$F$/$@$5$$!#$b$7(B Emacs 19.29 $B0J9_$^$?$O(B Emacs 20.1,
|
||||
20.2 $B$r;H$C$F=i4|@_Dj$G%$%s%9%H!<%k$7$?$N$J$i!"<!$N$h$&$K(B subdirs.el
|
||||
$B$r=q$/$3$H$,$G$-$^$9!#(B
|
||||
|
||||
--------------------------------------------------------------------
|
||||
(normal-top-level-add-to-load-path '("apel"))
|
||||
--------------------------------------------------------------------
|
||||
|
||||
$B$b$7(B Emacs 20.3 $B0J9_$b$7$/$O(B XEmacs $B$r;H$C$FIaDL$K%$%s%9%H!<%k$9$k$N(B
|
||||
$B$J$i$P!"(Bload-path $B$r@_Dj$9$kI,MW$O$"$j$^$;$s!#(B
|
||||
|
||||
|
||||
* Emacs $B$N%P!<%8%g%s$K4XO"$7$?>pJs(B
|
||||
|
||||
** $B!V8E$$(B byte-compiler$B!W$H!V?7$7$$(B byte-compiler$B!W(B
|
||||
|
||||
Emacs 18 $B$N%f!<%6$N$_$J$5$s$X(B:
|
||||
|
||||
$B$3$N%Q%C%1!<%8$G$O%3%s%Q%$%k;~$K$*$1$k>r7oH=CG$r$?$/$5$s9T$J$C$F$$$^(B
|
||||
$B$9!#;DG0$J$,$i(B Emacs 18 $B$KIUB0$7$F$$$k(B byte-compiler $B$K$O!"Nc$($P(B
|
||||
`eval-when-compile' $B$d(B `eval-and-compile' $B$N5!G=$,L5$$$N$GBeMQIJ$N%^(B
|
||||
$B%/%m$rMQ0U$7$F$"$j$^$9$,!"$3$l$i$O%3%s%Q%$%k;~$@$1$G$J$/(B load $B;~$^$?(B
|
||||
$B$O<B9T;~$K$bF/$$$F$7$^$$$^$9(B! $B2C$($F!V8E$$(B byte-compiler$B!W$O%H%C%W(B
|
||||
$B%l%Y%k$N%^%/%m$r%3%s%Q%$%k$7$F$/$l$J$$$N$G!"(BAPEL $B$NB?$/$N%3!<%I$,%3(B
|
||||
$B%s%Q%$%k$5$l$J$$$^$^$K$J$C$F$7$^$$$^$9!#(B
|
||||
|
||||
$B$=$3$G!":GE,2=$r9T$J$&!V?7$7$$(B byte-compiler$B!W$r;H$&$3$H$r$*4+$a$7$^(B
|
||||
$B$9!#$=$l$O(B Emacs 19 $B0J9_$KIUB0$7$F$$$k(B byte-compiler $B$N85$K$J$C$F$$(B
|
||||
$B$k$b$N$G$9!#(B
|
||||
|
||||
$B:GE,2=$r9T$J$&(B byte-compiler $B$O(B Emacs Lisp Archive $B$*$h$S$=$l$i$N%_(B
|
||||
$B%i!<$+$iF~<j$9$k$3$H$,$G$-$^$9!#(B
|
||||
|
||||
Mule 1.* $B$N;~Be$K$O(B Mule $BMQ$N!V?7$7$$(B byte-compiler$B!W$r4^$`(B Mule 1.*
|
||||
$BMQ$N(B "contrib" $B%Q%C%1!<%8$,G[I[$5$l$F$$$^$7$?!#$7$+$78=:_$G$O$3$N%Q%C(B
|
||||
$B%1!<%8$r<j$KF~$l$k$3$H$OFq$7$$$G$7$g$&!#(B
|
||||
|
||||
$B2f!9$NCN$k8B$j$G$O(B Emacs 18 $BMQ$N!V?7$7$$(B byte-compiler$B!W$O(B SKK 9.6,
|
||||
$B$^$?$O(B SKK 10.62a $B$KIUB0$7$F$$$^$9!#(BSKK 10.62a $B$O(B
|
||||
|
||||
http://openlab.ring.gr.jp/skk/maintrunk
|
||||
|
||||
$B$+$iF~<j$9$k$3$H$,$G$-$^$9!#$3$l$i$O(B Mule 1.* $BMQ$N%Q%C%A$b4^$s$G$$$^$9!#(B
|
||||
|
||||
|
||||
** $B!V8E$$(B custom$B!W$H!V?7$7$$(B custom$B!W(B
|
||||
|
||||
Emacs 19.34 $B$H(B XEmacs 19.14 $B$N%f!<%6$N$_$J$5$s$X(B:
|
||||
|
||||
Emacs 19.32$B!A(B19.34$B!"(BXEmacs 19.14 $B$*$h$S(B Gnus 5.2/5.3 $B$K4^$^$l$F$$$k(B
|
||||
custom $B%i%$%V%i%j$O!V8E$$!W$b$N$G!"$3$l$N(B API $B$O(B Emacs 20.1 $B$^$?$O(B
|
||||
XEmacs 19.15 $B$h$j?7$7$$(B Emacsen $B$H(B Gnus 5.4/5.5 $B$K4^$^$l$F$$$k(B
|
||||
$B!V?7$7$$(B custom$B!W$H$O0c$C$F$$$^$9!#(B
|
||||
|
||||
Emacs 19.34 $B$H(B XEmacs 19.15$B!A(B20.2 $BMQ$N!V?7$7$$(B custom$B!W$O!"0J2<$N(B
|
||||
URL $B$+$i<j$KF~$l$k$3$H$,$G$-$^$9!#(B
|
||||
|
||||
ftp://ftp.dina.kvl.dk/pub/Staff/Per.Abrahamsen/custom/custom-1.9962.tar.gz
|
||||
|
||||
($BCm(B: XEmacs 19.15$B!A(B20.2 $B$H(B Gnus 5.4/5.5 $B$K4^$^$l$F$$$k!V?7$7$$(B custom$B!W(B
|
||||
$B$O$3$NHG$h$j8E$$$b$N$G$9!#(B)
|
||||
|
||||
$B!V?7$7$$(B custom$B!W$r%$%s%9%H!<%k$9$kA0$K!"<!$N3F9`L\$r%A%'%C%/$7$F2<(B
|
||||
$B$5$$!#(B
|
||||
|
||||
1) $B$b$7$"$J$?$,(B Gnus 5.2/5.3 ($B$^$?$OB>$N!V8E$$(B custom$B!W$r;H$&%"%W(B
|
||||
$B%j%1!<%7%g%s(B) $B$r;H$&$3$H$K8G<9$7$F$$$k$N$J$i$P!V?7$7$$(B custom$B!W(B
|
||||
$B$r%$%s%9%H!<%k$7$F$O$$$1$^$;$s!#(B
|
||||
|
||||
2) Emacs 19 $B$r85$K$7$?(B Mule $B$r;H$&$N$J$i$P!"$3$N%Q%C%A$r!V?7$7$$(B
|
||||
custom$B!W$KEv$F$kI,MW$,$"$j$^$9!#(B
|
||||
|
||||
----8<------8<------8<------8<------8<------8<------8<------8<----
|
||||
--- custom-1.9962/cus-face.el~ Wed Mar 4 19:52:39 1998
|
||||
+++ custom-1.9962/cus-face.el Mon Mar 9 08:05:33 1998
|
||||
@@ -96,7 +96,7 @@
|
||||
"Define a new FACE on all frames, ignoring X resources."
|
||||
(interactive "SMake face: ")
|
||||
(or (internal-find-face name)
|
||||
- (let ((face (make-vector 8 nil)))
|
||||
+ (let ((face (make-vector face-vector-length nil)))
|
||||
(aset face 0 'face)
|
||||
(aset face 1 name)
|
||||
(let* ((frames (frame-list))
|
||||
----8<------8<------8<------8<------8<------8<------8<------8<----
|
||||
|
||||
3) custom $B$r;H$&%3%s%Q%$%k$5$l$?%"%W%j%1!<%7%g%s$O!"$=$l$r(B load $B$9(B
|
||||
$B$k$H$-$d<B9T$9$k$H$-$KF1$8%P!<%8%g%s$N(B custom $B$rI,MW$H$7$^$9!#(B
|
||||
$B$7$?$,$C$F!"$$$D$b(B load-path $B$K!V?7$7$$(B custom$B!W$r4^$a$F$*$+$J(B
|
||||
$B$1$l$P$J$j$^$;$s!#(B
|
||||
$B$3$l$r9T$J$&$?$a$N$b$C$H$b4JC1$JJ}K!$O(B subdirs.el $B$r;H$&$3$H$G(B
|
||||
$B$9!#(B
|
||||
$B!V?7$7$$(B custom$B!W$,(B /usr/local/share/emacs/19.34/site-lisp/custom/
|
||||
$B$K%$%s%9%H!<%k$5$l$F$$$k$N$J$i$P!"(B
|
||||
/usr/local/share/emacs/19.34/site-lisp/subdirs.el $B$H$$$&%U%!%$(B
|
||||
$B%k$K0J2<$N9T$r=q$-9~$s$G2<$5$$!#(B
|
||||
|
||||
(normal-top-level-add-to-load-path '("custom"))
|
||||
|
||||
|
||||
* $B;H$$J}(B
|
||||
|
||||
** alist
|
||||
|
||||
*** $B4X?t(B put-alist (ITEM VALUE ALIST)
|
||||
|
||||
ALIST $B$r(B ITEM $B$NCM$,(B VALUE $B$K$J$k$h$&$K=$@5$7$^$9!#(Bcar $B$,(B ITEM $B$G$"(B
|
||||
$B$kBP$,B8:_$9$l$P!"$=$N(B cdr $B$r(B VALUE $B$GCV$-49$($^$9!#$=$N$h$&$JBP$,$J(B
|
||||
$B$1$l$P!"?7$7$$BP(B (ITEM . VALUE) $B$r:n$j!"(Bcar $B$,?7$7$$BP$G!"(Bcdr $B$,(B
|
||||
ALIST $B$G$"$k?7$7$$O"A[%j%9%H$rJV$7$^$9!#(B
|
||||
|
||||
*** $B4X?t(B del-alist (ITEM ALIST)
|
||||
|
||||
$BO"A[%j%9%H(B ALIST $B$K(B key $B$,(B ITEM $B$G$"$kBP$,$"$l$P!"$=$l$r(B ALIST $B$+$i<h(B
|
||||
$B$j=|$-$^$9!#(B
|
||||
|
||||
*** $B4X?t(B set-alist (SYMBOL ITEM VALUE)
|
||||
|
||||
SYMBOL $B$G;XDj$5$l$F$$$kO"A[%j%9%H$r!"(BITEM $B$NCM$,(B VALUE $B$G$"$k$h$&$K=$(B
|
||||
$B@5$7$^$9!#(B
|
||||
|
||||
$BNc(B. (set-alist 'auto-mode-alist "\\.pln$" 'text-mode)
|
||||
|
||||
*** $B4X?t(B modify-alist (MODIFIER DEFAULT)
|
||||
|
||||
$BO"A[%j%9%H(B DEFAULT $B$rO"A[%j%9%H(B MODIFIER $B$K=$@5$7$^$9!#(B
|
||||
|
||||
*** $B4X?t(B set-modified-alist (SYMBOL MODIFIER)
|
||||
|
||||
SYMBOL $B$NCM$rO"A[%j%9%H(B MODIFIER $B$K=$@5$7$^$9!#(BSYMBOL $B$OO"A[%j%9%H$G$"(B
|
||||
$B$kI,MW$,$"$j$^$9!#$=$l$,B+G{$5$l$F$$$J$1$l$P!"$=$NCM$r(B nil $B$H$_$J$7$^(B
|
||||
$B$9!#(B
|
||||
|
||||
** path-util
|
||||
|
||||
*** $B4X?t(B add-path (PATH &rest OPTIONS)
|
||||
|
||||
PATH $B$,(B `default-load-path' $B$N%G%#%l%/%H%j!<$N2<$KB8:_$7$F!"(B
|
||||
`load-path'$B$KB8:_$7$J$$$H$-$K!"$=$l$r(B `load-path' $B$KDI2C$7$^$9!#(B
|
||||
|
||||
$B<!$N$h$&$J(B PATH $B$NMM<0$r;H$&$3$H$,$G$-$^$9(B:
|
||||
|
||||
load-path $B$+$i$NAjBP(B: "PATH" ($B$=$l$O(B `default-load-path $B$+$iC5$5$l$^(B
|
||||
$B$9!#(B)
|
||||
|
||||
$B%[!<%`%G%#%l%/%H%j!<$+$i$NAjBP(B: "~/PATH" "~USER/PATH"
|
||||
|
||||
$B@dBP%Q%9(B: "/FOO/BAR/BAZ"
|
||||
|
||||
$B<!$N$h$&$J(B OPTIONS $B$r;XDj$9$k$3$H$,$G$-$^$9(B:
|
||||
|
||||
'all-paths --- `default-load-path $B$NBe$o$j(B `load-path' $B$+$iC5$7$^(B
|
||||
$B$9!#(B
|
||||
|
||||
'append --- PATH $B$r(B `load-path' $B$N:G8e$KDI2C$7$^$9!#(B
|
||||
|
||||
*** $B4X?t(B add-latest-path (PATTERN &optional ALL-PATHS)
|
||||
|
||||
$B@55,I=8=(B PATTERN $B$K9gCW$7$?:G?7$N%Q%9$,(B `default-load-path' $B$N2<$KB8:_(B
|
||||
$B$7$F$$$F!"(B`load-path' $B$N2<$KB8:_$7$F$$$J$$$H$-$K$=$l$r(B `load-path' $B$K(B
|
||||
$BDI2C$7$^$9!#(B
|
||||
|
||||
$BNc$($P!"(Bbbdb-1.50 $B$H(B bbdb-1.51 $B$,(B site-lisp $B$N2<$K$"$C$F!"(Bbbdb-1.51 $B$,(B
|
||||
bbdb-1.50 $B$h$j$b?7$7$/!"(Bsite-lisp $B$,(B /usr/local/share/emacs/site-lisp
|
||||
$B$G$"$k$H$-$O!"(B
|
||||
|
||||
(add-latest-path "bbdb")
|
||||
|
||||
$B$O(B "/usr/local/share/emacs/site-lisp/bbdb-1.51" $B$r(B `load-path' $B$N@hF,(B
|
||||
$B$KDI2C$7$^$9!#(B
|
||||
|
||||
$B>JN,2DG=$J0z?t(B ALL-PATHS $B$,;XDj$5$l$k$H!"(B`default-load-path' $B$N$+$o$j(B
|
||||
$B$K(B `load-path' $B$+$iC5$7$^$9!#(B
|
||||
|
||||
*** $B4X?t(B get-latest-path (PATTERN &optional ALL-PATHS)
|
||||
|
||||
$B@55,I=8=(B PATTERN $B$K9gCW$9$k(B default-load-path $B$K$"$k:G?7$N%G%#%l%/%H%j!<(B
|
||||
$B$rJV$7$^$9!#>JN,2DG=$J0z?t(B ALL-PATHS $B$,;XDj$5$l$k$H!"(Bdefault-load-path
|
||||
$B$NBe$o$j$K(B load-path $B$NA4$F$+$iC5$7$^$9!#(B
|
||||
|
||||
$BNc(B. (let ((gnus-path (get-latest-path "gnus")))
|
||||
(add-path (expand-file-name "lisp" gnus-path))
|
||||
(add-to-list 'Info-default-directory-list
|
||||
(expand-file-name "texi" gnus-path)))
|
||||
|
||||
*** $B4X?t(B file-installed-p (FILE &optional PATHS)
|
||||
|
||||
FILE $B$,(B PATHS $B$KB8:_$7$?>l9g!"(BFILE $B$N@dBP%Q%9$rJV$7$^$9!#(BPATHS $B$,>JN,(B
|
||||
$B$5$l$k$H!"(B`load-path' $B$,;H$o$l$^$9!#(B
|
||||
|
||||
*** $B4X?t(B exec-installed-p (FILE &optional PATHS SUFFIXES)
|
||||
|
||||
FILE $B$,(B PATHS $B$KB8:_$7$?>l9g$K(B FILE $B$N@dBP%Q%9$rJV$7$^$9!#(BPATHS $B$,>JN,(B
|
||||
$B$5$l$k$H!"(B`exec-path' $B$,;H$o$l$^$9!#(BSUFFIXES $B$,>JN,$5$l$k$H!"(B
|
||||
`exec-suffix-list' $B$,;H$o$l$^$9!#(B
|
||||
|
||||
*** $B4X?t(B module-installed-p (MODULE &optional PATHS)
|
||||
|
||||
MODULE $B$,Ds6!$5$l$F$$$k(B (provided) $B$+!"(BPATHS $B$KB8:_$9$k>l9g$K(B nil $B$G(B
|
||||
$B$J$$CM$rJV$7$^$9!#(BPATHS $B$,>JN,$5$l$k$H!"(B`load-path' $B$,;H$o$l$^$9!#(B
|
||||
|
||||
** filename
|
||||
|
||||
*** $B4X?t(B replace-as-filename (string)
|
||||
|
||||
STRING $B$+$i0BA4$J%U%!%$%kL>$rJV$7$^$9!#(B
|
||||
|
||||
$B$=$l$OJQ?t(B 'filename-filters' $B$r;2>H$7$^$9!#$=$NJQ?t$O%U%!%$%kL>$NA*(B
|
||||
$BJL4o$N$?$a$N4X?t$N%j%9%H$G$9!#=i4|@_Dj$NA*JL4o$O0J2<$NJQ?t$r;2>H$7$F$$(B
|
||||
$B$^$9!#(B
|
||||
|
||||
**** $BJQ?t(B filename-limit-length
|
||||
|
||||
$B%U%!%$%kL>$ND9$5$N@)8B!#(B
|
||||
|
||||
**** $BJQ?t(B filename-replacement-alist
|
||||
|
||||
$BJ8;z$HJ8;zNs$,BP$K$J$C$?%j%9%H$NO"A[%j%9%H$G$9!#J8;z$N%j%9%H$O%U%!%$%k(B
|
||||
$BL>$H$7$F5v$5$l$J$$J8;z$r8=$o$7$^$9!#(B
|
||||
|
||||
|
||||
* $B%P%0Js9p(B
|
||||
|
||||
$B%P%0Js9p$d2~A1$NDs0F$r=q$$$?$H$-$O!"@'Hs(B APEL $B%a!<%j%s%0%j%9%H$KAw$C$F(B
|
||||
$B$/$@$5$$(B:
|
||||
|
||||
apel-en@m17n.org ($B1Q8l(B)
|
||||
apel-ja@m17n.org ($BF|K\8l(B)
|
||||
|
||||
APEL ML $B$rDL$7$F!"(BAPEL $B$N%P%0$rJs9p$7$?$j!"(BAPEL $B$N:G?7$N%j%j!<%9$r<hF@(B
|
||||
$B$7$?$j!"(BAPEL $B$N>-Mh$N3HD%$N5DO@$r$7$?$j$9$k$3$H$,$G$-$^$9!#(BAPEL ML $B$K(B
|
||||
$B;22C$9$k$K$O!"6u$NEE;R%a!<%k$r(B
|
||||
|
||||
apel-en-ctl@m17n.org ($B1Q8l(B)
|
||||
apel-ja-ctl@m17n.org ($BF|K\8l(B)
|
||||
|
||||
$B$KAw$C$F$/$@$5$$!#(B
|
||||
|
||||
|
||||
* Anonymous FTP
|
||||
|
||||
$B:G?7$N(B APEL $B$N%j%j!<%9$O0J2<$N>l=j$+$i<hF@$G$-$^$9(B:
|
||||
|
||||
ftp://ftp.m17n.org/pub/mule/apel/
|
||||
|
||||
|
||||
* CVS
|
||||
|
||||
APEL $B$N3+H/$O(B CVS $B$r;H$C$F$$$^$9!#:G?7$N3+H/%P!<%8%g%s$r(B CVS $B$G<hF@$G(B
|
||||
$B$-$^$9!#(B
|
||||
|
||||
** cvs login ($B0l2sL\$@$1(B)
|
||||
|
||||
% cvs -d :pserver:anonymous@cvs.m17n.org:/cvs/root login
|
||||
|
||||
CVS password: [CR] # $B6uJ8;zNs(B
|
||||
|
||||
** checkout
|
||||
|
||||
% cvs -d :pserver:anonymous@cvs.m17n.org:/cvs/root checkout apel
|
||||
|
||||
CVS $B$K4p$E$$$?3+H/$K;22C$7$?$$$H$-$O!"(B
|
||||
|
||||
cvs@cvs.m17n.org
|
||||
|
||||
$B$K%"%+%&%s%HL>$H!"(Bssh $B$N8x3+80$rAw$C$F$/$@$5$$!#(Bssh $B7PM3$G$O!"(Bcvsroot
|
||||
$B$O(B :ext:cvs@cvs.m17n.org:/cvs/root $B$H$J$j$^$9!#(B
|
||||
|
||||
$B3+$+$l$?3+H/$K;22C$7$F$/$@$5$k$3$H$r4|BT$7$^$9!#(B
|
||||
101
apel-10.7/alist.el
Normal file
101
apel-10.7/alist.el
Normal file
@ -0,0 +1,101 @@
|
||||
;;; alist.el --- utility functions for 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 GNU Emacs.
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;;###autoload
|
||||
(defun put-alist (key value alist)
|
||||
"Set cdr of an element (KEY . ...) in ALIST to VALUE and return ALIST.
|
||||
If there is no such element, create a new pair (KEY . VALUE) and
|
||||
return a new alist whose car is the new pair and cdr is ALIST."
|
||||
(let ((elm (assoc key alist)))
|
||||
(if elm
|
||||
(progn
|
||||
(setcdr elm value)
|
||||
alist)
|
||||
(cons (cons key value) alist))))
|
||||
|
||||
;;;###autoload
|
||||
(defun del-alist (key alist)
|
||||
"Delete an element whose car equals KEY from ALIST.
|
||||
Return the modified ALIST."
|
||||
(let ((pair (assoc key alist)))
|
||||
(if pair
|
||||
(delq pair alist)
|
||||
alist)))
|
||||
|
||||
;;;###autoload
|
||||
(defun set-alist (symbol key value)
|
||||
"Set cdr of an element (KEY . ...) in the alist bound to SYMBOL to VALUE."
|
||||
(or (boundp symbol)
|
||||
(set symbol nil))
|
||||
(set symbol (put-alist key value (symbol-value symbol))))
|
||||
|
||||
;;;###autoload
|
||||
(defun remove-alist (symbol key)
|
||||
"Delete an element whose car equals KEY from the alist bound to SYMBOL."
|
||||
(and (boundp symbol)
|
||||
(set symbol (del-alist key (symbol-value symbol)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun modify-alist (modifier default)
|
||||
"Store elements in the alist MODIFIER in the alist DEFAULT.
|
||||
Return the modified alist."
|
||||
(mapcar (function
|
||||
(lambda (as)
|
||||
(setq default (put-alist (car as)(cdr as) default))))
|
||||
modifier)
|
||||
default)
|
||||
|
||||
;;;###autoload
|
||||
(defun set-modified-alist (symbol modifier)
|
||||
"Store elements in the alist MODIFIER in an alist bound to SYMBOL.
|
||||
If SYMBOL is not bound, set it to nil at first."
|
||||
(if (not (boundp symbol))
|
||||
(set symbol nil))
|
||||
(set symbol (modify-alist modifier (eval symbol))))
|
||||
|
||||
|
||||
;;; @ association-vector-list
|
||||
;;;
|
||||
|
||||
;;;###autoload
|
||||
(defun vassoc (key avlist)
|
||||
"Search AVLIST for an element whose first element equals KEY.
|
||||
AVLIST is a list of vectors.
|
||||
See also `assoc'."
|
||||
(while (and avlist
|
||||
(not (equal key (aref (car avlist) 0))))
|
||||
(setq avlist (cdr avlist)))
|
||||
(and avlist
|
||||
(car avlist)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'alist) (require 'apel-ver))
|
||||
|
||||
;;; alist.el ends here
|
||||
62
apel-10.7/apel-ver.el
Normal file
62
apel-10.7/apel-ver.el
Normal file
@ -0,0 +1,62 @@
|
||||
;;; apel-ver.el --- Declare APEL version.
|
||||
|
||||
;; Copyright (C) 1999, 2000, 2003, 2006 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keiichi Suzuki <keiichi@nanap.org>
|
||||
;; Keywords: compatibility
|
||||
|
||||
;; 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 this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Put the following lines to each file of APEL package.
|
||||
;;
|
||||
;; (require 'product)
|
||||
;; (product-provide (provide FEATURE) (require 'apel-ver))
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'product) ; beware of circular dependency.
|
||||
(provide 'apel-ver) ; these two files depend on each other.
|
||||
|
||||
(product-provide 'apel-ver
|
||||
;; (product-define "APEL" nil '(9 23)) ; comment.
|
||||
;; (product-define "APEL" nil '(10 0)) ; Released 24 December 1999
|
||||
;; (product-define "APEL" nil '(10 1)) ; Released 20 January 2000
|
||||
;; (product-define "APEL" nil '(10 2)) ; Released 01 March 2000
|
||||
;; (product-define "APEL" nil '(10 3)) ; Released 30 December 2000
|
||||
;; (product-define "APEL" nil '(10 4)) ; Released 04 October 2002
|
||||
;; (product-define "APEL" nil '(10 5)) ; Released 06 June 2003
|
||||
;; (product-define "APEL" nil '(10 6)) ; Released 05 July 2003
|
||||
(product-define "APEL" nil '(10 7))
|
||||
)
|
||||
|
||||
(defun apel-version ()
|
||||
"Print APEL version."
|
||||
(interactive)
|
||||
(let ((product-info (product-string-1 'apel-ver t)))
|
||||
(if (interactive-p)
|
||||
(message "%s" product-info)
|
||||
product-info)))
|
||||
|
||||
|
||||
;;; @ End.
|
||||
;;;
|
||||
|
||||
;;; apel-ver.el ends here
|
||||
191
apel-10.7/atype.el
Normal file
191
apel-10.7/atype.el
Normal file
@ -0,0 +1,191 @@
|
||||
;;; atype.el --- atype functions
|
||||
|
||||
;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'emu) ; for backward compatibility.
|
||||
(require 'poe) ; delete.
|
||||
(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
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'atype) (require 'apel-ver))
|
||||
|
||||
;;; atype.el ends here
|
||||
114
apel-10.7/broken.el
Normal file
114
apel-10.7/broken.el
Normal file
@ -0,0 +1,114 @@
|
||||
;;; broken.el --- Emacs broken facility information registry.
|
||||
|
||||
;; Copyright (C) 1998, 1999 Tanaka Akira <akr@jaist.ac.jp>
|
||||
|
||||
;; Author: Tanaka Akira <akr@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, incompatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'static)
|
||||
(require 'poe)
|
||||
|
||||
(eval-and-compile
|
||||
|
||||
(defvar notice-non-obvious-broken-facility t
|
||||
"If the value is t, non-obvious broken facility is noticed when
|
||||
`broken-facility' macro is expanded.")
|
||||
|
||||
(defun broken-facility-internal (facility &optional docstring assertion)
|
||||
"Declare that FACILITY emulation is broken if ASSERTION is nil."
|
||||
(when docstring
|
||||
(put facility 'broken-docstring docstring))
|
||||
(put facility 'broken (not assertion)))
|
||||
|
||||
(defun broken-p (facility)
|
||||
"t if FACILITY emulation is broken."
|
||||
(get facility 'broken))
|
||||
|
||||
(defun broken-facility-description (facility)
|
||||
"Return description for FACILITY."
|
||||
(get facility 'broken-docstring))
|
||||
|
||||
)
|
||||
|
||||
(put 'broken-facility 'lisp-indent-function 1)
|
||||
(defmacro broken-facility (facility &optional docstring assertion no-notice)
|
||||
"Declare that FACILITY emulation is broken if ASSERTION is nil.
|
||||
ASSERTION is evaluated statically.
|
||||
|
||||
FACILITY must be symbol.
|
||||
|
||||
If ASSERTION is not omitted and evaluated to nil and NO-NOTICE is nil,
|
||||
it is noticed."
|
||||
(` (static-if (, assertion)
|
||||
(eval-and-compile
|
||||
(broken-facility-internal '(, facility) (, docstring) t))
|
||||
(eval-when-compile
|
||||
(when (and '(, assertion) (not '(, no-notice))
|
||||
notice-non-obvious-broken-facility)
|
||||
(message "BROKEN FACILITY DETECTED: %s" (, docstring)))
|
||||
nil)
|
||||
(eval-and-compile
|
||||
(broken-facility-internal '(, facility) (, docstring) nil)))))
|
||||
|
||||
(put 'if-broken 'lisp-indent-function 2)
|
||||
(defmacro if-broken (facility then &rest else)
|
||||
"If FACILITY is broken, expand to THEN, otherwise (progn . ELSE)."
|
||||
(` (static-if (broken-p '(, facility))
|
||||
(, then)
|
||||
(,@ else))))
|
||||
|
||||
|
||||
(put 'when-broken 'lisp-indent-function 1)
|
||||
(defmacro when-broken (facility &rest body)
|
||||
"If FACILITY is broken, expand to (progn . BODY), otherwise nil."
|
||||
(` (static-when (broken-p '(, facility))
|
||||
(,@ body))))
|
||||
|
||||
(put 'unless-broken 'lisp-indent-function 1)
|
||||
(defmacro unless-broken (facility &rest body)
|
||||
"If FACILITY is not broken, expand to (progn . BODY), otherwise nil."
|
||||
(` (static-unless (broken-p '(, facility))
|
||||
(,@ body))))
|
||||
|
||||
(defmacro check-broken-facility (facility)
|
||||
"Check FACILITY is broken or not. If the status is different on
|
||||
compile(macro expansion) time and run time, warn it."
|
||||
(` (if-broken (, facility)
|
||||
(unless (broken-p '(, facility))
|
||||
(message "COMPILE TIME ONLY BROKEN FACILITY DETECTED: %s"
|
||||
(or
|
||||
'(, (broken-facility-description facility))
|
||||
(broken-facility-description '(, facility)))))
|
||||
(when (broken-p '(, facility))
|
||||
(message "RUN TIME ONLY BROKEN FACILITY DETECTED: %s"
|
||||
(or
|
||||
(broken-facility-description '(, facility))
|
||||
'(, (broken-facility-description facility))))))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'broken) (require 'apel-ver))
|
||||
|
||||
;;; broken.el ends here
|
||||
331
apel-10.7/calist.el
Normal file
331
apel-10.7/calist.el
Normal file
@ -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 <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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, 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" sym)))
|
||||
(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
|
||||
61
apel-10.7/emu-mule.el
Normal file
61
apel-10.7/emu-mule.el
Normal file
@ -0,0 +1,61 @@
|
||||
;;; emu-mule.el --- emu module for Mule 1.* and Mule 2.*
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; This file is part of emu.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2, or (at
|
||||
;; your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poem)
|
||||
|
||||
|
||||
;;; @ regulation
|
||||
;;;
|
||||
|
||||
(defun regulate-latin-char (chr)
|
||||
(cond ((and (<= ?$B#A(B chr)(<= chr ?$B#Z(B))
|
||||
(+ (- chr ?$B#A(B) ?A))
|
||||
((and (<= ?$B#a(B chr)(<= chr ?$B#z(B))
|
||||
(+ (- chr ?$B#a(B) ?a))
|
||||
((eq chr ?$B!%(B) ?.)
|
||||
((eq chr ?$B!$(B) ?,)
|
||||
(t chr)))
|
||||
|
||||
(defun regulate-latin-string (str)
|
||||
(let ((len (length str))
|
||||
(i 0)
|
||||
chr (dest ""))
|
||||
(while (< i len)
|
||||
(setq chr (sref str i))
|
||||
(setq dest (concat dest
|
||||
(char-to-string (regulate-latin-char chr))))
|
||||
(setq i (+ i (char-bytes chr))))
|
||||
dest))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'emu-mule) (require 'apel-ver))
|
||||
|
||||
;;; emu-mule.el ends here
|
||||
262
apel-10.7/emu.el
Normal file
262
apel-10.7/emu.el
Normal file
@ -0,0 +1,262 @@
|
||||
;;; emu.el --- Emulation module for each Emacs variants
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Nemacs, MULE, Emacs/mule, XEmacs
|
||||
|
||||
;; This file is part of emu.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation; either version 2, or (at
|
||||
;; your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
(defvar running-emacs-18 (<= emacs-major-version 18))
|
||||
(defvar running-xemacs (featurep 'xemacs))
|
||||
|
||||
(defvar running-mule-merged-emacs (and (not (boundp 'MULE))
|
||||
(not running-xemacs) (featurep 'mule)))
|
||||
(defvar running-xemacs-with-mule (and running-xemacs (featurep 'mule)))
|
||||
|
||||
(defvar running-emacs-19 (and (not running-xemacs) (= emacs-major-version 19)))
|
||||
(defvar running-emacs-19_29-or-later
|
||||
(or (and running-emacs-19 (>= emacs-minor-version 29))
|
||||
(and (not running-xemacs)(>= emacs-major-version 20))))
|
||||
|
||||
(defvar running-xemacs-19 (and running-xemacs
|
||||
(= emacs-major-version 19)))
|
||||
(defvar running-xemacs-20-or-later (and running-xemacs
|
||||
(>= emacs-major-version 20)))
|
||||
(defvar running-xemacs-19_14-or-later
|
||||
(or (and running-xemacs-19 (>= emacs-minor-version 14))
|
||||
running-xemacs-20-or-later))
|
||||
|
||||
(cond (running-xemacs
|
||||
;; for XEmacs
|
||||
(defvar mouse-button-1 'button1)
|
||||
(defvar mouse-button-2 'button2)
|
||||
(defvar mouse-button-3 'button3)
|
||||
)
|
||||
((>= emacs-major-version 19)
|
||||
;; mouse
|
||||
(defvar mouse-button-1 [mouse-1])
|
||||
(defvar mouse-button-2 [mouse-2])
|
||||
(defvar mouse-button-3 [down-mouse-3])
|
||||
)
|
||||
(t
|
||||
;; mouse
|
||||
(defvar mouse-button-1 nil)
|
||||
(defvar mouse-button-2 nil)
|
||||
(defvar mouse-button-3 nil)
|
||||
))
|
||||
|
||||
;; for tm-7.106
|
||||
(unless (fboundp 'tl:make-overlay)
|
||||
(defalias 'tl:make-overlay 'make-overlay)
|
||||
(make-obsolete 'tl:make-overlay 'make-overlay)
|
||||
)
|
||||
(unless (fboundp 'tl:overlay-put)
|
||||
(defalias 'tl:overlay-put 'overlay-put)
|
||||
(make-obsolete 'tl:overlay-put 'overlay-put)
|
||||
)
|
||||
(unless (fboundp 'tl:overlay-buffer)
|
||||
(defalias 'tl:overlay-buffer 'overlay-buffer)
|
||||
(make-obsolete 'tl:overlay-buffer 'overlay-buffer)
|
||||
)
|
||||
|
||||
(require 'poem)
|
||||
(require 'mcharset)
|
||||
(require 'invisible)
|
||||
|
||||
(defsubst char-list-to-string (char-list)
|
||||
"Convert list of character CHAR-LIST to string."
|
||||
(apply (function string) char-list))
|
||||
|
||||
(cond ((featurep 'mule)
|
||||
(cond ((featurep 'xemacs) ; for XEmacs with MULE
|
||||
;; old Mule emulating aliases
|
||||
|
||||
;;(defalias 'char-leading-char 'char-charset)
|
||||
|
||||
(defun char-category (character)
|
||||
"Return string of category mnemonics for CHAR in TABLE.
|
||||
CHAR can be any multilingual character
|
||||
TABLE defaults to the current buffer's category table."
|
||||
(mapconcat (lambda (chr)
|
||||
(if (integerp chr)
|
||||
(char-to-string (int-char chr))
|
||||
(char-to-string chr)))
|
||||
;; `char-category-list' returns a list of
|
||||
;; characters in XEmacs 21.2.25 and later,
|
||||
;; otherwise integers.
|
||||
(char-category-list character)
|
||||
""))
|
||||
)
|
||||
((>= emacs-major-version 20) ; for Emacs 20
|
||||
(defalias 'insert-binary-file-contents-literally
|
||||
'insert-file-contents-literally)
|
||||
|
||||
;; old Mule emulating aliases
|
||||
(defun char-category (character)
|
||||
"Return string of category mnemonics for CHAR in TABLE.
|
||||
CHAR can be any multilingual character
|
||||
TABLE defaults to the current buffer's category table."
|
||||
(category-set-mnemonics (char-category-set character)))
|
||||
)
|
||||
(t ; for MULE 1.* and 2.*
|
||||
(require 'emu-mule)
|
||||
))
|
||||
)
|
||||
((boundp 'NEMACS)
|
||||
;; for Nemacs and Nepoch
|
||||
|
||||
;; old MULE emulation
|
||||
(defconst *noconv* 0)
|
||||
(defconst *sjis* 1)
|
||||
(defconst *junet* 2)
|
||||
(defconst *ctext* 2)
|
||||
(defconst *internal* 3)
|
||||
(defconst *euc-japan* 3)
|
||||
|
||||
(defun code-convert-string (str ic oc)
|
||||
"Convert code in STRING from SOURCE code to TARGET code,
|
||||
On successful conversion, returns the result string,
|
||||
else returns nil."
|
||||
(if (not (eq ic oc))
|
||||
(convert-string-kanji-code str ic oc)
|
||||
str))
|
||||
|
||||
(defun code-convert-region (beg end ic oc)
|
||||
"Convert code of the text between BEGIN and END from SOURCE
|
||||
to TARGET. On successful conversion returns t,
|
||||
else returns nil."
|
||||
(if (/= ic oc)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(convert-region-kanji-code beg end ic oc)))
|
||||
))
|
||||
)
|
||||
(t
|
||||
;; for Emacs 19 and XEmacs without MULE
|
||||
|
||||
;; old MULE emulation
|
||||
(defconst *internal* nil)
|
||||
(defconst *ctext* nil)
|
||||
(defconst *noconv* nil)
|
||||
|
||||
(defun code-convert-string (str ic oc)
|
||||
"Convert code in STRING from SOURCE code to TARGET code,
|
||||
On successful conversion, returns the result string,
|
||||
else returns nil. [emu-latin1.el; old MULE emulating function]"
|
||||
str)
|
||||
|
||||
(defun code-convert-region (beg end ic oc)
|
||||
"Convert code of the text between BEGIN and END from SOURCE
|
||||
to TARGET. On successful conversion returns t,
|
||||
else returns nil. [emu-latin1.el; old MULE emulating function]"
|
||||
t)
|
||||
))
|
||||
|
||||
|
||||
;;; @ Mule emulating aliases
|
||||
;;;
|
||||
;;; You should not use it.
|
||||
|
||||
(or (boundp '*noconv*)
|
||||
(defconst *noconv* 'binary
|
||||
"Coding-system for binary.
|
||||
This constant is defined to emulate old MULE anything older than MULE 2.3.
|
||||
It is obsolete, so don't use it."))
|
||||
|
||||
|
||||
;;; @ without code-conversion
|
||||
;;;
|
||||
|
||||
(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
|
||||
(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
|
||||
|
||||
(defun-maybe insert-binary-file-contents-literally (filename
|
||||
&optional visit
|
||||
beg end replace)
|
||||
"Like `insert-file-contents-literally', q.v., but don't code conversion.
|
||||
A buffer may be modified in several ways after reading into the buffer due
|
||||
to advanced Emacs features, such as file-name-handlers, format decoding,
|
||||
find-file-hooks, etc.
|
||||
This function ensures that none of these modifications will take place."
|
||||
(as-binary-input-file
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents-literally filename visit beg end replace)))
|
||||
|
||||
|
||||
;;; @ for text/richtext and text/enriched
|
||||
;;;
|
||||
|
||||
(cond ((fboundp 'richtext-decode)
|
||||
;; have richtext.el
|
||||
)
|
||||
((or running-emacs-19_29-or-later running-xemacs-19_14-or-later)
|
||||
;; have enriched.el
|
||||
(autoload 'richtext-decode "richtext")
|
||||
(or (assq 'text/richtext format-alist)
|
||||
(setq format-alist
|
||||
(cons
|
||||
(cons 'text/richtext
|
||||
'("Extended MIME text/richtext format."
|
||||
"Content-[Tt]ype:[ \t]*text/richtext"
|
||||
richtext-decode richtext-encode t enriched-mode))
|
||||
format-alist)))
|
||||
)
|
||||
(t
|
||||
;; don't have enriched.el
|
||||
(autoload 'richtext-decode "tinyrich")
|
||||
(autoload 'enriched-decode "tinyrich")
|
||||
))
|
||||
|
||||
(if (or (and (eq emacs-major-version 19)
|
||||
(>= emacs-minor-version (if (featurep 'xemacs) 14 29)))
|
||||
(and (eq emacs-major-version 20)
|
||||
(< emacs-minor-version (if (featurep 'xemacs) 3 1))))
|
||||
(eval-after-load "enriched"
|
||||
'(if (fboundp 'si:enriched-encode)
|
||||
nil
|
||||
(fset 'si:enriched-encode (symbol-function 'enriched-encode))
|
||||
(defun enriched-encode (from to &optional orig-buf)
|
||||
(let* ((si:enriched-initial-annotation enriched-initial-annotation)
|
||||
(enriched-initial-annotation
|
||||
(if (stringp si:enriched-initial-annotation)
|
||||
si:enriched-initial-annotation
|
||||
(function
|
||||
(lambda ()
|
||||
(save-excursion
|
||||
;; Eval this in the buffer we are annotating. This
|
||||
;; fixes a bug which was saving incorrect File-Width
|
||||
;; information, since we were looking at local
|
||||
;; variables in the wrong buffer.
|
||||
(if orig-buf (set-buffer orig-buf))
|
||||
(funcall si:enriched-initial-annotation)))))))
|
||||
(si::enriched-encode from to))))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'emu) (require 'apel-ver))
|
||||
|
||||
;;; emu.el ends here
|
||||
115
apel-10.7/env.el
Normal file
115
apel-10.7/env.el
Normal file
@ -0,0 +1,115 @@
|
||||
;;; env.el --- functions to manipulate environment variables.
|
||||
|
||||
;; Copyright (C) 1991, 1994 Free Software Foundation, Inc.
|
||||
|
||||
;; Maintainer: FSF
|
||||
;; Keywords: processes, unix
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs 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.
|
||||
|
||||
;; GNU Emacs 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; UNIX processes inherit a list of name-to-string associations from their
|
||||
;; parents called their `environment'; these are commonly used to control
|
||||
;; program options. This package permits you to set environment variables
|
||||
;; to be passed to any sub-process run under Emacs.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;; History list for environment variable names.
|
||||
(defvar read-envvar-name-history nil)
|
||||
|
||||
(defun read-envvar-name (prompt &optional mustmatch)
|
||||
"Read environment variable name, prompting with PROMPT.
|
||||
Optional second arg MUSTMATCH, if non-nil, means require existing envvar name.
|
||||
If it is also not t, RET does not exit if it does non-null completion."
|
||||
(completing-read prompt
|
||||
(mapcar (function
|
||||
(lambda (enventry)
|
||||
(list (substring enventry 0
|
||||
(string-match "=" enventry)))))
|
||||
process-environment)
|
||||
nil mustmatch nil 'read-envvar-name-history))
|
||||
|
||||
;; History list for VALUE argument to setenv.
|
||||
(defvar setenv-history nil)
|
||||
|
||||
;;;###autoload
|
||||
(defun setenv (variable &optional value unset)
|
||||
"Set the value of the environment variable named VARIABLE to VALUE.
|
||||
VARIABLE should be a string. VALUE is optional; if not provided or is
|
||||
`nil', the environment variable VARIABLE will be removed.
|
||||
|
||||
Interactively, a prefix argument means to unset the variable.
|
||||
Interactively, the current value (if any) of the variable
|
||||
appears at the front of the history list when you type in the new value.
|
||||
|
||||
This function works by modifying `process-environment'."
|
||||
(interactive
|
||||
(if current-prefix-arg
|
||||
(list (read-envvar-name "Clear environment variable: " 'exact) nil t)
|
||||
(let* ((var (read-envvar-name "Set environment variable: " nil))
|
||||
(oldval (getenv var))
|
||||
newval
|
||||
oldhist)
|
||||
;; Don't put the current value on the history
|
||||
;; if it is already there.
|
||||
(if (equal oldval (car setenv-history))
|
||||
(setq oldval nil))
|
||||
;; Now if OLDVAL is non-nil, we should add it to the history.
|
||||
(if oldval
|
||||
(setq setenv-history (cons oldval setenv-history)))
|
||||
(setq oldhist setenv-history)
|
||||
(setq newval (read-from-minibuffer (format "Set %s to value: " var)
|
||||
nil nil nil 'setenv-history))
|
||||
;; If we added the current value to the history, remove it.
|
||||
;; Note that read-from-minibuffer may have added the new value.
|
||||
;; Don't remove that!
|
||||
(if oldval
|
||||
(if (eq oldhist setenv-history)
|
||||
(setq setenv-history (cdr setenv-history))
|
||||
(setcdr setenv-history (cdr (cdr setenv-history)))))
|
||||
;; Here finally we specify the args to give call setenv with.
|
||||
(list var newval))))
|
||||
(if unset (setq value nil))
|
||||
(if (string-match "=" variable)
|
||||
(error "Environment variable name `%s' contains `='" variable)
|
||||
(let ((pattern (concat "\\`" (regexp-quote (concat variable "="))))
|
||||
(case-fold-search nil)
|
||||
(scan process-environment)
|
||||
found)
|
||||
(if (string-equal "TZ" variable)
|
||||
(set-time-zone-rule value))
|
||||
(while scan
|
||||
(cond ((string-match pattern (car scan))
|
||||
(setq found t)
|
||||
(if (eq nil value)
|
||||
(setq process-environment (delq (car scan) process-environment))
|
||||
(setcar scan (concat variable "=" value)))
|
||||
(setq scan nil)))
|
||||
(setq scan (cdr scan)))
|
||||
(or found
|
||||
(if value
|
||||
(setq process-environment
|
||||
(cons (concat variable "=" value)
|
||||
process-environment)))))))
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'env) (require 'apel-ver))
|
||||
|
||||
;;; env.el ends here
|
||||
39
apel-10.7/file-detect.el
Normal file
39
apel-10.7/file-detect.el
Normal file
@ -0,0 +1,39 @@
|
||||
;;; file-detect.el --- Path management or file detection utility
|
||||
|
||||
;; Copyright (C) 1996,1997 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Version: $Id: file-detect.el,v 7.1 1997/11/08 07:40:52 morioka Exp $
|
||||
;; Keywords: file detection, install, module
|
||||
;; Status: obsoleted
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file is existed only for compatibility. Please use
|
||||
;; path-util.el instead of this file.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'path-util)
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'file-detect) (require 'apel-ver))
|
||||
|
||||
;;; file-detect.el ends here
|
||||
170
apel-10.7/filename.el
Normal file
170
apel-10.7/filename.el
Normal file
@ -0,0 +1,170 @@
|
||||
;;; filename.el --- file name filter
|
||||
|
||||
;; Copyright (C) 1996,1997 MORIOKA Tomohiko
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Version: $Id: filename.el,v 2.1 1997/11/06 15:50:53 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, 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 nil
|
||||
"List of functions for file-name filter.
|
||||
|
||||
Example:
|
||||
\(setq filename-filters '\(filename-special-filter
|
||||
filename-eliminate-top-low-lines
|
||||
filename-canonicalize-low-lines
|
||||
filename-maybe-truncate-by-size
|
||||
filename-eliminate-bottom-low-lines\)\)
|
||||
|
||||
Moreover, if you want to convert Japanese filename to roman string by kakasi,
|
||||
|
||||
\(if \(exec-installed-p \"kakasi\"\)
|
||||
\(setq filename-filters
|
||||
\(append '\(filename-japanese-to-roman-string\) filename-filters\)\)\)")
|
||||
|
||||
;;; @ 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))))
|
||||
|
||||
(eval-when-compile
|
||||
(defmacro filename-special-filter-1 (string)
|
||||
(let (sref inc-i)
|
||||
(if (or (not (fboundp 'sref))
|
||||
(>= emacs-major-version 21)
|
||||
(and (= emacs-major-version 20)
|
||||
(>= emacs-minor-version 3)))
|
||||
(setq sref 'aref
|
||||
inc-i '(1+ i))
|
||||
(setq sref 'aref
|
||||
inc-i '(+ i (char-length chr))))
|
||||
(` (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 (, inc-i)
|
||||
b i)
|
||||
(setq i (, inc-i)))))
|
||||
(concat dest (substring (, string) b)))))))
|
||||
|
||||
(defun filename-special-filter (string)
|
||||
(filename-special-filter-1 string))
|
||||
|
||||
(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
|
||||
306
apel-10.7/install.el
Normal file
306
apel-10.7/install.el
Normal file
@ -0,0 +1,306 @@
|
||||
;;; install.el --- Emacs Lisp package install utility
|
||||
|
||||
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2006
|
||||
;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, 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)
|
||||
(set-file-modes full-path install-overwritten-file-modes)
|
||||
(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 just-print
|
||||
(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 del-elc)
|
||||
(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)
|
||||
(set-file-modes full-path install-overwritten-file-modes)
|
||||
(princ (format "%s -> %s\n" el-file dest)))))
|
||||
(setq src-file (expand-file-name elc-file src))
|
||||
(if (not (file-exists-p src-file))
|
||||
(let ((full-path (expand-file-name elc-file dest)))
|
||||
(if (and del-elc (file-exists-p full-path))
|
||||
(if just-print
|
||||
(princ (format "%s -> to be deleted\n" full-path))
|
||||
(delete-file full-path)
|
||||
(princ (format "%s -> deleted\n" full-path)))))
|
||||
(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)
|
||||
(set-file-modes full-path install-overwritten-file-modes)
|
||||
(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 del-elc)
|
||||
(or just-print
|
||||
(file-exists-p dest)
|
||||
(make-directory dest t))
|
||||
(mapcar
|
||||
(function
|
||||
(lambda (module)
|
||||
(install-elisp-module module src dest just-print del-elc)))
|
||||
modules))
|
||||
|
||||
|
||||
;;; @ detect install path
|
||||
;;;
|
||||
|
||||
;; install to shared directory (maybe "/usr/local")
|
||||
(defvar install-prefix
|
||||
(if (or (<= emacs-major-version 18)
|
||||
(featurep 'xemacs)
|
||||
(featurep 'meadow) ; for Meadow
|
||||
(and (eq system-type 'windows-nt) ; for NTEmacs
|
||||
(>= emacs-major-version 20)))
|
||||
(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"))
|
||||
|
||||
;; Avoid compile warning.
|
||||
(eval-when-compile (autoload 'replace-in-string "subr"))
|
||||
|
||||
(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 (delq nil (copy-sequence default-load-path)))
|
||||
(regexp
|
||||
(concat "^"
|
||||
(regexp-quote (if (featurep 'xemacs)
|
||||
;; Handle backslashes (Windows)
|
||||
(replace-in-string
|
||||
(file-name-as-directory
|
||||
(expand-file-name prefix))
|
||||
"\\\\" "/")
|
||||
(file-name-as-directory
|
||||
(expand-file-name prefix))))
|
||||
".*/"
|
||||
(regexp-quote
|
||||
(if (featurep 'xemacs)
|
||||
;; Handle backslashes (Windows)
|
||||
(replace-in-string elisp-prefix "\\\\" "/")
|
||||
elisp-prefix))
|
||||
"/?$"))
|
||||
dir)
|
||||
(while rest
|
||||
(setq dir (if (featurep 'xemacs)
|
||||
;; Handle backslashes (Windows)
|
||||
(replace-in-string (car rest) "\\\\" "/")
|
||||
(car rest)))
|
||||
(if (string-match regexp dir)
|
||||
(if (or allow-version-specific
|
||||
(not (string-match (format "/%d\\.%d"
|
||||
emacs-major-version
|
||||
emacs-minor-version)
|
||||
dir)))
|
||||
(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))
|
||||
|
||||
|
||||
;;; @ for XEmacs package system
|
||||
;;;
|
||||
|
||||
(defun install-get-default-package-directory ()
|
||||
(let ((dirs (append
|
||||
(cond
|
||||
((boundp 'early-package-hierarchies)
|
||||
(append (if early-package-load-path
|
||||
early-package-hierarchies)
|
||||
(if late-package-load-path
|
||||
late-package-hierarchies)
|
||||
(if last-package-load-path
|
||||
last-package-hierarchies)) )
|
||||
((boundp 'early-packages)
|
||||
(append (if early-package-load-path
|
||||
early-packages)
|
||||
(if late-package-load-path
|
||||
late-packages)
|
||||
(if last-package-load-path
|
||||
last-packages)) ))
|
||||
(if (and (boundp 'configure-package-path)
|
||||
(listp configure-package-path))
|
||||
(delete "" configure-package-path))))
|
||||
dir)
|
||||
(while (and (setq dir (car dirs))
|
||||
(not (file-exists-p dir)))
|
||||
(setq dirs (cdr dirs)))
|
||||
dir))
|
||||
|
||||
(defun install-update-package-files (package dir &optional just-print)
|
||||
(cond
|
||||
(just-print
|
||||
(princ (format "Updating autoloads in directory %s..\n\n" dir))
|
||||
|
||||
(princ (format "Processing %s\n" dir))
|
||||
(princ "Generating custom-load.el...\n\n")
|
||||
|
||||
(princ (format "Compiling %s...\n"
|
||||
(expand-file-name "auto-autoloads.el" dir)))
|
||||
(princ (format "Wrote %s\n"
|
||||
(expand-file-name "auto-autoloads.elc" dir)))
|
||||
|
||||
(princ (format "Compiling %s...\n"
|
||||
(expand-file-name "custom-load.el" dir)))
|
||||
(princ (format "Wrote %s\n"
|
||||
(expand-file-name "custom-load.elc" dir))))
|
||||
(t
|
||||
(if (fboundp 'batch-update-directory-autoloads)
|
||||
;; XEmacs 21.5.19 and newer.
|
||||
(let ((command-line-args-left (list package dir)))
|
||||
(batch-update-directory-autoloads))
|
||||
(setq autoload-package-name package)
|
||||
(let ((command-line-args-left (list dir)))
|
||||
(batch-update-directory)))
|
||||
|
||||
(let ((command-line-args-left (list dir)))
|
||||
(Custom-make-dependencies))
|
||||
|
||||
(byte-compile-file (expand-file-name "auto-autoloads.el" dir))
|
||||
(byte-compile-file (expand-file-name "custom-load.el" dir)))))
|
||||
|
||||
|
||||
;;; @ Other Utilities
|
||||
;;;
|
||||
|
||||
(defun install-just-print-p ()
|
||||
(let ((flag (getenv "MAKEFLAGS"))
|
||||
(case-fold-search nil))
|
||||
(princ (format "%s\n" flag))
|
||||
(if flag
|
||||
(string-match "^\\(\\(--[^ ]+ \\)+-\\|[^ =-]\\)*n" flag))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'install) (require 'apel-ver))
|
||||
|
||||
;;; install.el ends here
|
||||
79
apel-10.7/inv-18.el
Normal file
79
apel-10.7/inv-18.el
Normal file
@ -0,0 +1,79 @@
|
||||
;;; inv-18.el --- invisible feature implementation for Emacs 18
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: invisible, text-property, region, Emacs 18
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
(defun enable-invisible ()
|
||||
(make-local-variable 'original-selective-display)
|
||||
(setq original-selective-display selective-display)
|
||||
(setq selective-display t))
|
||||
|
||||
(defun disable-invisible ()
|
||||
(setq selective-display
|
||||
(and (boundp 'original-selective-display)
|
||||
original-selective-display)))
|
||||
(defalias 'end-of-invisible 'disable-invisible)
|
||||
(make-obsolete 'end-of-invisible 'disable-invisible)
|
||||
|
||||
(defun invisible-region (start end)
|
||||
(let ((buffer-read-only nil)
|
||||
(modp (buffer-modified-p)))
|
||||
(if (save-excursion
|
||||
(goto-char (1- end))
|
||||
(eq (following-char) ?\n))
|
||||
(setq end (1- end)))
|
||||
(unwind-protect
|
||||
(subst-char-in-region start end ?\n ?\r t)
|
||||
(set-buffer-modified-p modp))))
|
||||
|
||||
(defun visible-region (start end)
|
||||
(let ((buffer-read-only nil)
|
||||
(modp (buffer-modified-p)))
|
||||
(unwind-protect
|
||||
(subst-char-in-region start end ?\r ?\n t)
|
||||
(set-buffer-modified-p modp))))
|
||||
|
||||
(defun invisible-p (pos)
|
||||
(save-excursion
|
||||
(goto-char pos)
|
||||
(eq (following-char) ?\r)))
|
||||
|
||||
(defun next-visible-point (pos)
|
||||
(save-excursion
|
||||
(goto-char pos)
|
||||
(end-of-line)
|
||||
(if (eq (following-char) ?\n)
|
||||
(forward-char))
|
||||
(point)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'inv-18) (require 'apel-ver))
|
||||
|
||||
;;; inv-18.el ends here
|
||||
61
apel-10.7/inv-19.el
Normal file
61
apel-10.7/inv-19.el
Normal file
@ -0,0 +1,61 @@
|
||||
;;; inv-19.el --- invisible feature implementation for Emacs 19 or later
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: invisible, text-property, region, Emacs 19
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
(defun enable-invisible ())
|
||||
(defun disable-invisible ())
|
||||
(defalias 'end-of-invisible 'disable-invisible)
|
||||
(make-obsolete 'end-of-invisible 'disable-invisible)
|
||||
|
||||
(defun invisible-region (start end)
|
||||
(if (save-excursion
|
||||
(goto-char (1- end))
|
||||
(eq (following-char) ?\n))
|
||||
(setq end (1- end)))
|
||||
(put-text-property start end 'invisible t))
|
||||
|
||||
(defun visible-region (start end)
|
||||
(put-text-property start end 'invisible nil))
|
||||
|
||||
(defun invisible-p (pos)
|
||||
(get-text-property pos 'invisible))
|
||||
|
||||
(defun next-visible-point (pos)
|
||||
(if (setq pos (next-single-property-change pos 'invisible))
|
||||
(if (eq ?\n (char-after pos))
|
||||
(1+ pos)
|
||||
pos)
|
||||
(point-max)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'inv-19) (require 'apel-ver))
|
||||
|
||||
;;; inv-19.el ends here
|
||||
68
apel-10.7/inv-xemacs.el
Normal file
68
apel-10.7/inv-xemacs.el
Normal file
@ -0,0 +1,68 @@
|
||||
;;; inv-xemacs.el --- invisible feature implementation for XEmacs
|
||||
|
||||
;; Copyright (C) 1995 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: invisible, text-property, region, XEmacs
|
||||
|
||||
;; 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 XEmacs; see the file COPYING. If not, write to the Free
|
||||
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
|
||||
;; MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
(defun enable-invisible ())
|
||||
(defun disable-invisible ())
|
||||
(defalias 'end-of-invisible 'disable-invisible)
|
||||
(make-obsolete 'end-of-invisible 'disable-invisible)
|
||||
|
||||
(defun invisible-region (start end)
|
||||
(if (save-excursion
|
||||
(goto-char start)
|
||||
(eq (following-char) ?\n))
|
||||
(setq start (1+ start)))
|
||||
(put-text-property start end 'invisible t))
|
||||
|
||||
(defun visible-region (start end)
|
||||
(put-text-property start end 'invisible nil))
|
||||
|
||||
(defun invisible-p (pos)
|
||||
(if (save-excursion
|
||||
(goto-char pos)
|
||||
(eq (following-char) ?\n))
|
||||
(setq pos (1+ pos)))
|
||||
(get-text-property pos 'invisible))
|
||||
|
||||
(defun next-visible-point (pos)
|
||||
(save-excursion
|
||||
(if (save-excursion
|
||||
(goto-char pos)
|
||||
(eq (following-char) ?\n))
|
||||
(setq pos (1+ pos)))
|
||||
(or (next-single-property-change pos 'invisible)
|
||||
(point-max))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'inv-xemacs) (require 'apel-ver))
|
||||
|
||||
;;; inv-xemacs.el ends here
|
||||
42
apel-10.7/invisible.el
Normal file
42
apel-10.7/invisible.el
Normal file
@ -0,0 +1,42 @@
|
||||
;;; invisible.el --- hide region
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: invisible, text-property, region
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
(require 'inv-xemacs))
|
||||
((>= emacs-major-version 19)
|
||||
(require 'inv-19))
|
||||
(t
|
||||
(require 'inv-18)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'invisible) (require 'apel-ver))
|
||||
|
||||
;;; invisible.el ends here
|
||||
308
apel-10.7/localhook.el
Normal file
308
apel-10.7/localhook.el
Normal file
@ -0,0 +1,308 @@
|
||||
;;; localhook.el --- local hook variable support in emacs-lisp.
|
||||
|
||||
;; Copyright (C) 1985,86,92,94,95,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: compatibility
|
||||
|
||||
;; 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 this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file (re)defines the following functions.
|
||||
;; These functions support local hook feature in emacs-lisp level.
|
||||
;;
|
||||
;; add-hook, remove-hook, make-local-hook,
|
||||
;; run-hooks, run-hook-with-args,
|
||||
;; run-hook-with-args-until-success, and
|
||||
;; run-hook-with-args-until-failure.
|
||||
|
||||
;; The following functions which do not exist in 19.28 are used in the
|
||||
;; original definitions of add-hook, remove-hook, and make-local-hook.
|
||||
;;
|
||||
;; local-variable-p, and local-variable-if-set-p.
|
||||
;;
|
||||
;; In this file, these functions are replaced with mock versions.
|
||||
|
||||
;; In addition, the following functions which do not exist in v18 are used.
|
||||
;;
|
||||
;; default-boundp, byte-code-function-p, functionp, member, and delete.
|
||||
;;
|
||||
;; These functions are provided by poe-18.el.
|
||||
|
||||
;; For historians:
|
||||
;;
|
||||
;; `add-hook' and `remove-hook' were introduced in v19.
|
||||
;;
|
||||
;; Local hook feature and `make-local-hook' were introduced in 19.29.
|
||||
;;
|
||||
;; `run-hooks' exists in v17.
|
||||
;; `run-hook-with-args' was introduced in 19.23 as a lisp function.
|
||||
;; Two variants of `run-hook-with-args' were introduced in 19.29 as
|
||||
;; lisp functions. `run-hook' family became C primitives in 19.30.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;; beware of circular dependency.
|
||||
(require 'product)
|
||||
(product-provide (provide 'localhook) (require 'apel-ver))
|
||||
|
||||
(require 'poe) ; this file is loaded from poe.el.
|
||||
|
||||
;; These two functions are not complete, but work enough for our purpose.
|
||||
;;
|
||||
;; (defun local-variable-p (variable &optional buffer)
|
||||
;; "Non-nil if VARIABLE has a local binding in buffer BUFFER.
|
||||
;; BUFFER defaults to the current buffer."
|
||||
;; (and (or (assq variable (buffer-local-variables buffer)) ; local and bound.
|
||||
;; (memq variable (buffer-local-variables buffer))); local but void.
|
||||
;; ;; docstring is ambiguous; 20.3 returns bool value.
|
||||
;; t))
|
||||
;;
|
||||
;; (defun local-variable-if-set-p (variable &optional buffer)
|
||||
;; "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.
|
||||
;; BUFFER defaults to the current buffer."
|
||||
;; (and (or (assq variable (buffer-local-variables buffer)) ; local and bound.
|
||||
;; (memq variable (buffer-local-variables buffer))); local but void.
|
||||
;; ;; docstring is ambiguous; 20.3 returns bool value.
|
||||
;; t))
|
||||
|
||||
;;; Hook manipulation functions.
|
||||
|
||||
;; The following three functions are imported from emacs-20.3/lisp/subr.el.
|
||||
;; (local-variable-p, and local-variable-if-set-p are expanded.)
|
||||
(defun make-local-hook (hook)
|
||||
"Make the hook HOOK local to the current buffer.
|
||||
The return value is HOOK.
|
||||
|
||||
When a hook is local, its local and global values
|
||||
work in concert: running the hook actually runs all the hook
|
||||
functions listed in *either* the local value *or* the global value
|
||||
of the hook variable.
|
||||
|
||||
This function works by making `t' a member of the buffer-local value,
|
||||
which acts as a flag to run the hook functions in the default value as
|
||||
well. This works for all normal hooks, but does not work for most
|
||||
non-normal hooks yet. We will be changing the callers of non-normal
|
||||
hooks so that they can handle localness; this has to be done one by
|
||||
one.
|
||||
|
||||
This function does nothing if HOOK is already local in the current
|
||||
buffer.
|
||||
|
||||
Do not use `make-local-variable' to make a hook variable buffer-local."
|
||||
(if ;; (local-variable-p hook)
|
||||
(or (assq hook (buffer-local-variables)) ; local and bound.
|
||||
(memq hook (buffer-local-variables))); local but void.
|
||||
nil
|
||||
(or (boundp hook) (set hook nil))
|
||||
(make-local-variable hook)
|
||||
(set hook (list t)))
|
||||
hook)
|
||||
|
||||
(defun add-hook (hook function &optional append local)
|
||||
"Add to the value of HOOK the function FUNCTION.
|
||||
FUNCTION is not added if already present.
|
||||
FUNCTION is added (if necessary) at the beginning of the hook list
|
||||
unless the optional argument APPEND is non-nil, in which case
|
||||
FUNCTION is added at the end.
|
||||
|
||||
The optional fourth argument, LOCAL, if non-nil, says to modify
|
||||
the hook's buffer-local value rather than its default value.
|
||||
This makes no difference if the hook is not buffer-local.
|
||||
To make a hook variable buffer-local, always use
|
||||
`make-local-hook', not `make-local-variable'.
|
||||
|
||||
HOOK should be a symbol, and FUNCTION may be any valid function. If
|
||||
HOOK is void, it is first set to nil. If HOOK's value is a single
|
||||
function, it is changed to a list of functions."
|
||||
(or (boundp hook) (set hook nil))
|
||||
(or (default-boundp hook) (set-default hook nil))
|
||||
;; If the hook value is a single function, turn it into a list.
|
||||
(let ((old (symbol-value hook)))
|
||||
(if (or (not (listp old)) (eq (car old) 'lambda))
|
||||
(set hook (list old))))
|
||||
(if (or local
|
||||
;; Detect the case where make-local-variable was used on a hook
|
||||
;; and do what we used to do.
|
||||
(and ;; (local-variable-if-set-p hook)
|
||||
(or (assq hook (buffer-local-variables)) ; local and bound.
|
||||
(memq hook (buffer-local-variables))); local but void.
|
||||
(not (memq t (symbol-value hook)))))
|
||||
;; Alter the local value only.
|
||||
(or (if (or (consp function) (byte-code-function-p function))
|
||||
(member function (symbol-value hook))
|
||||
(memq function (symbol-value hook)))
|
||||
(set hook
|
||||
(if append
|
||||
(append (symbol-value hook) (list function))
|
||||
(cons function (symbol-value hook)))))
|
||||
;; Alter the global value (which is also the only value,
|
||||
;; if the hook doesn't have a local value).
|
||||
(or (if (or (consp function) (byte-code-function-p function))
|
||||
(member function (default-value hook))
|
||||
(memq function (default-value hook)))
|
||||
(set-default hook
|
||||
(if append
|
||||
(append (default-value hook) (list function))
|
||||
(cons function (default-value hook)))))))
|
||||
|
||||
(defun remove-hook (hook function &optional local)
|
||||
"Remove from the value of HOOK the function FUNCTION.
|
||||
HOOK should be a symbol, and FUNCTION may be any valid function. If
|
||||
FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
|
||||
list of hooks to run in HOOK, then nothing is done. See `add-hook'.
|
||||
|
||||
The optional third argument, LOCAL, if non-nil, says to modify
|
||||
the hook's buffer-local value rather than its default value.
|
||||
This makes no difference if the hook is not buffer-local.
|
||||
To make a hook variable buffer-local, always use
|
||||
`make-local-hook', not `make-local-variable'."
|
||||
(if (or (not (boundp hook)) ;unbound symbol, or
|
||||
(not (default-boundp hook))
|
||||
(null (symbol-value hook)) ;value is nil, or
|
||||
(null function)) ;function is nil, then
|
||||
nil ;Do nothing.
|
||||
(if (or local
|
||||
;; Detect the case where make-local-variable was used on a hook
|
||||
;; and do what we used to do.
|
||||
(and ;; (local-variable-p hook)
|
||||
(or (assq hook (buffer-local-variables)) ; local and bound.
|
||||
(memq hook (buffer-local-variables))); local but void.
|
||||
(consp (symbol-value hook))
|
||||
(not (memq t (symbol-value hook)))))
|
||||
(let ((hook-value (symbol-value hook)))
|
||||
(if (consp hook-value)
|
||||
(if (member function hook-value)
|
||||
(setq hook-value (delete function (copy-sequence hook-value))))
|
||||
(if (equal hook-value function)
|
||||
(setq hook-value nil)))
|
||||
(set hook hook-value))
|
||||
(let ((hook-value (default-value hook)))
|
||||
(if (and (consp hook-value) (not (functionp hook-value)))
|
||||
(if (member function hook-value)
|
||||
(setq hook-value (delete function (copy-sequence hook-value))))
|
||||
(if (equal hook-value function)
|
||||
(setq hook-value nil)))
|
||||
(set-default hook hook-value)))))
|
||||
|
||||
;;; Hook execution functions.
|
||||
|
||||
(defun run-hook-with-args-internal (hook args cond)
|
||||
"Run HOOK with the specified arguments ARGS.
|
||||
HOOK should be a symbol, a hook variable. Its value should be a list of
|
||||
functions. We call those functions, one by one, passing arguments ARGS
|
||||
to each of them, until specified COND is satisfied. If COND is nil, we
|
||||
call those functions until one of them returns a non-nil value, and then
|
||||
we return that value. If COND is t, we call those functions until one
|
||||
of them returns nil, and then we return nil. If COND is not nil and not
|
||||
t, we call all the functions."
|
||||
(if (not (boundp hook))
|
||||
;; hook is void.
|
||||
(not cond)
|
||||
(let* ((functions (symbol-value hook))
|
||||
(ret (eq cond t))
|
||||
(all (and cond (not ret)))
|
||||
function)
|
||||
(if (functionp functions)
|
||||
;; hook is just a function.
|
||||
(apply functions args)
|
||||
;; hook is nil or a list of functions.
|
||||
(while (and functions
|
||||
(or all ; to-completion
|
||||
(if cond
|
||||
ret ; until-failure
|
||||
(null ret)))) ; until-success
|
||||
(setq function (car functions)
|
||||
functions(cdr functions))
|
||||
(if (eq function t)
|
||||
;; this hook has a local binding.
|
||||
;; we must run the global binding too.
|
||||
(let ((globals (default-value hook))
|
||||
global)
|
||||
(if (functionp globals)
|
||||
(setq ret (apply globals args))
|
||||
(while (and globals
|
||||
(or all
|
||||
(if cond
|
||||
ret
|
||||
(null ret))))
|
||||
(setq global (car globals)
|
||||
globals(cdr globals))
|
||||
(or (eq global t) ; t should not occur.
|
||||
(setq ret (apply global args))))))
|
||||
(setq ret (apply function args))))
|
||||
ret))))
|
||||
|
||||
;; The following four functions are direct translation of their
|
||||
;; C definitions in emacs-20.3/src/eval.c.
|
||||
(defun run-hooks (&rest hooks)
|
||||
"Run each hook in HOOKS. Major mode functions use this.
|
||||
Each argument should be a symbol, a hook variable.
|
||||
These symbols are processed in the order specified.
|
||||
If a hook symbol has a non-nil value, that value may be a function
|
||||
or a list of functions to be called to run the hook.
|
||||
If the value is a function, it is called with no arguments.
|
||||
If it is a list, the elements are called, in order, with no arguments.
|
||||
|
||||
To make a hook variable buffer-local, use `make-local-hook',
|
||||
not `make-local-variable'."
|
||||
(while hooks
|
||||
(run-hook-with-args-internal (car hooks) nil 'to-completion)
|
||||
(setq hooks (cdr hooks))))
|
||||
|
||||
(defun run-hook-with-args (hook &rest args)
|
||||
"Run HOOK with the specified arguments ARGS.
|
||||
HOOK should be a symbol, a hook variable. If HOOK has a non-nil
|
||||
value, that value may be a function or a list of functions to be
|
||||
called to run the hook. If the value is a function, it is called with
|
||||
the given arguments and its return value is returned. If it is a list
|
||||
of functions, those functions are called, in order,
|
||||
with the given arguments ARGS.
|
||||
It is best not to depend on the value return by `run-hook-with-args',
|
||||
as that may change.
|
||||
|
||||
To make a hook variable buffer-local, use `make-local-hook',
|
||||
not `make-local-variable'."
|
||||
(run-hook-with-args-internal hook args 'to-completion))
|
||||
|
||||
(defun run-hook-with-args-until-success (hook &rest args)
|
||||
"Run HOOK with the specified arguments ARGS.
|
||||
HOOK should be a symbol, a hook variable. Its value should
|
||||
be a list of functions. We call those functions, one by one,
|
||||
passing arguments ARGS to each of them, until one of them
|
||||
returns a non-nil value. Then we return that value.
|
||||
If all the functions return nil, we return nil.
|
||||
|
||||
To make a hook variable buffer-local, use `make-local-hook',
|
||||
not `make-local-variable'."
|
||||
(run-hook-with-args-internal hook args nil))
|
||||
|
||||
(defun run-hook-with-args-until-failure (hook &rest args)
|
||||
"Run HOOK with the specified arguments ARGS.
|
||||
HOOK should be a symbol, a hook variable. Its value should
|
||||
be a list of functions. We call those functions, one by one,
|
||||
passing arguments ARGS to each of them, until one of them
|
||||
returns nil. Then we return nil.
|
||||
If all the functions return non-nil, we return non-nil.
|
||||
|
||||
To make a hook variable buffer-local, use `make-local-hook',
|
||||
not `make-local-variable'."
|
||||
(run-hook-with-args-internal hook args t))
|
||||
|
||||
;;; localhook.el ends here
|
||||
56
apel-10.7/make1.bat
Normal file
56
apel-10.7/make1.bat
Normal file
@ -0,0 +1,56 @@
|
||||
echo off
|
||||
rem MAKE1.BAT for APEL.
|
||||
rem
|
||||
rem Version: $Id: make1.bat,v 1.1 2001/02/01 03:19:36 minakaji Exp $
|
||||
rem Last Modified: $Date: 2001/02/01 03:19:36 $
|
||||
|
||||
rem --- argument
|
||||
rem --- elc : byte compile
|
||||
rem --- all, install : install
|
||||
rem --- clean : cleaning garbage file
|
||||
rem --- what-where : print where to install
|
||||
rem ---
|
||||
|
||||
rem --- check calling from make.bat
|
||||
if not "%SUBMAKEOK%"=="OK" goto prnusage
|
||||
set SUBMAKEOK=
|
||||
|
||||
rem argument check
|
||||
|
||||
set arg1=%1
|
||||
|
||||
if "%arg1%"=="elc" goto compile
|
||||
if "%arg1%"=="all" goto install
|
||||
if "%arg1%"=="install" goto install
|
||||
if "%arg1%"=="what-where" goto listing
|
||||
if "%arg1%"=="clean" goto clean
|
||||
echo Unrecognized argument: specify either 'elc', 'all',
|
||||
echo 'install', 'clean' or 'what-where'.
|
||||
goto pauseend
|
||||
|
||||
:compile
|
||||
%EMACS% -q -batch -no-site-file -l APEL-MK -f compile-apel NONE %LISPDIR% %VLISPDIR%
|
||||
goto end
|
||||
|
||||
:install
|
||||
%EMACS% -q -batch -no-site-file -l APEL-MK -f install-apel NONE %LISPDIR% %VLISPDIR%
|
||||
goto end
|
||||
|
||||
:listing
|
||||
%EMACS% -batch -q -no-site-file -l APEL-MK -f what-where-apel
|
||||
goto end
|
||||
|
||||
:clean
|
||||
del *.elc
|
||||
|
||||
rem --- This file should not be executed by itself. Use make.bat.
|
||||
:prnusage
|
||||
echo This file should not be executed by itself. Use make.bat.
|
||||
|
||||
rem --- If error occurs, stay display until any key is typed.
|
||||
:pauseend
|
||||
echo Type any key when you're done reading the error message.
|
||||
pause
|
||||
|
||||
:end
|
||||
|
||||
215
apel-10.7/makeit.bat
Normal file
215
apel-10.7/makeit.bat
Normal file
@ -0,0 +1,215 @@
|
||||
@echo off
|
||||
rem ---
|
||||
rem --- common install batch file for Meadow & NTEmacs
|
||||
rem --- 1999/07/07, Masaki YATSU mailto:yatsu@aurora.dti.ne.jp
|
||||
rem --- cmail ML member
|
||||
rem --- modified 1999/12/01, Yuh Ohmura, mailto:yutopia@t3.rim.or.jp
|
||||
rem --- modified 2000/12/26, Takeshi Morishima mailto:tm@interaccess.com
|
||||
rem --- date $Date: 2001/02/01 03:19:36 $
|
||||
rem --- version $Id: makeit.bat,v 1.1 2001/02/01 03:19:36 minakaji Exp $
|
||||
|
||||
set ELISPMK_APP=apel
|
||||
|
||||
rem --- Japanese Comments:
|
||||
rem ---
|
||||
rem --- 引数
|
||||
rem --- 引数については make1.bat のコメントを参照してください．
|
||||
rem --- makeit.bat は、インストールの環境変数を設定した後に
|
||||
rem --- make1.bat を呼出してインストールを行います。
|
||||
rem ---
|
||||
rem --- 変数設定
|
||||
rem --- このコメントのあとにある PREFIX, EMACS, EXEC_PREFIX, LISPDIR,
|
||||
rem --- INFODIR, VERSION_SPECIFIC_LISPDIR の各変数を，お使いの環境に
|
||||
rem --- 適当に合せて設定してください．
|
||||
rem --- 特に，EMACS の値を，
|
||||
rem --- Windows95/98 を利用されている方は meadow95.exe
|
||||
rem --- WindowsNT4.0 を利用されている方は meadownt.exe
|
||||
rem --- NTEmacs を利用されている方は emacs.exe
|
||||
rem --- を指定するのを忘れないように．
|
||||
rem ---
|
||||
rem --- 適宜指定が終った makeit.bat は下のいずれかのファイルとして
|
||||
rem --- コピーしておくとそちらを優先して実行します。(アップグレード
|
||||
rem --- の際に makeit.bat を再編集する必要がありません.) 優先順に:
|
||||
rem ---
|
||||
rem --- 1-1. %HOME%\.elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-2. %HOME%\elisp\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-3. %HOME%\config\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-4. c:\Program Files\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-5. c:\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-6. d:\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
rem ---
|
||||
rem --- 2-1. %HOME%\.elispmk.bat
|
||||
rem --- 2-2. %HOME%\elisp\elispmk.bat
|
||||
rem --- 2-3. %HOME%\config\elispmk.bat
|
||||
rem --- 2-4. c:\Program Files\Meadow\elispmk.bat
|
||||
rem --- 2-5. c:\Meadow\elispmk.bat
|
||||
rem --- 2-6. d:\Meadow\elispmk.bat
|
||||
rem ---
|
||||
rem --- となります。
|
||||
rem ---
|
||||
rem --- English Comments:
|
||||
rem ---
|
||||
rem --- Arguments
|
||||
rem --- Please refer to comment section of make1.bat. Makeit.bat
|
||||
rem --- will perform installation procedure by executing make1.bat.
|
||||
rem ---
|
||||
rem --- Specifying variables
|
||||
rem --- After this comment section, PREFIX, EMACS, EXEC_PREFIX,
|
||||
rem --- LISPDIR, INFODIR, VERSION_SPECIFIC_LISPDIR is defined using
|
||||
rem --- 'set' batch command. Please specify them appropriately
|
||||
rem --- according to your Emacs environment. Especially remember to set
|
||||
rem --- the EMACS variable to meadow95.exe if you use Meadow on
|
||||
rem --- Windows95/98, or to meadownt.exe if you use Meadow on
|
||||
rem --- WindowsNT4.0, or to emacs.exe if you use NTEmacs.
|
||||
rem ---
|
||||
rem --- After modification, you may make a copy of makeit.bat as a pre-
|
||||
rem --- configured file as one of the following name. Any future
|
||||
rem --- execution of makeit.bat will automatically use this pre-
|
||||
rem --- configured batch file instead of makeit.bat itself. (When
|
||||
rem --- upgrading new distribution file for example, you do not have to
|
||||
rem --- make modification to makeit.bat again.) A pre-configured batch
|
||||
rem --- file is searched in order listed below:
|
||||
rem ---
|
||||
rem --- 1-1. %HOME%\.elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-2. %HOME%\elisp\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-3. %HOME%\config\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-4. c:\Program Files\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-5. c:\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
rem --- 1-6. d:\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
rem ---
|
||||
rem --- 2-1. %HOME%\.elispmk.bat
|
||||
rem --- 2-2. %HOME%\elisp\elispmk.bat
|
||||
rem --- 2-3. %HOME%\config\elispmk.bat
|
||||
rem --- 2-4. c:\Program Files\Meadow\elispmk.bat
|
||||
rem --- 2-5. c:\Meadow\elispmk.bat
|
||||
rem --- 2-6. d:\Meadow\elispmk.bat
|
||||
|
||||
rem --- 変数設定の例 (Example of variable definition)
|
||||
rem --- c:\usr\Meadow にインストールされている 1.10 の Meadow を使用
|
||||
rem --- している場合の設定例. (An example of variable definition. In
|
||||
rem --- this example, Meadow 1.10 installed in c:\usr\Meadow directory
|
||||
rem --- is used.)
|
||||
rem --- set PREFIX=c:\usr\Meadow
|
||||
rem --- set EMACS=%PREFIX%\1.10\bin\meadow95.exe
|
||||
rem --- set EXEC_PREFIX=
|
||||
rem --- set LISPDIR=%PREFIX%\site-lisp
|
||||
rem --- set VERSION_SPECIFIC_LISPDIR=%PREFIX%\1.10\site-lisp
|
||||
rem --- set DEFAULT_MAKE_ARG=elc
|
||||
rem --- 安全のためデフォルトの値はすべて空文字列になっています。お使い
|
||||
rem --- のシステムにあわせてこれらの変数を指定してください。(To take a
|
||||
rem --- safe side, default values are all set to null strings. Please
|
||||
rem --- specify these variables accordingly for your system.)
|
||||
rem --- なお、DEFAULT_MAKE_ARG に可能な値は make1.bat を御覧ください。
|
||||
rem --- (Please see make1.bat for possible values of DEFAULT_MAKE_ARG.)
|
||||
|
||||
set PREFIX=
|
||||
set EMACS=
|
||||
set LISPDIR=
|
||||
set DEFAULT_MAKE_ARG=
|
||||
|
||||
|
||||
rem --- makeit.bat 内から呼ばれている場合は再帰呼び出しをせず make1 を実行
|
||||
if not "%ELISPMK%"=="" goto execsubmk
|
||||
|
||||
rem ---
|
||||
set ELISPMK=%HOME%\.elispmk.%ELISPMK_APP%.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=%HOME%\elisp\elispmk.%ELISPMK_APP%.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=%HOME%\config\elispmk.%ELISPMK_APP%.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK="c:\Program Files\Meadow\elispmk.%ELISPMK_APP%.bat"
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=c:\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=d:\Meadow\elispmk.%ELISPMK_APP%.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
rem ---
|
||||
set ELISPMK=%HOME%\.elispmk.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=%HOME%\elisp\elispmk.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=%HOME%\config\elispmk.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK="c:\Program Files\Meadow\elispmk.bat"
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=c:\Meadow\elispmk.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
set ELISPMK=d:\Meadow\elispmk.bat
|
||||
if exist %ELISPMK% goto execelmkb
|
||||
|
||||
echo ----
|
||||
echo INFORMATIVE: No pre-configured batch (e.g. ~/.elispmk.bat
|
||||
echo INVORMATIVE: or ~/.elispmk.%ELISPMK_APP%.bat) found.
|
||||
echo INFORMATIVE: You may create one for your convenience.
|
||||
echo INFORMATIVE: See comments in makeit.bat.
|
||||
echo ----
|
||||
|
||||
:execsubmk
|
||||
set ELISPMK=
|
||||
rem --- %EMACS% が場合はエラー終了する
|
||||
if "%EMACS%"=="" goto errnotspecified
|
||||
if not exist "%EMACS%" goto errnonexistent
|
||||
|
||||
rem --- MAKE1.BAT Control
|
||||
set SUBMAKEOK=OK
|
||||
|
||||
echo ----
|
||||
echo Executing make1.bat in the current directory using the folloiwing env.
|
||||
echo HOME=%HOME%
|
||||
echo PREFIX=%PREFIX%
|
||||
echo EMACS=%EMACS%
|
||||
echo EXEC_PREFIX=%EXEC_PREFIX%
|
||||
echo LISPDIR=%LISPDIR%
|
||||
echo INFODIR=%INFODIR%
|
||||
echo VERSION_SPECIFIC_LISPDIR=%VERSION_SPECIFIC_LISPDIR%
|
||||
echo ----
|
||||
|
||||
set ARG=%1
|
||||
if "%ARG%"=="" set ARG=%DEFAULT_MAKE_ARG%
|
||||
|
||||
echo Executing .\make1.bat with argument=%ARG%
|
||||
.\make1.bat %ARG%
|
||||
|
||||
echo Error: for some reason .\make1.bat could not be executed.
|
||||
echo Please check if .\make1.bat exists and correct.
|
||||
goto pauseend
|
||||
|
||||
:execelmkb
|
||||
echo ----
|
||||
echo Found %ELISPMK%. Executing it...
|
||||
echo ----
|
||||
%ELISPMK% %1
|
||||
echo Error: for some reason %ELISPMK% could not be executed.
|
||||
echo Please check if ELISPMK=%ELISPMK% exists and correct.
|
||||
goto printenv
|
||||
|
||||
rem --- %EMACS% が設定されていない
|
||||
:errnotspecified
|
||||
echo Error: Environment variable EMACS is not specified.
|
||||
goto printenv
|
||||
|
||||
rem --- %EMACS% に設定されているファイルが存在しない
|
||||
:errnonexistent
|
||||
echo Error: EMACS=%EMACS% does not exist.
|
||||
|
||||
:printenv
|
||||
echo ----
|
||||
echo Check correctness of the following environment variables.
|
||||
echo HOME=%HOME%
|
||||
echo PREFIX=%PREFIX%
|
||||
echo EMACS=%EMACS%
|
||||
echo EXEC_PREFIX=%EXEC_PREFIX%
|
||||
echo LISPDIR=%LISPDIR%
|
||||
echo INFODIR=%INFODIR%
|
||||
echo VERSION_SPECIFIC_LISPDIR=%VERSION_SPECIFIC_LISPDIR%
|
||||
echo DEFAULT_MAKE_ARG=%DEFAULT_MAKE_ARG%
|
||||
echo See comments in makeit.bat and make1.bat for setup instruction.
|
||||
echo ----
|
||||
|
||||
:pauseend
|
||||
echo Type any key when you're done reading the error message.
|
||||
pause
|
||||
|
||||
rem --- end of makeit.bat
|
||||
:end
|
||||
109
apel-10.7/mcharset.el
Normal file
109
apel-10.7/mcharset.el
Normal file
@ -0,0 +1,109 @@
|
||||
;;; mcharset.el --- MIME charset API
|
||||
|
||||
;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
(require 'pcustom)
|
||||
|
||||
(cond ((featurep 'mule)
|
||||
(if (>= emacs-major-version 20)
|
||||
(require 'mcs-20)
|
||||
;; for MULE 1.* and 2.*
|
||||
(require 'mcs-om)))
|
||||
((boundp 'NEMACS)
|
||||
;; for Nemacs and Nepoch
|
||||
(require 'mcs-nemacs))
|
||||
(t
|
||||
(require 'mcs-ltn1)))
|
||||
|
||||
(defcustom default-mime-charset-for-write
|
||||
(if (mime-charset-p 'utf-8)
|
||||
'utf-8
|
||||
default-mime-charset)
|
||||
"Default value of MIME-charset for encoding.
|
||||
It may be used when suitable MIME-charset is not found.
|
||||
It must be symbol."
|
||||
:group 'i18n
|
||||
:type 'mime-charset)
|
||||
|
||||
(defcustom default-mime-charset-detect-method-for-write
|
||||
nil
|
||||
"Function called when suitable MIME-charset is not found to encode.
|
||||
It must be nil or function.
|
||||
If it is nil, variable `default-mime-charset-for-write' is used.
|
||||
If it is a function, interface must be (TYPE CHARSETS &rest ARGS).
|
||||
CHARSETS is list of charset.
|
||||
If TYPE is 'region, ARGS has START and END."
|
||||
:group 'i18n
|
||||
:type '(choice function (const nil)))
|
||||
|
||||
(defun charsets-to-mime-charset (charsets)
|
||||
"Return MIME charset from list of charset CHARSETS.
|
||||
Return nil if suitable mime-charset is not found."
|
||||
(if charsets
|
||||
(catch 'tag
|
||||
(let ((rest charsets-mime-charset-alist)
|
||||
cell)
|
||||
(while (setq cell (car rest))
|
||||
(if (catch 'not-subset
|
||||
(let ((set1 charsets)
|
||||
(set2 (car cell))
|
||||
obj)
|
||||
(while set1
|
||||
(setq obj (car set1))
|
||||
(or (memq obj set2)
|
||||
(throw 'not-subset nil))
|
||||
(setq set1 (cdr set1)))
|
||||
t))
|
||||
(throw 'tag (cdr cell)))
|
||||
(setq rest (cdr rest)))
|
||||
))))
|
||||
|
||||
(defun find-mime-charset-by-charsets (charsets &optional mode &rest args)
|
||||
"Like `charsets-to-mime-charset', but it does not return nil.
|
||||
|
||||
When suitable mime-charset is not found and variable
|
||||
`default-mime-charset-detect-method-for-write' is not nil,
|
||||
`find-mime-charset-by-charsets' calls the variable as function and
|
||||
return the return value of the function.
|
||||
Interface of the function is (MODE CHARSETS &rest ARGS).
|
||||
|
||||
When suitable mime-charset is not found and variable
|
||||
`default-mime-charset-detect-method-for-write' is nil,
|
||||
variable `default-mime-charset-for-write' is returned."
|
||||
(or (charsets-to-mime-charset charsets)
|
||||
(if default-mime-charset-detect-method-for-write
|
||||
(apply default-mime-charset-detect-method-for-write
|
||||
mode charsets args)
|
||||
default-mime-charset-for-write)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcharset) (require 'apel-ver))
|
||||
|
||||
;;; mcharset.el ends here
|
||||
235
apel-10.7/mcs-20.el
Normal file
235
apel-10.7/mcs-20.el
Normal file
@ -0,0 +1,235 @@
|
||||
;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule
|
||||
|
||||
;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
|
||||
;; or later.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'custom)
|
||||
(eval-when-compile (require 'wid-edit))
|
||||
|
||||
(if (featurep 'xemacs)
|
||||
(require 'mcs-xm)
|
||||
(require 'mcs-e20))
|
||||
|
||||
|
||||
;;; @ MIME charset
|
||||
;;;
|
||||
|
||||
(defcustom mime-charset-coding-system-alist
|
||||
(let ((rest
|
||||
'((us-ascii . raw-text)
|
||||
(gb2312 . cn-gb-2312)
|
||||
(cn-gb . cn-gb-2312)
|
||||
(iso-2022-jp-2 . iso-2022-7bit-ss2)
|
||||
(iso-2022-jp-3 . iso-2022-7bit-ss2)
|
||||
(tis-620 . tis620)
|
||||
(windows-874 . tis-620)
|
||||
(cp874 . tis-620)
|
||||
(x-ctext . ctext)
|
||||
(unknown . undecided)
|
||||
(x-unknown . undecided)
|
||||
))
|
||||
dest)
|
||||
(while rest
|
||||
(let ((pair (car rest)))
|
||||
(or (find-coding-system (car pair))
|
||||
(setq dest (cons pair dest))
|
||||
))
|
||||
(setq rest (cdr rest))
|
||||
)
|
||||
dest)
|
||||
"Alist MIME CHARSET vs CODING-SYSTEM.
|
||||
MIME CHARSET and CODING-SYSTEM must be symbol."
|
||||
:group 'i18n
|
||||
:type '(repeat (cons symbol coding-system)))
|
||||
|
||||
(defcustom mime-charset-to-coding-system-default-method
|
||||
nil
|
||||
"Function called when suitable coding-system is not found from MIME-charset.
|
||||
It must be nil or function.
|
||||
If it is a function, interface must be (CHARSET LBT CODING-SYSTEM)."
|
||||
:group 'i18n
|
||||
:type '(choice function (const nil)))
|
||||
|
||||
(defun mime-charset-to-coding-system (charset &optional lbt)
|
||||
"Return coding-system corresponding with CHARSET.
|
||||
CHARSET is a symbol whose name is MIME charset.
|
||||
If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac')
|
||||
is specified, it is used as line break code type of coding-system."
|
||||
(if (stringp charset)
|
||||
(setq charset (intern (downcase charset)))
|
||||
)
|
||||
(let ((cs (assq charset mime-charset-coding-system-alist)))
|
||||
(setq cs
|
||||
(if cs
|
||||
(cdr cs)
|
||||
charset))
|
||||
(if lbt
|
||||
(setq cs (intern (format "%s-%s" cs
|
||||
(cond ((eq lbt 'CRLF) 'dos)
|
||||
((eq lbt 'LF) 'unix)
|
||||
((eq lbt 'CR) 'mac)
|
||||
(t lbt)))))
|
||||
)
|
||||
(if (find-coding-system cs)
|
||||
cs
|
||||
(if mime-charset-to-coding-system-default-method
|
||||
(funcall mime-charset-to-coding-system-default-method
|
||||
charset lbt cs)
|
||||
))))
|
||||
|
||||
(defalias 'mime-charset-p 'mime-charset-to-coding-system)
|
||||
|
||||
(defvar widget-mime-charset-prompt-value-history nil
|
||||
"History of input to `widget-mime-charset-prompt-value'.")
|
||||
|
||||
(define-widget 'mime-charset 'coding-system
|
||||
"A mime-charset."
|
||||
:format "%{%t%}: %v"
|
||||
:tag "MIME-charset"
|
||||
:prompt-history 'widget-mime-charset-prompt-value-history
|
||||
:prompt-value 'widget-mime-charset-prompt-value
|
||||
:action 'widget-mime-charset-action)
|
||||
|
||||
(defun widget-mime-charset-prompt-value (widget prompt value unbound)
|
||||
;; Read mime-charset from minibuffer.
|
||||
(intern
|
||||
(completing-read (format "%s (default %s) " prompt value)
|
||||
(mapcar (function
|
||||
(lambda (sym)
|
||||
(list (symbol-name sym))))
|
||||
(mime-charset-list)))))
|
||||
|
||||
(defun widget-mime-charset-action (widget &optional event)
|
||||
;; Read a mime-charset from the minibuffer.
|
||||
(let ((answer
|
||||
(widget-mime-charset-prompt-value
|
||||
widget
|
||||
(widget-apply widget :menu-tag-get)
|
||||
(widget-value widget)
|
||||
t)))
|
||||
(widget-value-set widget answer)
|
||||
(widget-apply widget :notify widget event)
|
||||
(widget-setup)))
|
||||
|
||||
(defcustom default-mime-charset 'x-unknown
|
||||
"Default value of MIME-charset.
|
||||
It is used when MIME-charset is not specified.
|
||||
It must be symbol."
|
||||
:group 'i18n
|
||||
:type 'mime-charset)
|
||||
|
||||
(cond ((featurep 'utf-2000)
|
||||
;; for CHISE Architecture
|
||||
(defun mcs-region-repertoire-p (start end charsets &optional buffer)
|
||||
(save-excursion
|
||||
(if buffer
|
||||
(set-buffer buffer))
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char (point-min))
|
||||
(catch 'tag
|
||||
(let (ch)
|
||||
(while (not (eobp))
|
||||
(setq ch (char-after (point)))
|
||||
(unless (some (lambda (ccs)
|
||||
(encode-char ch ccs))
|
||||
charsets)
|
||||
(throw 'tag nil))
|
||||
(forward-char)))
|
||||
t))))
|
||||
|
||||
(defun mcs-string-repertoire-p (string charsets &optional start end)
|
||||
(let ((i (if start
|
||||
(if (< start 0)
|
||||
(error 'args-out-of-range string start end)
|
||||
start)
|
||||
0))
|
||||
ch)
|
||||
(if end
|
||||
(if (> end (length string))
|
||||
(error 'args-out-of-range string start end))
|
||||
(setq end (length string)))
|
||||
(catch 'tag
|
||||
(while (< i end)
|
||||
(setq ch (aref string i))
|
||||
(unless (some (lambda (ccs)
|
||||
(encode-char ch ccs))
|
||||
charsets)
|
||||
(throw 'tag nil))
|
||||
(setq i (1+ i)))
|
||||
t)))
|
||||
|
||||
(defun detect-mime-charset-region (start end)
|
||||
"Return MIME charset for region between START and END."
|
||||
(let ((rest charsets-mime-charset-alist)
|
||||
cell)
|
||||
(catch 'tag
|
||||
(while rest
|
||||
(setq cell (car rest))
|
||||
(if (mcs-region-repertoire-p start end (car cell))
|
||||
(throw 'tag (cdr cell)))
|
||||
(setq rest (cdr rest)))
|
||||
default-mime-charset-for-write)))
|
||||
|
||||
(defun detect-mime-charset-string (string)
|
||||
"Return MIME charset for STRING."
|
||||
(let ((rest charsets-mime-charset-alist)
|
||||
cell)
|
||||
(catch 'tag
|
||||
(while rest
|
||||
(setq cell (car rest))
|
||||
(if (mcs-string-repertoire-p string (car cell))
|
||||
(throw 'tag (cdr cell)))
|
||||
(setq rest (cdr rest)))
|
||||
default-mime-charset-for-write)))
|
||||
)
|
||||
(t
|
||||
;; for legacy Mule
|
||||
(defun detect-mime-charset-region (start end)
|
||||
"Return MIME charset for region between START and END."
|
||||
(find-mime-charset-by-charsets (find-charset-region start end)
|
||||
'region start end))
|
||||
))
|
||||
|
||||
(defun write-region-as-mime-charset (charset start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but encode by MIME CHARSET."
|
||||
(let ((coding-system-for-write
|
||||
(or (mime-charset-to-coding-system charset)
|
||||
'binary)))
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-20) (require 'apel-ver))
|
||||
|
||||
;;; mcs-20.el ends here
|
||||
187
apel-10.7/mcs-e20.el
Normal file
187
apel-10.7/mcs-e20.el
Normal file
@ -0,0 +1,187 @@
|
||||
;;; mcs-e20.el --- MIME charset implementation for Emacs 20.1 and 20.2
|
||||
|
||||
;; Copyright (C) 1996,1997,1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.1 and 20.2.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'pces)
|
||||
(eval-when-compile (require 'static))
|
||||
|
||||
(defsubst encode-mime-charset-region (start end charset &optional lbt)
|
||||
"Encode the text between START and END as MIME CHARSET."
|
||||
(let (cs)
|
||||
(if (and enable-multibyte-characters
|
||||
(setq cs (mime-charset-to-coding-system charset lbt)))
|
||||
(encode-coding-region start end cs)
|
||||
)))
|
||||
|
||||
(defsubst decode-mime-charset-region (start end charset &optional lbt)
|
||||
"Decode the text between START and END as MIME CHARSET."
|
||||
(let (cs)
|
||||
(if (and enable-multibyte-characters
|
||||
(setq cs (mime-charset-to-coding-system charset lbt)))
|
||||
(decode-coding-region start end cs)
|
||||
)))
|
||||
|
||||
|
||||
(defsubst encode-mime-charset-string (string charset &optional lbt)
|
||||
"Encode the STRING as MIME CHARSET."
|
||||
(let (cs)
|
||||
(if (and enable-multibyte-characters
|
||||
(setq cs (mime-charset-to-coding-system charset lbt)))
|
||||
(encode-coding-string string cs)
|
||||
string)))
|
||||
|
||||
(defsubst decode-mime-charset-string (string charset &optional lbt)
|
||||
"Decode the STRING as MIME CHARSET."
|
||||
(let (cs)
|
||||
(if (and enable-multibyte-characters
|
||||
(setq cs (mime-charset-to-coding-system charset lbt)))
|
||||
(decode-coding-string string cs)
|
||||
string)))
|
||||
|
||||
|
||||
(defvar charsets-mime-charset-alist
|
||||
(delq
|
||||
nil
|
||||
`(((ascii) . us-ascii)
|
||||
((ascii latin-iso8859-1) . iso-8859-1)
|
||||
((ascii latin-iso8859-2) . iso-8859-2)
|
||||
((ascii latin-iso8859-3) . iso-8859-3)
|
||||
((ascii latin-iso8859-4) . iso-8859-4)
|
||||
;;((ascii cyrillic-iso8859-5) . iso-8859-5)
|
||||
((ascii cyrillic-iso8859-5) . koi8-r)
|
||||
((ascii arabic-iso8859-6) . iso-8859-6)
|
||||
((ascii greek-iso8859-7) . iso-8859-7)
|
||||
((ascii hebrew-iso8859-8) . iso-8859-8)
|
||||
((ascii latin-iso8859-9) . iso-8859-9)
|
||||
,(if (find-coding-system 'iso-8859-14)
|
||||
'((ascii latin-iso8859-14) . iso-8859-14))
|
||||
,(if (find-coding-system 'iso-8859-15)
|
||||
'((ascii latin-iso8859-15) . iso-8859-15))
|
||||
((ascii latin-jisx0201
|
||||
japanese-jisx0208-1978 japanese-jisx0208) . iso-2022-jp)
|
||||
((ascii latin-jisx0201
|
||||
katakana-jisx0201 japanese-jisx0208) . shift_jis)
|
||||
((ascii korean-ksc5601) . euc-kr)
|
||||
((ascii chinese-gb2312) . gb2312)
|
||||
((ascii chinese-big5-1 chinese-big5-2) . big5)
|
||||
((ascii thai-tis620 composition) . tis-620)
|
||||
((ascii latin-iso8859-1 greek-iso8859-7
|
||||
latin-jisx0201 japanese-jisx0208-1978
|
||||
chinese-gb2312 japanese-jisx0208
|
||||
korean-ksc5601 japanese-jisx0212) . iso-2022-jp-2)
|
||||
;;((ascii latin-iso8859-1 greek-iso8859-7
|
||||
;; latin-jisx0201 japanese-jisx0208-1978
|
||||
;; chinese-gb2312 japanese-jisx0208
|
||||
;; korean-ksc5601 japanese-jisx0212
|
||||
;; chinese-cns11643-1 chinese-cns11643-2) . iso-2022-int-1)
|
||||
;;((ascii latin-iso8859-1 latin-iso8859-2
|
||||
;; cyrillic-iso8859-5 greek-iso8859-7
|
||||
;; latin-jisx0201 japanese-jisx0208-1978
|
||||
;; chinese-gb2312 japanese-jisx0208
|
||||
;; korean-ksc5601 japanese-jisx0212
|
||||
;; chinese-cns11643-1 chinese-cns11643-2
|
||||
;; chinese-cns11643-3 chinese-cns11643-4
|
||||
;; chinese-cns11643-5 chinese-cns11643-6
|
||||
;; chinese-cns11643-7) . iso-2022-int-1)
|
||||
)))
|
||||
|
||||
(defun-maybe coding-system-get (coding-system prop)
|
||||
"Extract a value from CODING-SYSTEM's property list for property PROP."
|
||||
(plist-get (coding-system-plist coding-system) prop)
|
||||
)
|
||||
|
||||
(defun coding-system-to-mime-charset (coding-system)
|
||||
"Convert CODING-SYSTEM to a MIME-charset.
|
||||
Return nil if corresponding MIME-charset is not found."
|
||||
(or (car (rassq coding-system mime-charset-coding-system-alist))
|
||||
(coding-system-get coding-system 'mime-charset)
|
||||
))
|
||||
|
||||
(defun-maybe-cond mime-charset-list ()
|
||||
"Return a list of all existing MIME-charset."
|
||||
((boundp 'coding-system-list)
|
||||
(let ((dest (mapcar (function car) mime-charset-coding-system-alist))
|
||||
(rest coding-system-list)
|
||||
cs)
|
||||
(while rest
|
||||
(setq cs (car rest))
|
||||
(unless (rassq cs mime-charset-coding-system-alist)
|
||||
(if (setq cs (coding-system-get cs 'mime-charset))
|
||||
(or (rassq cs mime-charset-coding-system-alist)
|
||||
(memq cs dest)
|
||||
(setq dest (cons cs dest))
|
||||
)))
|
||||
(setq rest (cdr rest)))
|
||||
dest))
|
||||
(t
|
||||
(let ((dest (mapcar (function car) mime-charset-coding-system-alist))
|
||||
(rest (coding-system-list))
|
||||
cs)
|
||||
(while rest
|
||||
(setq cs (car rest))
|
||||
(unless (rassq cs mime-charset-coding-system-alist)
|
||||
(when (setq cs (or (coding-system-get cs 'mime-charset)
|
||||
(and
|
||||
(setq cs (aref
|
||||
(coding-system-get cs 'coding-spec)
|
||||
2))
|
||||
(string-match "(MIME:[ \t]*\\([^,)]+\\)" cs)
|
||||
(match-string 1 cs))))
|
||||
(setq cs (intern (downcase cs)))
|
||||
(or (rassq cs mime-charset-coding-system-alist)
|
||||
(memq cs dest)
|
||||
(setq dest (cons cs dest))
|
||||
)))
|
||||
(setq rest (cdr rest)))
|
||||
dest)
|
||||
))
|
||||
|
||||
(static-when (and (string= (decode-coding-string "\e.A\eN!" 'ctext) "\eN!")
|
||||
(or (not (find-coding-system 'x-ctext))
|
||||
(coding-system-get 'x-ctext 'apel)))
|
||||
(unless (find-coding-system 'x-ctext)
|
||||
(make-coding-system
|
||||
'x-ctext 2 ?x
|
||||
"Compound text based generic encoding for decoding unknown messages."
|
||||
'((ascii t) (latin-iso8859-1 t) t t
|
||||
nil ascii-eol ascii-cntl nil locking-shift single-shift nil nil nil
|
||||
init-bol nil nil)
|
||||
'((safe-charsets . t)
|
||||
(mime-charset . x-ctext)))
|
||||
(coding-system-put 'x-ctext 'apel t)
|
||||
))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-e20) (require 'apel-ver))
|
||||
|
||||
;;; mcs-e20.el ends here
|
||||
110
apel-10.7/mcs-ltn1.el
Normal file
110
apel-10.7/mcs-ltn1.el
Normal file
@ -0,0 +1,110 @@
|
||||
;;; mcs-ltn1.el --- MIME charset implementation for Emacs 19
|
||||
;;; and XEmacs without MULE
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar charsets-mime-charset-alist
|
||||
'(((ascii) . us-ascii)))
|
||||
|
||||
(defvar default-mime-charset 'iso-8859-1)
|
||||
|
||||
(defsubst lbt-to-string (lbt)
|
||||
(cdr (assq lbt '((nil . nil)
|
||||
(CRLF . "\r\n")
|
||||
(CR . "\r")
|
||||
(dos . "\r\n")
|
||||
(mac . "\r"))))
|
||||
)
|
||||
|
||||
(defun mime-charset-to-coding-system (charset &optional lbt)
|
||||
(if (stringp charset)
|
||||
(setq charset (intern (downcase charset))))
|
||||
(if (memq charset (list 'us-ascii default-mime-charset))
|
||||
charset))
|
||||
|
||||
(defalias 'mime-charset-p 'mime-charset-to-coding-system)
|
||||
|
||||
(defun detect-mime-charset-region (start end)
|
||||
"Return MIME charset for region between START and END."
|
||||
(if (save-excursion
|
||||
(goto-char start)
|
||||
(re-search-forward "[\200-\377]" end t))
|
||||
default-mime-charset
|
||||
'us-ascii))
|
||||
|
||||
(defun encode-mime-charset-region (start end charset &optional lbt)
|
||||
"Encode the text between START and END as MIME CHARSET."
|
||||
(let ((newline (lbt-to-string lbt)))
|
||||
(if newline
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\n" nil t)
|
||||
(replace-match newline))
|
||||
)))
|
||||
))
|
||||
|
||||
(defun decode-mime-charset-region (start end charset &optional lbt)
|
||||
"Decode the text between START and END as MIME CHARSET."
|
||||
(let ((newline (lbt-to-string lbt)))
|
||||
(if newline
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward newline nil t)
|
||||
(replace-match "\n"))
|
||||
)))
|
||||
))
|
||||
|
||||
(defun encode-mime-charset-string (string charset &optional lbt)
|
||||
"Encode the STRING as MIME CHARSET."
|
||||
(if lbt
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(encode-mime-charset-region (point-min)(point-max) charset lbt)
|
||||
(buffer-string))
|
||||
string))
|
||||
|
||||
(defun decode-mime-charset-string (string charset &optional lbt)
|
||||
"Decode the STRING as MIME CHARSET."
|
||||
(if lbt
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(decode-mime-charset-region (point-min)(point-max) charset lbt)
|
||||
(buffer-string))
|
||||
string))
|
||||
|
||||
(defalias 'write-region-as-mime-charset 'write-region)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-ltn1) (require 'apel-ver))
|
||||
|
||||
;;; mcs-ltn1.el ends here
|
||||
130
apel-10.7/mcs-nemacs.el
Normal file
130
apel-10.7/mcs-nemacs.el
Normal file
@ -0,0 +1,130 @@
|
||||
;;; mcs-nemacs.el --- MIME charset implementation for Nemacs
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar charsets-mime-charset-alist
|
||||
'(((ascii) . us-ascii)))
|
||||
|
||||
(defvar default-mime-charset 'iso-2022-jp)
|
||||
|
||||
(defvar mime-charset-coding-system-alist
|
||||
'((iso-2022-jp . 2)
|
||||
(shift_jis . 1)
|
||||
))
|
||||
|
||||
(defsubst lbt-to-string (lbt)
|
||||
(cdr (assq lbt '((nil . nil)
|
||||
(CRLF . "\r\n")
|
||||
(CR . "\r")
|
||||
(dos . "\r\n")
|
||||
(mac . "\r"))))
|
||||
)
|
||||
|
||||
(defun mime-charset-to-coding-system (charset &optional lbt)
|
||||
(if (stringp charset)
|
||||
(setq charset (intern (downcase charset)))
|
||||
)
|
||||
(cdr (assq charset mime-charset-coding-system-alist)))
|
||||
|
||||
(fset 'mime-charset-p 'mime-charset-to-coding-system)
|
||||
|
||||
(defun detect-mime-charset-region (start end)
|
||||
"Return MIME charset for region between START and END.
|
||||
\[emu-nemacs.el]"
|
||||
(if (save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char start)
|
||||
(re-search-forward "[\200-\377]" nil t)))
|
||||
default-mime-charset
|
||||
'us-ascii))
|
||||
|
||||
(defun encode-mime-charset-region (start end charset &optional lbt)
|
||||
"Encode the text between START and END as MIME CHARSET.
|
||||
\[emu-nemacs.el]"
|
||||
(let ((cs (mime-charset-to-coding-system charset))
|
||||
(nl (lbt-to-string lbt)))
|
||||
(and (numberp cs)
|
||||
(or (= cs 3)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(convert-region-kanji-code start end 3 cs)
|
||||
(if nl
|
||||
(progn
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\n" nil t)
|
||||
(replace-match nl)))
|
||||
)))
|
||||
))))
|
||||
|
||||
(defun decode-mime-charset-region (start end charset &optional lbt)
|
||||
"Decode the text between START and END as MIME CHARSET.
|
||||
\[emu-nemacs.el]"
|
||||
(let ((cs (mime-charset-to-coding-system charset))
|
||||
(nl (lbt-to-string lbt)))
|
||||
(and (numberp cs)
|
||||
(or (= cs 3)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(convert-region-kanji-code start end cs 3)
|
||||
(if nl
|
||||
(progn
|
||||
(goto-char (point-min))
|
||||
(while (search-forward nl nil t)
|
||||
(replace-match "\n")))
|
||||
)))
|
||||
))))
|
||||
|
||||
(defun encode-mime-charset-string (string charset &optional lbt)
|
||||
"Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(encode-mime-charset-region (point-min)(point-max) charset lbt)
|
||||
(buffer-string)))
|
||||
|
||||
(defun decode-mime-charset-string (string charset &optional lbt)
|
||||
"Decode the STRING as MIME CHARSET. [emu-nemacs.el]"
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(decode-mime-charset-region (point-min)(point-max) charset lbt)
|
||||
(buffer-string)))
|
||||
|
||||
(defun write-region-as-mime-charset (charset start end filename)
|
||||
"Like `write-region', q.v., but code-convert by MIME CHARSET.
|
||||
\[emu-nemacs.el]"
|
||||
(let ((kanji-fileio-code
|
||||
(or (mime-charset-to-coding-system charset) 0)))
|
||||
(write-region start end filename)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-nemacs) (require 'apel-ver))
|
||||
|
||||
;;; mcs-nemacs.el ends here
|
||||
243
apel-10.7/mcs-om.el
Normal file
243
apel-10.7/mcs-om.el
Normal file
@ -0,0 +1,243 @@
|
||||
;;; mcs-om.el --- MIME charset implementation for Mule 1.* and Mule 2.*
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poem)
|
||||
|
||||
(defsubst lbt-to-string (lbt)
|
||||
(cdr (assq lbt '((nil . nil)
|
||||
(CRLF . "\r\n")
|
||||
(CR . "\r")
|
||||
(dos . "\r\n")
|
||||
(mac . "\r"))))
|
||||
)
|
||||
|
||||
(defun encode-mime-charset-region (start end charset &optional lbt)
|
||||
"Encode the text between START and END as MIME CHARSET."
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(code-convert start end *internal* cs)
|
||||
(if (and lbt (setq cs (mime-charset-to-coding-system charset)))
|
||||
(let ((newline (lbt-to-string lbt)))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(code-convert (point-min) (point-max) *internal* cs)
|
||||
(if newline
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\n" nil t)
|
||||
(replace-match newline))))))))))
|
||||
|
||||
(defun decode-mime-charset-region (start end charset &optional lbt)
|
||||
"Decode the text between START and END as MIME CHARSET."
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(code-convert start end cs *internal*)
|
||||
(if (and lbt (setq cs (mime-charset-to-coding-system charset)))
|
||||
(let ((newline (lbt-to-string lbt)))
|
||||
(if newline
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward newline nil t)
|
||||
(replace-match "\n")))
|
||||
(code-convert (point-min) (point-max) cs *internal*))
|
||||
(code-convert start end cs *internal*)))))))
|
||||
|
||||
(defun encode-mime-charset-string (string charset &optional lbt)
|
||||
"Encode the STRING as MIME CHARSET."
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(code-convert-string string *internal* cs)
|
||||
(if (and lbt (setq cs (mime-charset-to-coding-system charset)))
|
||||
(let ((newline (lbt-to-string lbt)))
|
||||
(if newline
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(code-convert (point-min) (point-max) *internal* cs)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\n" nil t)
|
||||
(replace-match newline))
|
||||
(buffer-string))
|
||||
(decode-coding-string string cs)))
|
||||
string))))
|
||||
|
||||
(defun decode-mime-charset-string (string charset &optional lbt)
|
||||
"Decode the STRING which is encoded in MIME CHARSET."
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(decode-coding-string string cs)
|
||||
(if (and lbt (setq cs (mime-charset-to-coding-system charset)))
|
||||
(let ((newline (lbt-to-string lbt)))
|
||||
(if newline
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward newline nil t)
|
||||
(replace-match "\n"))
|
||||
(code-convert (point-min) (point-max) cs *internal*)
|
||||
(buffer-string))
|
||||
(decode-coding-string string cs)))
|
||||
string))))
|
||||
|
||||
(cond
|
||||
((and (>= emacs-major-version 19) (>= emacs-minor-version 29))
|
||||
;; for MULE 2.3 based on Emacs 19.34.
|
||||
(defun write-region-as-mime-charset (charset start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but code-convert by MIME CHARSET."
|
||||
(let ((file-coding-system
|
||||
(or (mime-charset-to-coding-system charset)
|
||||
*noconv*)))
|
||||
(write-region start end filename append visit lockname)))
|
||||
)
|
||||
(t
|
||||
;; for MULE 2.3 based on Emacs 19.28.
|
||||
(defun write-region-as-mime-charset (charset start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but code-convert by MIME CHARSET."
|
||||
(let ((file-coding-system
|
||||
(or (mime-charset-to-coding-system charset)
|
||||
*noconv*)))
|
||||
(write-region start end filename append visit)))
|
||||
))
|
||||
|
||||
|
||||
;;; @ to coding-system
|
||||
;;;
|
||||
|
||||
(condition-case nil
|
||||
(require 'cyrillic)
|
||||
(error nil))
|
||||
|
||||
(defvar mime-charset-coding-system-alist
|
||||
'((iso-8859-1 . *ctext*)
|
||||
(x-ctext . *ctext*)
|
||||
(gb2312 . *euc-china*)
|
||||
(koi8-r . *koi8*)
|
||||
(iso-2022-jp-2 . *iso-2022-ss2-7*)
|
||||
(x-iso-2022-jp-2 . *iso-2022-ss2-7*)
|
||||
(shift_jis . *sjis*)
|
||||
(x-shiftjis . *sjis*)
|
||||
))
|
||||
|
||||
(defsubst mime-charset-to-coding-system (charset &optional lbt)
|
||||
"Return coding-system corresponding with CHARSET.
|
||||
CHARSET is a symbol whose name is MIME charset.
|
||||
If optional argument LBT (`CRLF', `LF', `CR', `unix', `dos' or `mac')
|
||||
is specified, it is used as line break code type of coding-system."
|
||||
(if (stringp charset)
|
||||
(setq charset (intern (downcase charset)))
|
||||
)
|
||||
(setq charset (or (cdr (assq charset mime-charset-coding-system-alist))
|
||||
(intern (concat "*" (symbol-name charset) "*"))))
|
||||
(if lbt
|
||||
(setq charset (intern (format "%s%s" charset
|
||||
(cond ((eq lbt 'CRLF) 'dos)
|
||||
((eq lbt 'LF) 'unix)
|
||||
((eq lbt 'CR) 'mac)
|
||||
(t lbt)))))
|
||||
)
|
||||
(if (coding-system-p charset)
|
||||
charset
|
||||
))
|
||||
|
||||
|
||||
;;; @ detection
|
||||
;;;
|
||||
|
||||
(defvar charsets-mime-charset-alist
|
||||
(let ((alist
|
||||
'(((lc-ascii) . us-ascii)
|
||||
((lc-ascii lc-ltn1) . iso-8859-1)
|
||||
((lc-ascii lc-ltn2) . iso-8859-2)
|
||||
((lc-ascii lc-ltn3) . iso-8859-3)
|
||||
((lc-ascii lc-ltn4) . iso-8859-4)
|
||||
;;; ((lc-ascii lc-crl) . iso-8859-5)
|
||||
((lc-ascii lc-crl) . koi8-r)
|
||||
((lc-ascii lc-arb) . iso-8859-6)
|
||||
((lc-ascii lc-grk) . iso-8859-7)
|
||||
((lc-ascii lc-hbw) . iso-8859-8)
|
||||
((lc-ascii lc-ltn5) . iso-8859-9)
|
||||
((lc-ascii lc-roman lc-jpold lc-jp) . iso-2022-jp)
|
||||
((lc-ascii lc-kr) . euc-kr)
|
||||
((lc-ascii lc-cn) . gb2312)
|
||||
((lc-ascii lc-big5-1 lc-big5-2) . big5)
|
||||
((lc-ascii lc-roman lc-ltn1 lc-grk
|
||||
lc-jpold lc-cn lc-jp lc-kr
|
||||
lc-jp2) . iso-2022-jp-2)
|
||||
((lc-ascii lc-roman lc-ltn1 lc-grk
|
||||
lc-jpold lc-cn lc-jp lc-kr lc-jp2
|
||||
lc-cns1 lc-cns2) . iso-2022-int-1)
|
||||
((lc-ascii lc-roman
|
||||
lc-ltn1 lc-ltn2 lc-crl lc-grk
|
||||
lc-jpold lc-cn lc-jp lc-kr lc-jp2
|
||||
lc-cns1 lc-cns2 lc-cns3 lc-cns4
|
||||
lc-cns5 lc-cns6 lc-cns7) . iso-2022-int-1)
|
||||
))
|
||||
dest)
|
||||
(while alist
|
||||
(catch 'not-found
|
||||
(let ((pair (car alist)))
|
||||
(setq dest
|
||||
(append dest
|
||||
(list
|
||||
(cons (mapcar (function
|
||||
(lambda (cs)
|
||||
(if (boundp cs)
|
||||
(symbol-value cs)
|
||||
(throw 'not-found nil)
|
||||
)))
|
||||
(car pair))
|
||||
(cdr pair)))))))
|
||||
(setq alist (cdr alist)))
|
||||
dest))
|
||||
|
||||
(defvar default-mime-charset 'x-ctext
|
||||
"Default value of MIME-charset.
|
||||
It is used when MIME-charset is not specified.
|
||||
It must be symbol.")
|
||||
|
||||
(defvar default-mime-charset-for-write
|
||||
default-mime-charset
|
||||
"Default value of MIME-charset for encoding.
|
||||
It is used when suitable MIME-charset is not found.
|
||||
It must be symbol.")
|
||||
|
||||
(defun detect-mime-charset-region (start end)
|
||||
"Return MIME charset for region between START and END."
|
||||
(or (charsets-to-mime-charset
|
||||
(cons lc-ascii (find-charset-region start end)))
|
||||
default-mime-charset-for-write))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-om) (require 'apel-ver))
|
||||
|
||||
;;; mcs-om.el ends here
|
||||
201
apel-10.7/mcs-xm.el
Normal file
201
apel-10.7/mcs-xm.el
Normal file
@ -0,0 +1,201 @@
|
||||
;;; mcs-xm.el --- MIME charset implementation for XEmacs-mule
|
||||
|
||||
;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: MIME-charset, coding-system, emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
|
||||
;; or later.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poem)
|
||||
|
||||
|
||||
(defun encode-mime-charset-region (start end charset &optional lbt)
|
||||
"Encode the text between START and END as MIME CHARSET."
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(encode-coding-region start end cs)
|
||||
)))
|
||||
|
||||
|
||||
(defcustom mime-charset-decoder-alist
|
||||
(let ((alist
|
||||
'((hz-gb-2312 . decode-mime-charset-region-for-hz)
|
||||
(t . decode-mime-charset-region-default))))
|
||||
(if (featurep 'utf-2000)
|
||||
alist
|
||||
(list*
|
||||
'(iso-2022-jp . decode-mime-charset-region-with-iso646-unification)
|
||||
'(iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification)
|
||||
alist)))
|
||||
"Alist MIME-charset vs. decoder function."
|
||||
:group 'i18n
|
||||
:type '(repeat (cons mime-charset function)))
|
||||
|
||||
(defsubst decode-mime-charset-region-default (start end charset lbt)
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(decode-coding-region start end cs)
|
||||
)))
|
||||
|
||||
(unless (featurep 'utf-2000)
|
||||
(require 'mcs-xmu))
|
||||
|
||||
(defun decode-mime-charset-region-for-hz (start end charset lbt)
|
||||
(if lbt
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(decode-coding-region (point-min)(point-max)
|
||||
(mime-charset-to-coding-system 'raw-text lbt))
|
||||
(decode-hz-region (point-min)(point-max)))
|
||||
(decode-hz-region start end)))
|
||||
|
||||
(defun decode-mime-charset-region (start end charset &optional lbt)
|
||||
"Decode the text between START and END as MIME CHARSET."
|
||||
(if (stringp charset)
|
||||
(setq charset (intern (downcase charset)))
|
||||
)
|
||||
(let ((func (cdr (or (assq charset mime-charset-decoder-alist)
|
||||
(assq t mime-charset-decoder-alist)))))
|
||||
(funcall func start end charset lbt)))
|
||||
|
||||
(defun encode-mime-charset-string (string charset &optional lbt)
|
||||
"Encode the STRING as MIME CHARSET."
|
||||
(let ((cs (mime-charset-to-coding-system charset lbt)))
|
||||
(if cs
|
||||
(encode-coding-string string cs)
|
||||
string)))
|
||||
|
||||
;; (defsubst decode-mime-charset-string (string charset)
|
||||
;; "Decode the STRING as MIME CHARSET."
|
||||
;; (let ((cs (mime-charset-to-coding-system charset)))
|
||||
;; (if cs
|
||||
;; (decode-coding-string string cs)
|
||||
;; string)))
|
||||
(defun decode-mime-charset-string (string charset &optional lbt)
|
||||
"Decode the STRING as MIME CHARSET."
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(decode-mime-charset-region (point-min)(point-max) charset lbt)
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
(defvar charsets-mime-charset-alist
|
||||
(delq
|
||||
nil
|
||||
`(((ascii) . us-ascii)
|
||||
((ascii latin-iso8859-1) . iso-8859-1)
|
||||
((ascii latin-iso8859-2) . iso-8859-2)
|
||||
((ascii latin-iso8859-3) . iso-8859-3)
|
||||
((ascii latin-iso8859-4) . iso-8859-4)
|
||||
((ascii cyrillic-iso8859-5) . iso-8859-5)
|
||||
;;((ascii cyrillic-iso8859-5) . koi8-r)
|
||||
((ascii arabic-iso8859-6) . iso-8859-6)
|
||||
((ascii greek-iso8859-7) . iso-8859-7)
|
||||
((ascii hebrew-iso8859-8) . iso-8859-8)
|
||||
((ascii latin-iso8859-9) . iso-8859-9)
|
||||
,(if (find-coding-system 'iso-8859-14)
|
||||
'((ascii latin-iso8859-14) . iso-8859-14))
|
||||
,(if (find-coding-system 'iso-8859-15)
|
||||
'((ascii latin-iso8859-15) . iso-8859-15))
|
||||
,(if (featurep 'utf-2000)
|
||||
'((ascii latin-jisx0201
|
||||
japanese-jisx0208-1978
|
||||
japanese-jisx0208
|
||||
japanese-jisx0208-1990) . iso-2022-jp)
|
||||
'((ascii latin-jisx0201
|
||||
japanese-jisx0208-1978 japanese-jisx0208)
|
||||
. iso-2022-jp))
|
||||
,(if (featurep 'utf-2000)
|
||||
'((ascii latin-jisx0201
|
||||
japanese-jisx0208-1978
|
||||
japanese-jisx0208
|
||||
japanese-jisx0208-1990
|
||||
japanese-jisx0213-1
|
||||
japanese-jisx0213-2) . iso-2022-jp-3)
|
||||
'((ascii latin-jisx0201
|
||||
japanese-jisx0208-1978 japanese-jisx0208
|
||||
japanese-jisx0213-1
|
||||
japanese-jisx0213-2) . iso-2022-jp-3))
|
||||
,(if (featurep 'utf-2000)
|
||||
'((ascii latin-jisx0201 katakana-jisx0201
|
||||
japanese-jisx0208-1990) . shift_jis)
|
||||
'((ascii latin-jisx0201
|
||||
katakana-jisx0201 japanese-jisx0208) . shift_jis))
|
||||
((ascii korean-ksc5601) . euc-kr)
|
||||
((ascii chinese-gb2312) . gb2312)
|
||||
((ascii chinese-big5-1 chinese-big5-2) . big5)
|
||||
((ascii thai-xtis) . tis-620)
|
||||
,(if (featurep 'utf-2000)
|
||||
'((ascii latin-jisx0201 latin-iso8859-1
|
||||
greek-iso8859-7
|
||||
japanese-jisx0208-1978 japanese-jisx0208
|
||||
japanese-jisx0208-1990
|
||||
japanese-jisx0212
|
||||
chinese-gb2312
|
||||
korean-ksc5601) . iso-2022-jp-2)
|
||||
'((ascii latin-jisx0201 latin-iso8859-1
|
||||
greek-iso8859-7
|
||||
japanese-jisx0208-1978 japanese-jisx0208
|
||||
japanese-jisx0212
|
||||
chinese-gb2312
|
||||
korean-ksc5601) . iso-2022-jp-2))
|
||||
;;((ascii latin-iso8859-1 greek-iso8859-7
|
||||
;; latin-jisx0201 japanese-jisx0208-1978
|
||||
;; chinese-gb2312 japanese-jisx0208
|
||||
;; korean-ksc5601 japanese-jisx0212
|
||||
;; chinese-cns11643-1 chinese-cns11643-2) . iso-2022-int-1)
|
||||
)))
|
||||
|
||||
|
||||
(defun coding-system-to-mime-charset (coding-system)
|
||||
"Convert CODING-SYSTEM to a MIME-charset.
|
||||
Return nil if corresponding MIME-charset is not found."
|
||||
(setq coding-system
|
||||
(coding-system-name (coding-system-base coding-system)))
|
||||
(or (car (rassq coding-system mime-charset-coding-system-alist))
|
||||
coding-system))
|
||||
|
||||
(defun mime-charset-list ()
|
||||
"Return a list of all existing MIME-charset."
|
||||
(let ((dest (mapcar (function car) mime-charset-coding-system-alist))
|
||||
(rest (coding-system-list))
|
||||
cs)
|
||||
(while rest
|
||||
(setq cs (coding-system-name (coding-system-base (car rest))))
|
||||
(or (rassq cs mime-charset-coding-system-alist)
|
||||
(memq cs dest)
|
||||
(setq dest (cons cs dest)))
|
||||
(setq rest (cdr rest)))
|
||||
dest))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-xm) (require 'apel-ver))
|
||||
|
||||
;;; mcs-xm.el ends here
|
||||
101
apel-10.7/mcs-xmu.el
Normal file
101
apel-10.7/mcs-xmu.el
Normal file
@ -0,0 +1,101 @@
|
||||
;;; mcs-xmu.el --- Functions to unify ISO646 characters for XEmacs-mule
|
||||
|
||||
;; Copyright (C) 1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module will be loaded from mcs-xm automatically.
|
||||
;; There is no guarantee that it will work alone.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defcustom mime-iso646-character-unification-alist
|
||||
(eval-when-compile
|
||||
(let (dest
|
||||
(i 33))
|
||||
(while (< i 92)
|
||||
(setq dest
|
||||
(cons (cons (char-to-string (make-char 'latin-jisx0201 i))
|
||||
(format "%c" i))
|
||||
dest))
|
||||
(setq i (1+ i)))
|
||||
(setq i 93)
|
||||
(while (< i 126)
|
||||
(setq dest
|
||||
(cons (cons (char-to-string (make-char 'latin-jisx0201 i))
|
||||
(format "%c" i))
|
||||
dest))
|
||||
(setq i (1+ i)))
|
||||
(nreverse dest)))
|
||||
"Alist unified string vs. canonical string."
|
||||
:group 'i18n
|
||||
:type '(repeat (cons string string)))
|
||||
|
||||
(defcustom mime-unified-character-face nil
|
||||
"Face of unified character."
|
||||
:group 'i18n
|
||||
:type 'face)
|
||||
|
||||
(defcustom mime-character-unification-limit-size 2048
|
||||
"Limit size to unify characters. It is referred by the function
|
||||
`decode-mime-charset-region-with-iso646-unification'. If the length of
|
||||
the specified region (start end) is larger than its value, the function
|
||||
works for only decoding MIME-CHARSET. If it is nil, size is unlimited."
|
||||
:group 'i18n
|
||||
:type '(radio (integer :tag "Max size")
|
||||
(const :tag "Unlimited" nil)))
|
||||
|
||||
(defun decode-mime-charset-region-with-iso646-unification (start end charset
|
||||
lbt)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(if (prog1
|
||||
(or (null mime-character-unification-limit-size)
|
||||
(<= (- end start) mime-character-unification-limit-size))
|
||||
(decode-mime-charset-region-default start end charset lbt))
|
||||
(let ((rest mime-iso646-character-unification-alist))
|
||||
(while rest
|
||||
(let ((pair (car rest))
|
||||
case-fold-search)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward (car pair) nil t)
|
||||
(let ((str (cdr pair)))
|
||||
(if mime-unified-character-face
|
||||
(put-text-property
|
||||
0 (length str)
|
||||
'face mime-unified-character-face str))
|
||||
(replace-match str 'fixed-case 'literal)
|
||||
)
|
||||
))
|
||||
(setq rest (cdr rest)))))
|
||||
)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mcs-xmu) (require 'apel-ver))
|
||||
|
||||
;;; mcs-xmu.el ends here
|
||||
86
apel-10.7/mule-caesar.el
Normal file
86
apel-10.7/mule-caesar.el
Normal file
@ -0,0 +1,86 @@
|
||||
;;; mule-caesar.el --- ROT 13-47 Caesar rotation utility
|
||||
|
||||
;; Copyright (C) 1997,1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'emu) ; for backward compatibility.
|
||||
(require 'poe) ; char-after.
|
||||
(require 'poem) ; charset-chars, char-charset,
|
||||
; and split-char.
|
||||
|
||||
(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))))
|
||||
(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)
|
||||
)
|
||||
((<= chr ?\x9f)
|
||||
(forward-char)
|
||||
)
|
||||
(t
|
||||
(let* ((stride (lsh (charset-chars (char-charset chr)) -1))
|
||||
(ret (mapcar (function
|
||||
(lambda (octet)
|
||||
(if (< octet 80)
|
||||
(+ octet stride)
|
||||
(- octet stride)
|
||||
)))
|
||||
(cdr (split-char chr)))))
|
||||
(delete-char 1)
|
||||
(insert (make-char (char-charset chr)
|
||||
(car ret)(car (cdr ret))))
|
||||
)))
|
||||
)))))
|
||||
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'mule-caesar) (require 'apel-ver))
|
||||
|
||||
;;; mule-caesar.el ends here
|
||||
201
apel-10.7/path-util.el
Normal file
201
apel-10.7/path-util.el
Normal file
@ -0,0 +1,201 @@
|
||||
;;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, 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 `default-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 (or (member p load-path)
|
||||
(if (string-match "/$" p)
|
||||
(member (substring p 0 (1- (length p))) load-path)
|
||||
(member (file-name-as-directory 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
|
||||
175
apel-10.7/pccl-20.el
Normal file
175
apel-10.7/pccl-20.el
Normal file
@ -0,0 +1,175 @@
|
||||
;;; pccl-20.el --- Portable CCL utility for Emacs 20 and XEmacs-21-mule
|
||||
|
||||
;; Copyright (C) 1998 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1998 Tanaka Akira
|
||||
|
||||
;; Author: Tanaka Akira <akr@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'ccl))
|
||||
(require 'broken)
|
||||
|
||||
(broken-facility ccl-accept-symbol-as-program
|
||||
"Emacs does not accept symbol as CCL program."
|
||||
(progn
|
||||
(define-ccl-program test-ccl-identity
|
||||
'(1 ((read r0) (loop (write-read-repeat r0)))))
|
||||
(condition-case nil
|
||||
(progn
|
||||
(funcall
|
||||
(if (fboundp 'ccl-vector-execute-on-string)
|
||||
'ccl-vector-execute-on-string
|
||||
'ccl-execute-on-string)
|
||||
'test-ccl-identity
|
||||
(make-vector 9 nil)
|
||||
"")
|
||||
t)
|
||||
(error nil)))
|
||||
t)
|
||||
|
||||
(eval-and-compile
|
||||
|
||||
(static-if (featurep 'xemacs)
|
||||
(defadvice make-coding-system (before ccl-compat (name type &rest ad-subr-args) activate)
|
||||
(when (and (integerp type)
|
||||
(eq type 4)
|
||||
(characterp (ad-get-arg 2))
|
||||
(stringp (ad-get-arg 3))
|
||||
(consp (ad-get-arg 4))
|
||||
(symbolp (car (ad-get-arg 4)))
|
||||
(symbolp (cdr (ad-get-arg 4))))
|
||||
(setq type 'ccl)
|
||||
(setq ad-subr-args
|
||||
(list
|
||||
(ad-get-arg 3)
|
||||
(append
|
||||
(list
|
||||
'mnemonic (char-to-string (ad-get-arg 2))
|
||||
'decode (symbol-value (car (ad-get-arg 4)))
|
||||
'encode (symbol-value (cdr (ad-get-arg 4))))
|
||||
(ad-get-arg 5)))))))
|
||||
|
||||
(if (featurep 'xemacs)
|
||||
(defun make-ccl-coding-system (name mnemonic docstring decoder encoder)
|
||||
"\
|
||||
Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
|
||||
|
||||
CODING-SYSTEM, DECODER and ENCODER must be symbol."
|
||||
(make-coding-system
|
||||
name 'ccl docstring
|
||||
(list 'mnemonic (char-to-string mnemonic)
|
||||
'decode (symbol-value decoder)
|
||||
'encode (symbol-value encoder))))
|
||||
(defun make-ccl-coding-system
|
||||
(coding-system mnemonic docstring decoder encoder)
|
||||
"\
|
||||
Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
|
||||
|
||||
CODING-SYSTEM, DECODER and ENCODER must be symbol."
|
||||
(when-broken ccl-accept-symbol-as-program
|
||||
(setq decoder (symbol-value decoder))
|
||||
(setq encoder (symbol-value encoder)))
|
||||
(make-coding-system coding-system 4 mnemonic docstring
|
||||
(cons decoder encoder)))
|
||||
)
|
||||
|
||||
(when-broken ccl-accept-symbol-as-program
|
||||
|
||||
(when (subrp (symbol-function 'ccl-execute))
|
||||
(fset 'ccl-vector-program-execute
|
||||
(symbol-function 'ccl-execute))
|
||||
(defun ccl-execute (ccl-prog reg)
|
||||
"\
|
||||
Execute CCL-PROG with registers initialized by REGISTERS.
|
||||
If CCL-PROG is symbol, it is dereferenced."
|
||||
(ccl-vector-program-execute
|
||||
(if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
|
||||
reg)))
|
||||
|
||||
(when (subrp (symbol-function 'ccl-execute-on-string))
|
||||
(fset 'ccl-vector-program-execute-on-string
|
||||
(symbol-function 'ccl-execute-on-string))
|
||||
(defun ccl-execute-on-string (ccl-prog status string &optional contin)
|
||||
"\
|
||||
Execute CCL-PROG with initial STATUS on STRING.
|
||||
If CCL-PROG is symbol, it is dereferenced."
|
||||
(ccl-vector-program-execute-on-string
|
||||
(if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
|
||||
status string contin)))
|
||||
)
|
||||
)
|
||||
|
||||
(eval-when-compile
|
||||
(define-ccl-program test-ccl-eof-block
|
||||
'(1
|
||||
((read r0)
|
||||
(write r0)
|
||||
(read r0))
|
||||
(write "[EOF]")))
|
||||
|
||||
(make-ccl-coding-system
|
||||
'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
|
||||
'test-ccl-eof-block 'test-ccl-eof-block)
|
||||
)
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-encoding-null
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)"
|
||||
(equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-encoding-some
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)"
|
||||
(equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-decoding-null
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)"
|
||||
(equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-decoding-some
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)"
|
||||
(equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-encoding
|
||||
"Emacs may forget executing CCL_EOF_BLOCK with encoding."
|
||||
(not (or (broken-p 'ccl-execute-eof-block-on-encoding-null)
|
||||
(broken-p 'ccl-execute-eof-block-on-encoding-some)))
|
||||
t)
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-decoding
|
||||
"Emacs may forget executing CCL_EOF_BLOCK with decoding."
|
||||
(not (or (broken-p 'ccl-execute-eof-block-on-decoding-null)
|
||||
(broken-p 'ccl-execute-eof-block-on-decoding-some)))
|
||||
t)
|
||||
|
||||
(broken-facility ccl-execute-eof-block
|
||||
"Emacs may forget executing CCL_EOF_BLOCK."
|
||||
(not (or (broken-p 'ccl-execute-eof-block-on-encoding)
|
||||
(broken-p 'ccl-execute-eof-block-on-decoding)))
|
||||
t)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pccl-20) (require 'apel-ver))
|
||||
|
||||
;;; pccl-20.el ends here
|
||||
129
apel-10.7/pccl-om.el
Normal file
129
apel-10.7/pccl-om.el
Normal file
@ -0,0 +1,129 @@
|
||||
;;; pccl-om.el --- Portable CCL utility for Mule 2.*
|
||||
|
||||
;; Copyright (C) 1998 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1998 Tanaka Akira
|
||||
|
||||
;; Author: Tanaka Akira <akr@jaist.ac.jp>
|
||||
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'ccl))
|
||||
(require 'broken)
|
||||
|
||||
(broken-facility ccl-accept-symbol-as-program
|
||||
"Emacs does not accept symbol as CCL program.")
|
||||
|
||||
(eval-and-compile
|
||||
(defun make-ccl-coding-system
|
||||
(coding-system mnemonic doc-string decoder encoder)
|
||||
"\
|
||||
Define a new CODING-SYSTEM by CCL programs DECODER and ENCODER.
|
||||
|
||||
CODING-SYSTEM, DECODER and ENCODER must be symbol."
|
||||
(setq decoder (symbol-value decoder)
|
||||
encoder (symbol-value encoder))
|
||||
(make-coding-system coding-system 4 mnemonic doc-string
|
||||
nil ; Mule takes one more optional argument: EOL-TYPE.
|
||||
(cons decoder encoder)))
|
||||
)
|
||||
|
||||
(defun ccl-execute (ccl-prog reg)
|
||||
"Execute CCL-PROG with registers initialized by REGISTERS.
|
||||
If CCL-PROG is symbol, it is dereferenced."
|
||||
(exec-ccl
|
||||
(if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
|
||||
reg))
|
||||
|
||||
(defun ccl-execute-on-string (ccl-prog status string &optional contin)
|
||||
"Execute CCL-PROG with initial STATUS on STRING.
|
||||
If CCL-PROG is symbol, it is dereferenced."
|
||||
(exec-ccl-string
|
||||
(if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
|
||||
status string))
|
||||
|
||||
(broken-facility ccl-execute-on-string-ignore-contin
|
||||
"CONTIN argument for ccl-execute-on-string is ignored.")
|
||||
|
||||
(eval-when-compile
|
||||
(define-ccl-program test-ccl-eof-block
|
||||
'(1
|
||||
((read r0)
|
||||
(write r0)
|
||||
(read r0))
|
||||
(write "[EOF]")))
|
||||
|
||||
(make-ccl-coding-system
|
||||
'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
|
||||
'test-ccl-eof-block 'test-ccl-eof-block)
|
||||
)
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-encoding-null
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input."
|
||||
(equal (code-convert-string "" *internal* 'test-ccl-eof-block-cs) "[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-encoding-some
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input."
|
||||
(equal (code-convert-string "a" *internal* 'test-ccl-eof-block-cs) "a[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-decoding-null
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input."
|
||||
(equal (code-convert-string "" 'test-ccl-eof-block-cs *internal*) "[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-decoding-some
|
||||
"Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input."
|
||||
(equal (code-convert-string "a" 'test-ccl-eof-block-cs *internal*) "a[EOF]"))
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-encoding
|
||||
"Emacs may forget executing CCL_EOF_BLOCK with encoding."
|
||||
(not (or (broken-p 'ccl-execute-eof-block-on-encoding-null)
|
||||
(broken-p 'ccl-execute-eof-block-on-encoding-some)))
|
||||
t)
|
||||
|
||||
(broken-facility ccl-execute-eof-block-on-decoding
|
||||
"Emacs may forget executing CCL_EOF_BLOCK with decoding."
|
||||
(not (or (broken-p 'ccl-execute-eof-block-on-decoding-null)
|
||||
(broken-p 'ccl-execute-eof-block-on-decoding-some)))
|
||||
t)
|
||||
|
||||
(broken-facility ccl-execute-eof-block
|
||||
"Emacs may forget executing CCL_EOF_BLOCK."
|
||||
(not (or (broken-p 'ccl-execute-eof-block-on-encoding)
|
||||
(broken-p 'ccl-execute-eof-block-on-decoding)))
|
||||
t)
|
||||
|
||||
(broken-facility ccl-cascading-read
|
||||
"Emacs CCL read command does not accept more than 2 arguments."
|
||||
(condition-case nil
|
||||
(progn
|
||||
(define-ccl-program cascading-read-test
|
||||
'(1
|
||||
(read r0 r1 r2)))
|
||||
t)
|
||||
(error nil)))
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pccl-om) (require 'apel-ver))
|
||||
|
||||
;;; pccl-om.el ends here
|
||||
170
apel-10.7/pccl.el
Normal file
170
apel-10.7/pccl.el
Normal file
@ -0,0 +1,170 @@
|
||||
;;; pccl.el --- Portable CCL utility for Mule 2.*
|
||||
|
||||
;; Copyright (C) 1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'broken)
|
||||
|
||||
(broken-facility ccl-usable
|
||||
"Emacs has not CCL."
|
||||
(and (featurep 'mule)
|
||||
(if (featurep 'xemacs)
|
||||
(>= emacs-major-version 21)
|
||||
(>= emacs-major-version 19))))
|
||||
|
||||
(unless-broken ccl-usable
|
||||
(require 'advice)
|
||||
|
||||
(if (featurep 'mule)
|
||||
(progn
|
||||
(require 'ccl)
|
||||
(if (featurep 'xemacs)
|
||||
(if (>= emacs-major-version 21)
|
||||
;; for XEmacs 21 with mule
|
||||
(require 'pccl-20))
|
||||
(if (>= emacs-major-version 20)
|
||||
;; for Emacs 20
|
||||
(require 'pccl-20)
|
||||
;; for Mule 2.*
|
||||
(require 'pccl-om)))))
|
||||
|
||||
(static-if (or (featurep 'xemacs) (< emacs-major-version 21))
|
||||
(defadvice define-ccl-program
|
||||
(before accept-long-ccl-program activate)
|
||||
"When CCL-PROGRAM is too long, internal buffer is extended automatically."
|
||||
(let ((try-ccl-compile t)
|
||||
(prog (eval (ad-get-arg 1))))
|
||||
(ad-set-arg 1 (` '(, prog)))
|
||||
(while try-ccl-compile
|
||||
(setq try-ccl-compile nil)
|
||||
(condition-case sig
|
||||
(ccl-compile prog)
|
||||
(args-out-of-range
|
||||
(if (and (eq (car (cdr sig)) ccl-program-vector)
|
||||
(= (car (cdr (cdr sig))) (length ccl-program-vector)))
|
||||
(setq ccl-program-vector
|
||||
(make-vector (* 2 (length ccl-program-vector)) 0)
|
||||
try-ccl-compile t)
|
||||
(signal (car sig) (cdr sig)))))))))
|
||||
|
||||
(static-when (and (not (featurep 'xemacs)) (< emacs-major-version 21))
|
||||
(defun-maybe transform-make-coding-system-args (name type &optional doc-string props)
|
||||
"For internal use only.
|
||||
Transform XEmacs style args for `make-coding-system' to Emacs style.
|
||||
Value is a list of transformed arguments."
|
||||
(let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?")))
|
||||
(eol-type (plist-get props 'eol-type))
|
||||
properties tmp)
|
||||
(cond
|
||||
((eq eol-type 'lf) (setq eol-type 'unix))
|
||||
((eq eol-type 'crlf) (setq eol-type 'dos))
|
||||
((eq eol-type 'cr) (setq eol-type 'mac)))
|
||||
(if (setq tmp (plist-get props 'post-read-conversion))
|
||||
(setq properties (plist-put properties 'post-read-conversion tmp)))
|
||||
(if (setq tmp (plist-get props 'pre-write-conversion))
|
||||
(setq properties (plist-put properties 'pre-write-conversion tmp)))
|
||||
(cond
|
||||
((eq type 'shift-jis)
|
||||
(` ((, name) 1 (, mnemonic) (, doc-string)
|
||||
nil (, properties) (, eol-type))))
|
||||
((eq type 'iso2022) ; This is not perfect.
|
||||
(if (plist-get props 'escape-quoted)
|
||||
(error "escape-quoted is not supported: %S"
|
||||
(` ((, name) (, type) (, doc-string) (, props)))))
|
||||
(let ((g0 (plist-get props 'charset-g0))
|
||||
(g1 (plist-get props 'charset-g1))
|
||||
(g2 (plist-get props 'charset-g2))
|
||||
(g3 (plist-get props 'charset-g3))
|
||||
(use-roman
|
||||
(and
|
||||
(eq (cadr (assoc 'latin-jisx0201
|
||||
(plist-get props 'input-charset-conversion)))
|
||||
'ascii)
|
||||
(eq (cadr (assoc 'ascii
|
||||
(plist-get props 'output-charset-conversion)))
|
||||
'latin-jisx0201)))
|
||||
(use-oldjis
|
||||
(and
|
||||
(eq (cadr (assoc 'japanese-jisx0208-1978
|
||||
(plist-get props 'input-charset-conversion)))
|
||||
'japanese-jisx0208)
|
||||
(eq (cadr (assoc 'japanese-jisx0208
|
||||
(plist-get props 'output-charset-conversion)))
|
||||
'japanese-jisx0208-1978))))
|
||||
(if (charsetp g0)
|
||||
(if (plist-get props 'force-g0-on-output)
|
||||
(setq g0 (` (nil (, g0))))
|
||||
(setq g0 (` ((, g0) t)))))
|
||||
(if (charsetp g1)
|
||||
(if (plist-get props 'force-g1-on-output)
|
||||
(setq g1 (` (nil (, g1))))
|
||||
(setq g1 (` ((, g1) t)))))
|
||||
(if (charsetp g2)
|
||||
(if (plist-get props 'force-g2-on-output)
|
||||
(setq g2 (` (nil (, g2))))
|
||||
(setq g2 (` ((, g2) t)))))
|
||||
(if (charsetp g3)
|
||||
(if (plist-get props 'force-g3-on-output)
|
||||
(setq g3 (` (nil (, g3))))
|
||||
(setq g3 (` ((, g3) t)))))
|
||||
(` ((, name) 2 (, mnemonic) (, doc-string)
|
||||
((, g0) (, g1) (, g2) (, g3)
|
||||
(, (plist-get props 'short))
|
||||
(, (not (plist-get props 'no-ascii-eol)))
|
||||
(, (not (plist-get props 'no-ascii-cntl)))
|
||||
(, (plist-get props 'seven))
|
||||
t
|
||||
(, (not (plist-get props 'lock-shift)))
|
||||
(, use-roman)
|
||||
(, use-oldjis)
|
||||
(, (plist-get props 'no-iso6429))
|
||||
nil nil nil nil)
|
||||
(, properties) (, eol-type)))))
|
||||
((eq type 'big5)
|
||||
(` ((, name) 3 (, mnemonic) (, doc-string)
|
||||
nil (, properties) (, eol-type))))
|
||||
((eq type 'ccl)
|
||||
(` ((, name) 4 (, mnemonic) (, doc-string)
|
||||
((, (plist-get props 'decode)) . (, (plist-get props 'encode)))
|
||||
(, properties) (, eol-type))))
|
||||
(t
|
||||
(error "unsupported XEmacs style make-coding-style arguments: %S"
|
||||
(` ((, name) (, type) (, doc-string) (, props))))))))
|
||||
(defadvice make-coding-system
|
||||
(before ccl-compat (name type &rest ad-subr-args) activate)
|
||||
"Emulate XEmacs style make-coding-system."
|
||||
(when (and (symbolp type) (not (memq type '(t nil))))
|
||||
(let ((args (apply 'transform-make-coding-system-args
|
||||
name type ad-subr-args)))
|
||||
(setq type (cadr args)
|
||||
ad-subr-args (cddr args)))))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pccl) (require 'apel-ver))
|
||||
|
||||
;;; pccl.el ends here
|
||||
239
apel-10.7/pces-20.el
Normal file
239
apel-10.7/pces-20.el
Normal file
@ -0,0 +1,239 @@
|
||||
;;; -*-byte-compile-dynamic: t;-*-
|
||||
;;; pces-20.el --- pces submodule for Emacs 20 and XEmacs with coding-system
|
||||
|
||||
;; Copyright (C) 1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
|
||||
;; or later.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;; (defun-maybe-cond multibyte-string-p (object)
|
||||
;; "Return t if OBJECT is a multibyte string."
|
||||
;; ((featurep 'mule) (stringp object))
|
||||
;; (t nil))
|
||||
|
||||
|
||||
;;; @ without code-conversion
|
||||
;;;
|
||||
|
||||
(defmacro as-binary-process (&rest body)
|
||||
`(let (selective-display ; Disable ^M to nl translation.
|
||||
(coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
,@body))
|
||||
|
||||
(defmacro as-binary-input-file (&rest body)
|
||||
`(let ((coding-system-for-read 'binary))
|
||||
,@body))
|
||||
|
||||
(defmacro as-binary-output-file (&rest body)
|
||||
`(let ((coding-system-for-write 'binary))
|
||||
,@body))
|
||||
|
||||
(defun write-region-as-binary (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but don't encode."
|
||||
(let ((coding-system-for-write 'binary)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
(require 'broken)
|
||||
|
||||
(broken-facility insert-file-contents-literally-treats-binary
|
||||
"Function `insert-file-contents-literally' decodes text."
|
||||
(let* ((str "\r\n")
|
||||
(coding-system-for-write 'binary)
|
||||
(coding-system-for-read 'raw-text-dos)
|
||||
;; (default-enable-multibyte-characters (multibyte-string-p str))
|
||||
)
|
||||
(with-temp-buffer
|
||||
(insert str)
|
||||
(write-region (point-min)(point-max) "literal-test-file")
|
||||
)
|
||||
(string=
|
||||
(with-temp-buffer
|
||||
(let (file-name-handler-alist)
|
||||
(insert-file-contents-literally "literal-test-file")
|
||||
)
|
||||
(buffer-string)
|
||||
)
|
||||
str)))
|
||||
|
||||
(broken-facility insert-file-contents-literally-treats-file-name-handler
|
||||
"Function `insert-file-contents' doesn't call file-name-handler."
|
||||
(let (called)
|
||||
(with-temp-buffer
|
||||
(let ((file-name-handler-alist
|
||||
'(("literal-test-file" . (lambda (operation &rest args)
|
||||
(setq called t)
|
||||
(let (file-name-handler-alist)
|
||||
(apply operation args)
|
||||
))))))
|
||||
(insert-file-contents-literally "literal-test-file")
|
||||
)
|
||||
(delete-file "literal-test-file")
|
||||
)
|
||||
called))
|
||||
|
||||
(static-if
|
||||
(or (broken-p 'insert-file-contents-literally-treats-binary)
|
||||
(broken-p 'insert-file-contents-literally-treats-file-name-handler))
|
||||
(defun insert-file-contents-as-binary (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', but only reads in the file literally.
|
||||
A buffer may be modified in several ways after reading into the buffer,
|
||||
to Emacs features such as format decoding, character code
|
||||
conversion, find-file-hooks, automatic uncompression, etc.
|
||||
|
||||
This function ensures that none of these modifications will take place."
|
||||
(let ((format-alist nil)
|
||||
(after-insert-file-functions nil)
|
||||
(coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary)
|
||||
(jka-compr-compression-info-list nil)
|
||||
(jam-zcat-filename-list nil)
|
||||
(find-buffer-file-type-function
|
||||
(if (fboundp 'find-buffer-file-type)
|
||||
(symbol-function 'find-buffer-file-type)
|
||||
nil)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fset 'find-buffer-file-type (lambda (filename) t))
|
||||
(insert-file-contents filename visit beg end replace))
|
||||
(if find-buffer-file-type-function
|
||||
(fset 'find-buffer-file-type find-buffer-file-type-function)
|
||||
(fmakunbound 'find-buffer-file-type)))))
|
||||
(defalias 'insert-file-contents-as-binary 'insert-file-contents-literally)
|
||||
)
|
||||
|
||||
(defun insert-file-contents-as-raw-text (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
Like `insert-file-contents-as-binary', but it converts line-break
|
||||
code."
|
||||
(let ((coding-system-for-read 'raw-text)
|
||||
format-alist)
|
||||
;; Returns list of absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace)))
|
||||
|
||||
(defun insert-file-contents-as-raw-text-CRLF (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
Like `insert-file-contents-as-binary', but it converts line-break code
|
||||
from CRLF to LF."
|
||||
(let ((coding-system-for-read 'raw-text-dos)
|
||||
format-alist)
|
||||
;; Returns list of absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace)))
|
||||
|
||||
(defun write-region-as-raw-text-CRLF (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but write as network representation."
|
||||
(let ((coding-system-for-write 'raw-text-dos))
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
(defun find-file-noselect-as-binary (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but don't code and format conversion."
|
||||
(let ((coding-system-for-read 'binary)
|
||||
format-alist)
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
|
||||
(defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but it does not code and format conversion
|
||||
except for line-break code."
|
||||
(let ((coding-system-for-read 'raw-text)
|
||||
format-alist)
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
|
||||
(defun find-file-noselect-as-raw-text-CRLF (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but it does not code and format conversion
|
||||
except for line-break code."
|
||||
(let ((coding-system-for-read 'raw-text-dos)
|
||||
format-alist)
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
|
||||
(defun save-buffer-as-binary (&optional args)
|
||||
"Like `save-buffer', q.v., but don't encode."
|
||||
(let ((coding-system-for-write 'binary))
|
||||
(save-buffer args)))
|
||||
|
||||
(defun save-buffer-as-raw-text-CRLF (&optional args)
|
||||
"Like `save-buffer', q.v., but save as network representation."
|
||||
(let ((coding-system-for-write 'raw-text-dos))
|
||||
(save-buffer args)))
|
||||
|
||||
(defun open-network-stream-as-binary (name buffer host service)
|
||||
"Like `open-network-stream', q.v., but don't code conversion."
|
||||
(let ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
(open-network-stream name buffer host service)))
|
||||
|
||||
|
||||
;;; @ with code-conversion
|
||||
;;;
|
||||
|
||||
(defun insert-file-contents-as-coding-system
|
||||
(coding-system filename &optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `coding-system-for-read'."
|
||||
(let ((coding-system-for-read coding-system)
|
||||
format-alist)
|
||||
(insert-file-contents filename visit beg end replace)))
|
||||
|
||||
(defun write-region-as-coding-system
|
||||
(coding-system start end filename &optional append visit lockname)
|
||||
"Like `write-region', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `coding-system-for-write'."
|
||||
(let ((coding-system-for-write coding-system)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
(defun find-file-noselect-as-coding-system
|
||||
(coding-system filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `coding-system-for-read'."
|
||||
(let ((coding-system-for-read coding-system)
|
||||
format-alist)
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
|
||||
(defun save-buffer-as-coding-system (coding-system &optional args)
|
||||
"Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `coding-system-for-write'."
|
||||
(let ((coding-system-for-write coding-system))
|
||||
(save-buffer args)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-20) (require 'apel-ver))
|
||||
|
||||
;;; pces-20.el ends here
|
||||
48
apel-10.7/pces-e20.el
Normal file
48
apel-10.7/pces-e20.el
Normal file
@ -0,0 +1,48 @@
|
||||
;;; pces-e20.el --- pces submodule for Emacs 20
|
||||
|
||||
;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'pces-20)
|
||||
|
||||
(unless (and (fboundp 'set-buffer-multibyte)
|
||||
(subrp (symbol-function 'set-buffer-multibyte)))
|
||||
(require 'pces-e20_2) ; for Emacs 20.1 and 20.2
|
||||
)
|
||||
|
||||
(defsubst-maybe find-coding-system (obj)
|
||||
"Return OBJ if it is a coding-system."
|
||||
(if (coding-system-p obj)
|
||||
obj))
|
||||
|
||||
(defalias 'set-process-input-coding-system 'set-process-coding-system)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-e20) (require 'apel-ver))
|
||||
|
||||
;;; pces-e20.el ends here
|
||||
150
apel-10.7/pces-e20_2.el
Normal file
150
apel-10.7/pces-e20_2.el
Normal file
@ -0,0 +1,150 @@
|
||||
;;; -*-byte-compile-dynamic: t;-*-
|
||||
;;; pces-e20_2.el --- pces implementation for Emacs 20.1 and 20.2
|
||||
|
||||
;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.1 and 20.2.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ without code-conversion
|
||||
;;;
|
||||
|
||||
(defun insert-file-contents-as-binary (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
|
||||
Namely this function ensures that only format decoding and character
|
||||
code conversion will not take place."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read 'binary)
|
||||
format-alist)
|
||||
(prog1
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace)
|
||||
;; This operation does not change the length.
|
||||
(set-buffer-multibyte flag))))
|
||||
|
||||
(defun insert-file-contents-as-raw-text (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
Like `insert-file-contents-as-binary', but it converts line-break
|
||||
code."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read 'raw-text)
|
||||
format-alist)
|
||||
(prog1
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace)
|
||||
;; This operation does not change the length.
|
||||
(set-buffer-multibyte flag))))
|
||||
|
||||
(defun insert-file-contents-as-raw-text-CRLF (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
Like `insert-file-contents-as-binary', but it converts line-break code
|
||||
from CRLF to LF."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read 'raw-text-dos)
|
||||
format-alist)
|
||||
(prog1
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace)
|
||||
;; This operation does not change the length.
|
||||
(set-buffer-multibyte flag))))
|
||||
|
||||
(defun find-file-noselect-as-binary (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but don't code and format conversion."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read 'binary)
|
||||
format-alist)
|
||||
(save-current-buffer
|
||||
(prog1
|
||||
(set-buffer (find-file-noselect filename nowarn rawfile))
|
||||
(set-buffer-multibyte flag)))))
|
||||
|
||||
(defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but it does not code and format conversion
|
||||
except for line-break code."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read 'raw-text)
|
||||
format-alist)
|
||||
(save-current-buffer
|
||||
(prog1
|
||||
(set-buffer (find-file-noselect filename nowarn rawfile))
|
||||
(set-buffer-multibyte flag)))))
|
||||
|
||||
(defun find-file-noselect-as-raw-text-CRLF (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but it does not code and format conversion
|
||||
except for line-break code."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read 'raw-text-dos)
|
||||
format-alist)
|
||||
(save-current-buffer
|
||||
(prog1
|
||||
(set-buffer (find-file-noselect filename nowarn rawfile))
|
||||
(set-buffer-multibyte flag)))))
|
||||
|
||||
|
||||
;;; @ with code-conversion
|
||||
;;;
|
||||
|
||||
(defun insert-file-contents-as-coding-system
|
||||
(coding-system filename &optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `coding-system-for-read'."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read coding-system)
|
||||
format-alist)
|
||||
(prog1
|
||||
(insert-file-contents filename visit beg end replace)
|
||||
(set-buffer-multibyte flag))))
|
||||
|
||||
(defun find-file-noselect-as-coding-system
|
||||
(coding-system filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `coding-system-for-read'."
|
||||
(let ((flag enable-multibyte-characters)
|
||||
(coding-system-for-read coding-system)
|
||||
format-alist)
|
||||
(save-current-buffer
|
||||
(prog1
|
||||
(set-buffer (find-file-noselect filename nowarn rawfile))
|
||||
(set-buffer-multibyte flag)))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-e20_2) (require 'apel-ver))
|
||||
|
||||
;;; pces-e20_2.el ends here
|
||||
276
apel-10.7/pces-nemacs.el
Normal file
276
apel-10.7/pces-nemacs.el
Normal file
@ -0,0 +1,276 @@
|
||||
;;; pces-nemacs.el --- pces implementation for Nemacs
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ coding system
|
||||
;;;
|
||||
|
||||
(defvar coding-system-kanji-code-alist
|
||||
'((binary . 0)
|
||||
(raw-text . 0)
|
||||
(shift_jis . 1)
|
||||
(iso-2022-jp . 2)
|
||||
(ctext . 2)
|
||||
(euc-jp . 3)
|
||||
))
|
||||
|
||||
(defun decode-coding-string (string coding-system)
|
||||
"Decode the STRING which is encoded in CODING-SYSTEM.
|
||||
\[emu-nemacs.el; EMACS 20 emulating function]"
|
||||
(let ((code (if (integerp coding-system)
|
||||
coding-system
|
||||
(cdr (assq coding-system coding-system-kanji-code-alist)))))
|
||||
(if (eq code 3)
|
||||
string
|
||||
(convert-string-kanji-code string code 3)
|
||||
)))
|
||||
|
||||
(defun encode-coding-string (string coding-system)
|
||||
"Encode the STRING to CODING-SYSTEM.
|
||||
\[emu-nemacs.el; EMACS 20 emulating function]"
|
||||
(let ((code (if (integerp coding-system)
|
||||
coding-system
|
||||
(cdr (assq coding-system coding-system-kanji-code-alist)))))
|
||||
(if (eq code 3)
|
||||
string
|
||||
(convert-string-kanji-code string 3 code)
|
||||
)))
|
||||
|
||||
(defun decode-coding-region (start end coding-system)
|
||||
"Decode the text between START and END which is encoded in CODING-SYSTEM.
|
||||
\[emu-nemacs.el; EMACS 20 emulating function]"
|
||||
(let ((code (if (integerp coding-system)
|
||||
coding-system
|
||||
(cdr (assq coding-system coding-system-kanji-code-alist)))))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(convert-region-kanji-code start end code 3)
|
||||
))))
|
||||
|
||||
(defun encode-coding-region (start end coding-system)
|
||||
"Encode the text between START and END to CODING-SYSTEM.
|
||||
\[emu-nemacs.el; EMACS 20 emulating function]"
|
||||
(let ((code (if (integerp coding-system)
|
||||
coding-system
|
||||
(cdr (assq coding-system coding-system-kanji-code-alist)))))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(convert-region-kanji-code start end 3 code)
|
||||
))))
|
||||
|
||||
(defun detect-coding-region (start end)
|
||||
"Detect coding-system of the text in the region between START and END.
|
||||
\[emu-nemacs.el; Emacs 20 emulating function]"
|
||||
(if (save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char start)
|
||||
(re-search-forward "[\200-\377]" nil t)))
|
||||
'euc-jp
|
||||
))
|
||||
|
||||
(defalias 'set-buffer-file-coding-system 'set-kanji-fileio-code)
|
||||
|
||||
|
||||
;;; @ without code-conversion
|
||||
;;;
|
||||
|
||||
(defmacro as-binary-process (&rest body)
|
||||
(` (let (selective-display ; Disable ^M to nl translation.
|
||||
;; Nemacs
|
||||
kanji-flag
|
||||
(default-kanji-process-code 0)
|
||||
program-kanji-code-alist)
|
||||
(,@ body))))
|
||||
|
||||
(defmacro as-binary-input-file (&rest body)
|
||||
(` (let (kanji-flag default-kanji-flag)
|
||||
(,@ body))))
|
||||
|
||||
(defmacro as-binary-output-file (&rest body)
|
||||
(` (let (kanji-flag)
|
||||
(,@ body))))
|
||||
|
||||
(defun write-region-as-binary (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]"
|
||||
(as-binary-output-file
|
||||
(write-region start end filename append visit)))
|
||||
|
||||
(defun insert-file-contents-as-binary (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't character code conversion.
|
||||
\[emu-nemacs.el]"
|
||||
(as-binary-input-file
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit)))
|
||||
|
||||
(defun insert-file-contents-as-raw-text (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't character code conversion.
|
||||
It converts line-break code from CRLF to LF. [emu-nemacs.el]"
|
||||
(save-restriction
|
||||
(narrow-to-region (point) (point))
|
||||
(let ((return (as-binary-input-file
|
||||
(insert-file-contents filename visit))))
|
||||
(while (search-forward "\r\n" nil t)
|
||||
(replace-match "\n"))
|
||||
(goto-char (point-min))
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(list (car return) (- (point-max) (point-min))))))
|
||||
|
||||
(defalias 'insert-file-contents-as-raw-text-CRLF
|
||||
'insert-file-contents-as-raw-text)
|
||||
|
||||
(defun write-region-as-raw-text-CRLF (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but don't code conversion. [emu-nemacs.el]"
|
||||
(let ((the-buf (current-buffer)))
|
||||
(with-temp-buffer
|
||||
(insert-buffer-substring the-buf start end)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
|
||||
(replace-match "\\1\r\n"))
|
||||
(write-region-as-binary (point-min)(point-max)
|
||||
filename append visit))))
|
||||
|
||||
(defun find-file-noselect-as-binary (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but don't code conversion.
|
||||
\[emu-nemacs.el]"
|
||||
(as-binary-input-file (find-file-noselect filename nowarn)))
|
||||
|
||||
(defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but it does not code conversion
|
||||
except for line-break code. [emu-nemacs.el]"
|
||||
(let ((buf (get-file-buffer filename))
|
||||
cur)
|
||||
(if buf
|
||||
(prog1
|
||||
buf
|
||||
(or nowarn
|
||||
(verify-visited-file-modtime buf)
|
||||
(cond ((not (file-exists-p filename))
|
||||
(error "File %s no longer exists!" filename))
|
||||
((yes-or-no-p
|
||||
(if (buffer-modified-p buf)
|
||||
"File has changed since last visited or saved. Flush your changes? "
|
||||
"File has changed since last visited or saved. Read from disk? "))
|
||||
(setq cur (current-buffer))
|
||||
(set-buffer buf)
|
||||
(revert-buffer t t)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\r\n" nil t)
|
||||
(replace-match "\n")))
|
||||
(set-buffer-modified-p nil)
|
||||
(set-buffer cur)))))
|
||||
(save-excursion
|
||||
(prog1
|
||||
(set-buffer
|
||||
(find-file-noselect-as-binary filename nowarn rawfile))
|
||||
(while (search-forward "\r\n" nil t)
|
||||
(replace-match "\n"))
|
||||
(goto-char (point-min))
|
||||
(set-buffer-modified-p nil))))))
|
||||
|
||||
(defalias 'find-file-noselect-as-raw-text-CRLF
|
||||
'find-file-noselect-as-raw-text)
|
||||
|
||||
(defun open-network-stream-as-binary (name buffer host service)
|
||||
"Like `open-network-stream', q.v., but don't code conversion.
|
||||
\[emu-nemacs.el]"
|
||||
(let ((process (open-network-stream name buffer host service)))
|
||||
(set-process-kanji-code process 0)
|
||||
process))
|
||||
|
||||
(defun save-buffer-as-binary (&optional args)
|
||||
"Like `save-buffer', q.v., but don't encode. [emu-nemacs.el]"
|
||||
(as-binary-output-file
|
||||
(save-buffer args)))
|
||||
|
||||
(defun save-buffer-as-raw-text-CRLF (&optional args)
|
||||
"Like `save-buffer', q.v., but save as network representation.
|
||||
\[emu-nemacs.el]"
|
||||
(if (buffer-modified-p)
|
||||
(save-restriction
|
||||
(widen)
|
||||
(let ((the-buf (current-buffer))
|
||||
(filename (buffer-file-name)))
|
||||
(if filename
|
||||
(prog1
|
||||
(with-temp-buffer
|
||||
(insert-buffer the-buf)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
|
||||
(replace-match "\\1\r\n"))
|
||||
(setq buffer-file-name filename)
|
||||
(save-buffer-as-binary args))
|
||||
(set-buffer-modified-p nil)
|
||||
(clear-visited-file-modtime)))))))
|
||||
|
||||
|
||||
;;; @ with code-conversion
|
||||
;;;
|
||||
|
||||
(defun insert-file-contents-as-coding-system
|
||||
(coding-system filename &optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `kanji-fileio-code'. [emu-nemacs.el]"
|
||||
(let ((kanji-fileio-code coding-system)
|
||||
kanji-expected-code)
|
||||
(insert-file-contents filename visit)))
|
||||
|
||||
(defun write-region-as-coding-system
|
||||
(coding-system start end filename &optional append visit lockname)
|
||||
"Like `write-region', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `kanji-fileio-code'. [emu-nemacs.el]"
|
||||
(let ((kanji-fileio-code coding-system)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename append visit)))
|
||||
|
||||
(defun find-file-noselect-as-coding-system
|
||||
(coding-system filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `kanji-fileio-code'. [emu-nemacs.el]"
|
||||
(let ((default-kanji-fileio-code coding-system)
|
||||
kanji-fileio-code kanji-expected-code)
|
||||
(find-file-noselect filename nowarn)))
|
||||
|
||||
(defun save-buffer-as-coding-system (coding-system &optional args)
|
||||
"Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `kanji-fileio-code'. [emu-nemacs.el]"
|
||||
(let ((kanji-fileio-code coding-system))
|
||||
(save-buffer args)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-nemacs) (require 'apel-ver))
|
||||
|
||||
;;; pces-nemacs.el ends here
|
||||
340
apel-10.7/pces-om.el
Normal file
340
apel-10.7/pces-om.el
Normal file
@ -0,0 +1,340 @@
|
||||
;;; pces-om.el --- pces implementation for Mule 1.* and Mule 2.*
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
|
||||
;;; @ version specific features
|
||||
;;;
|
||||
|
||||
(cond ((= emacs-major-version 19)
|
||||
(define-ccl-program poem-ccl-decode-raw-text
|
||||
'(1
|
||||
((r2 = 0)
|
||||
(read r0)
|
||||
(loop
|
||||
(if (r0 == ?\x0d)
|
||||
((r2 = 1)
|
||||
(read-if (r1 == ?\x0a)
|
||||
((r0 = ?\x0a)
|
||||
(r2 = 0)
|
||||
(write-read-repeat r0))
|
||||
((write r0)
|
||||
(r0 = (r1 + 0))
|
||||
(repeat))))
|
||||
((r2 = 0)
|
||||
(write-read-repeat r0)))))
|
||||
;; This EOF BLOCK won't work out in practice. So the last datum
|
||||
;; might be lost if it's value is ?\x0d.
|
||||
(if r2
|
||||
(write r0))
|
||||
)
|
||||
"Convert line-break code from CRLF to LF.")
|
||||
|
||||
(define-ccl-program poem-ccl-encode-raw-text
|
||||
'(1
|
||||
((read r0)
|
||||
(loop (write-read-repeat r0))))
|
||||
"Pass through without any conversions.")
|
||||
|
||||
(define-ccl-program poem-ccl-encode-raw-text-CRLF
|
||||
'(2
|
||||
((loop
|
||||
(read-if (r0 == ?\x0a)
|
||||
(write "\x0d\x0a")
|
||||
(write r0))
|
||||
(repeat))))
|
||||
"Convert line-break code from LF to CRLF.")
|
||||
|
||||
(make-coding-system
|
||||
'raw-text 4 ?=
|
||||
"No conversion"
|
||||
nil
|
||||
(cons poem-ccl-decode-raw-text poem-ccl-encode-raw-text))
|
||||
|
||||
(make-coding-system
|
||||
'raw-text-dos 4 ?=
|
||||
"No conversion"
|
||||
nil
|
||||
(cons poem-ccl-decode-raw-text poem-ccl-encode-raw-text-CRLF))
|
||||
)
|
||||
(t
|
||||
(defun poem-decode-raw-text (from to)
|
||||
(save-restriction
|
||||
(narrow-to-region from to)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r$" nil t)
|
||||
(replace-match "")
|
||||
)))
|
||||
(defun poem-encode-raw-text-CRLF (from to)
|
||||
(save-restriction
|
||||
(narrow-to-region from to)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
|
||||
(replace-match "\\1\r\n")
|
||||
)))
|
||||
|
||||
(make-coding-system 'raw-text nil ?= "No conversion")
|
||||
(put 'raw-text 'post-read-conversion 'poem-decode-raw-text)
|
||||
|
||||
(make-coding-system 'raw-text-dos nil ?= "No conversion")
|
||||
(put 'raw-text-dos 'post-read-conversion 'poem-decode-raw-text)
|
||||
(put 'raw-text-dos 'pre-write-conversion 'poem-encode-raw-text-CRLF)
|
||||
))
|
||||
|
||||
|
||||
;;; @ coding system
|
||||
;;;
|
||||
|
||||
(defun-maybe find-coding-system (obj)
|
||||
"Return OBJ if it is a coding-system."
|
||||
(if (coding-system-p obj)
|
||||
obj))
|
||||
|
||||
(defun encode-coding-region (start end coding-system)
|
||||
"Encode the text between START and END to CODING-SYSTEM.
|
||||
\[EMACS 20 emulating function]"
|
||||
;; If `coding-system' is nil, do nothing.
|
||||
(code-convert-region start end *internal* coding-system))
|
||||
|
||||
(defun decode-coding-region (start end coding-system)
|
||||
"Decode the text between START and END which is encoded in CODING-SYSTEM.
|
||||
\[EMACS 20 emulating function]"
|
||||
;; If `coding-system' is nil, do nothing.
|
||||
(code-convert-region start end coding-system *internal*))
|
||||
|
||||
;; XXX: Should we support optional NOCOPY argument? (only in Emacs 20.x)
|
||||
(defun encode-coding-string (str coding-system)
|
||||
"Encode the STRING to CODING-SYSTEM.
|
||||
\[EMACS 20 emulating function]"
|
||||
(if coding-system
|
||||
(code-convert-string str *internal* coding-system)
|
||||
;;(code-convert-string str *internal* nil) returns nil instead of str.
|
||||
str))
|
||||
|
||||
;; XXX: Should we support optional NOCOPY argument? (only in Emacs 20.x)
|
||||
(defun decode-coding-string (str coding-system)
|
||||
"Decode the string STR which is encoded in CODING-SYSTEM.
|
||||
\[EMACS 20 emulating function]"
|
||||
(if coding-system
|
||||
(let ((len (length str))
|
||||
ret)
|
||||
(while (and (< 0 len)
|
||||
(null (setq ret
|
||||
(code-convert-string
|
||||
(substring str 0 len)
|
||||
coding-system *internal*))))
|
||||
(setq len (1- len)))
|
||||
(concat ret (substring str len)))
|
||||
str))
|
||||
|
||||
(defalias 'detect-coding-region 'code-detect-region)
|
||||
|
||||
(defalias 'set-buffer-file-coding-system 'set-file-coding-system)
|
||||
|
||||
|
||||
;;; @ with code-conversion
|
||||
;;;
|
||||
|
||||
(cond
|
||||
((and (>= emacs-major-version 19) (>= emacs-minor-version 23))
|
||||
;; Mule 2.0 or later.
|
||||
(defun insert-file-contents-as-coding-system
|
||||
(coding-system filename &optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `file-coding-system-for-read'."
|
||||
(let ((file-coding-system-for-read coding-system))
|
||||
(insert-file-contents filename visit beg end replace))))
|
||||
(t
|
||||
;; Mule 1.1 or earlier.
|
||||
(defun insert-file-contents-as-coding-system
|
||||
(coding-system filename &optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `file-coding-system-for-read'."
|
||||
(let ((file-coding-system-for-read coding-system))
|
||||
(insert-file-contents filename visit)))))
|
||||
|
||||
(cond
|
||||
((and (>= emacs-major-version 19) (>= emacs-minor-version 29))
|
||||
;; for MULE 2.3 based on Emacs 19.34.
|
||||
(defun write-region-as-coding-system
|
||||
(coding-system start end filename &optional append visit lockname)
|
||||
"Like `write-region', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `file-coding-system'."
|
||||
(let ((file-coding-system coding-system)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
(defun find-file-noselect-as-coding-system
|
||||
(coding-system filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `file-coding-system-for-read'."
|
||||
(let ((file-coding-system-for-read coding-system))
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
)
|
||||
(t
|
||||
;; for MULE 2.3 based on Emacs 19.28 or MULE 1.*.
|
||||
(defun write-region-as-coding-system
|
||||
(coding-system start end filename &optional append visit lockname)
|
||||
"Like `write-region', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `file-coding-system'."
|
||||
(let ((file-coding-system coding-system)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename append visit)))
|
||||
|
||||
(defun find-file-noselect-as-coding-system
|
||||
(coding-system filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will
|
||||
be applied to `file-coding-system-for-read'."
|
||||
(let ((file-coding-system-for-read coding-system))
|
||||
(find-file-noselect filename nowarn)))
|
||||
))
|
||||
|
||||
(defun save-buffer-as-coding-system (coding-system &optional args)
|
||||
"Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be
|
||||
applied to `coding-system-for-write'."
|
||||
(let ((file-coding-system coding-system))
|
||||
(save-buffer args)))
|
||||
|
||||
|
||||
;;; @ without code-conversion
|
||||
;;;
|
||||
|
||||
(make-coding-system 'binary nil ?= "No conversion")
|
||||
|
||||
(defmacro as-binary-process (&rest body)
|
||||
(` (let (selective-display ; Disable ^M to nl translation.
|
||||
;; Mule
|
||||
mc-flag
|
||||
(default-process-coding-system (cons *noconv* *noconv*))
|
||||
program-coding-system-alist)
|
||||
(,@ body))))
|
||||
|
||||
(defmacro as-binary-input-file (&rest body)
|
||||
(` (let (mc-flag
|
||||
(file-coding-system-for-read *noconv*)
|
||||
)
|
||||
(,@ body))))
|
||||
|
||||
(defmacro as-binary-output-file (&rest body)
|
||||
(` (let (mc-flag
|
||||
(file-coding-system *noconv*)
|
||||
)
|
||||
(,@ body))))
|
||||
|
||||
(defalias 'set-process-input-coding-system 'set-process-coding-system)
|
||||
|
||||
(cond
|
||||
((and (>= emacs-major-version 19) (>= emacs-minor-version 23))
|
||||
;; Mule 2.0 or later.
|
||||
(defun insert-file-contents-as-binary (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
|
||||
Namely this function ensures that only format decoding and character
|
||||
code conversion will not take place."
|
||||
(as-binary-input-file
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace))))
|
||||
(t
|
||||
;; Mule 1.1 or earlier.
|
||||
(defun insert-file-contents-as-binary (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
|
||||
Namely this function ensures that only format decoding and character
|
||||
code conversion will not take place."
|
||||
(as-binary-input-file
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit)))))
|
||||
|
||||
(defun insert-file-contents-as-raw-text (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
Like `insert-file-contents-as-binary', but it converts line-break
|
||||
code."
|
||||
;; Returns list absolute file name and length of data inserted.
|
||||
(insert-file-contents-as-coding-system 'raw-text
|
||||
filename visit beg end replace))
|
||||
|
||||
(defalias 'insert-file-contents-as-raw-text-CRLF
|
||||
'insert-file-contents-as-raw-text)
|
||||
|
||||
(defun write-region-as-binary (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but don't code conversion."
|
||||
(write-region-as-coding-system 'binary
|
||||
start end filename append visit lockname))
|
||||
|
||||
(defun write-region-as-raw-text-CRLF (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but don't code conversion."
|
||||
(write-region-as-coding-system 'raw-text-dos
|
||||
start end filename append visit lockname))
|
||||
|
||||
(defun find-file-noselect-as-binary (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but don't code and format conversion."
|
||||
(find-file-noselect-as-coding-system 'binary filename nowarn rawfile))
|
||||
|
||||
(defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but it does not code and format
|
||||
conversion except for line-break code."
|
||||
(find-file-noselect-as-coding-system 'raw-text filename nowarn rawfile))
|
||||
|
||||
(defalias 'find-file-noselect-as-raw-text-CRLF
|
||||
'find-file-noselect-as-raw-text)
|
||||
|
||||
(defun save-buffer-as-binary (&optional args)
|
||||
"Like `save-buffer', q.v., but don't encode."
|
||||
(let ((file-coding-system 'binary))
|
||||
(save-buffer args)))
|
||||
|
||||
(defun save-buffer-as-raw-text-CRLF (&optional args)
|
||||
"Like `save-buffer', q.v., but save as network representation."
|
||||
(let ((file-coding-system 'raw-text-dos))
|
||||
(save-buffer args)))
|
||||
|
||||
(defun open-network-stream-as-binary (name buffer host service)
|
||||
"Like `open-network-stream', q.v., but don't code conversion."
|
||||
(let ((process (open-network-stream name buffer host service)))
|
||||
(set-process-coding-system process *noconv* *noconv*)
|
||||
process))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-om) (require 'apel-ver))
|
||||
|
||||
;;; pces-om.el ends here
|
||||
172
apel-10.7/pces-raw.el
Normal file
172
apel-10.7/pces-raw.el
Normal file
@ -0,0 +1,172 @@
|
||||
;;; pces-raw.el --- pces submodule for emacsen without coding-system features
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ coding-system
|
||||
;;;
|
||||
|
||||
(defun decode-coding-string (string coding-system)
|
||||
"Decode the STRING which is encoded in CODING-SYSTEM."
|
||||
(copy-sequence string))
|
||||
|
||||
(defun encode-coding-string (string coding-system)
|
||||
"Encode the STRING as CODING-SYSTEM."
|
||||
(copy-sequence string))
|
||||
|
||||
(defun decode-coding-region (start end coding-system)
|
||||
"Decode the text between START and END which is encoded in CODING-SYSTEM."
|
||||
0)
|
||||
|
||||
(defun encode-coding-region (start end coding-system)
|
||||
"Encode the text between START and END to CODING-SYSTEM."
|
||||
0)
|
||||
|
||||
(defun detect-coding-region (start end)
|
||||
"Detect coding-system of the text in the region between START and END."
|
||||
)
|
||||
|
||||
(defun set-buffer-file-coding-system (coding-system &optional force)
|
||||
"Set buffer-file-coding-system of the current buffer to CODING-SYSTEM."
|
||||
)
|
||||
|
||||
|
||||
;;; @ without code-conversion
|
||||
;;;
|
||||
|
||||
(defmacro as-binary-process (&rest body)
|
||||
(` (let (selective-display) ; Disable ^M to nl translation.
|
||||
(,@ body))))
|
||||
|
||||
(defmacro as-binary-input-file (&rest body)
|
||||
(` (let ((emx-binary-mode t)) ; Stop CRLF to LF conversion in OS/2
|
||||
(,@ body))))
|
||||
|
||||
(defmacro as-binary-output-file (&rest body)
|
||||
(` (let ((emx-binary-mode t)) ; Stop CRLF to LF conversion in OS/2
|
||||
(,@ body))))
|
||||
|
||||
(defun write-region-as-binary (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but don't code conversion."
|
||||
(let ((emx-binary-mode t))
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
(defun insert-file-contents-as-binary (filename
|
||||
&optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but don't code and format conversion.
|
||||
Like `insert-file-contents-literary', but it allows find-file-hooks,
|
||||
automatic uncompression, etc.
|
||||
|
||||
Namely this function ensures that only format decoding and character
|
||||
code conversion will not take place."
|
||||
(let ((emx-binary-mode t))
|
||||
;; Returns list of absolute file name and length of data inserted.
|
||||
(insert-file-contents filename visit beg end replace)))
|
||||
|
||||
(defun write-region-as-raw-text-CRLF (start end filename
|
||||
&optional append visit lockname)
|
||||
"Like `write-region', q.v., but write as network representation."
|
||||
(let ((the-buf (current-buffer)))
|
||||
(with-temp-buffer
|
||||
(insert-buffer-substring the-buf start end)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
|
||||
(replace-match "\\1\r\n"))
|
||||
(write-region (point-min)(point-max) filename append visit lockname))))
|
||||
|
||||
(defalias 'insert-file-contents-as-raw-text 'insert-file-contents)
|
||||
|
||||
(defalias 'insert-file-contents-as-raw-text-CRLF 'insert-file-contents)
|
||||
|
||||
(defun find-file-noselect-as-binary (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but don't code and format conversion."
|
||||
(let ((emx-binary-mode t))
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
|
||||
(defalias 'find-file-noselect-as-raw-text 'find-file-noselect)
|
||||
|
||||
(defalias 'find-file-noselect-as-raw-text-CRLF 'find-file-noselect)
|
||||
|
||||
(defun save-buffer-as-binary (&optional args)
|
||||
"Like `save-buffer', q.v., but don't encode."
|
||||
(let ((emx-binary-mode t))
|
||||
(save-buffer args)))
|
||||
|
||||
(defun save-buffer-as-raw-text-CRLF (&optional args)
|
||||
"Like `save-buffer', q.v., but save as network representation."
|
||||
(if (buffer-modified-p)
|
||||
(save-restriction
|
||||
(widen)
|
||||
(let ((the-buf (current-buffer))
|
||||
(filename (buffer-file-name)))
|
||||
(if filename
|
||||
(prog1
|
||||
(with-temp-buffer
|
||||
(insert-buffer the-buf)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\\(\\=\\|[^\r]\\)\n" nil t)
|
||||
(replace-match "\\1\r\n"))
|
||||
(setq buffer-file-name filename)
|
||||
(save-buffer args))
|
||||
(set-buffer-modified-p nil)
|
||||
(clear-visited-file-modtime)))))))
|
||||
|
||||
(defun open-network-stream-as-binary (name buffer host service)
|
||||
"Like `open-network-stream', q.v., but don't code conversion."
|
||||
(let ((emx-binary-mode t))
|
||||
(open-network-stream name buffer host service)))
|
||||
|
||||
|
||||
;;; @ with code-conversion (but actually it might be not done)
|
||||
;;;
|
||||
|
||||
(defun insert-file-contents-as-coding-system
|
||||
(coding-system filename &optional visit beg end replace)
|
||||
"Like `insert-file-contents', q.v., but CODING-SYSTEM is used to decode."
|
||||
(insert-file-contents filename visit beg end replace))
|
||||
|
||||
(defun write-region-as-coding-system
|
||||
(coding-system start end filename &optional append visit lockname)
|
||||
"Like `write-region', q.v., but CODING-SYSTEM is used to encode."
|
||||
(let (jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename append visit lockname)))
|
||||
|
||||
(defun find-file-noselect-as-coding-system
|
||||
(coding-system filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., CODING-SYSTEM is used to decode."
|
||||
(find-file-noselect filename nowarn rawfile))
|
||||
|
||||
(defun save-buffer-as-coding-system (coding-system &optional args)
|
||||
"Like `save-buffer', q.v., CODING-SYSTEM is used to encode."
|
||||
(save-buffer args))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-raw) (require 'apel-ver))
|
||||
|
||||
;;; pces-raw.el ends here
|
||||
48
apel-10.7/pces-xfc.el
Normal file
48
apel-10.7/pces-xfc.el
Normal file
@ -0,0 +1,48 @@
|
||||
;;; pces-xfc.el --- pces module for XEmacs with file coding
|
||||
|
||||
;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;; Redefine if -{dos|mac|unix} is not found.
|
||||
(or (find-coding-system 'raw-text-dos)
|
||||
(copy-coding-system 'no-conversion-dos 'raw-text-dos))
|
||||
(or (find-coding-system 'raw-text-mac)
|
||||
(copy-coding-system 'no-conversion-mac 'raw-text-mac))
|
||||
(or (find-coding-system 'raw-text-unix)
|
||||
(copy-coding-system 'no-conversion-unix 'raw-text-unix))
|
||||
|
||||
(if (featurep 'mule)
|
||||
(require 'pces-xm)
|
||||
)
|
||||
|
||||
(require 'pces-20)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-xfc) (require 'apel-ver))
|
||||
|
||||
;;; pces-xfc.el ends here
|
||||
78
apel-10.7/pces-xm.el
Normal file
78
apel-10.7/pces-xm.el
Normal file
@ -0,0 +1,78 @@
|
||||
;;; pces-xm.el --- pces module for XEmacs-mule
|
||||
|
||||
;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ fix coding-system definition
|
||||
;;;
|
||||
|
||||
;; It seems not bug, but I can not permit it...
|
||||
(and (coding-system-property 'iso-2022-jp 'input-charset-conversion)
|
||||
(copy-coding-system 'iso-2022-7bit 'iso-2022-jp))
|
||||
|
||||
(and (coding-system-property 'iso-2022-jp-dos 'input-charset-conversion)
|
||||
(copy-coding-system 'iso-2022-7bit-dos 'iso-2022-jp-dos))
|
||||
|
||||
(or (find-coding-system 'ctext-dos)
|
||||
(make-coding-system
|
||||
'ctext 'iso2022
|
||||
"Coding-system used in X as Compound Text Encoding."
|
||||
'(charset-g0 ascii charset-g1 latin-iso8859-1
|
||||
eol-type nil
|
||||
mnemonic "CText")))
|
||||
|
||||
(or (find-coding-system 'iso-2022-jp-2-dos)
|
||||
(make-coding-system
|
||||
'iso-2022-jp-2 'iso2022
|
||||
"ISO-2022 coding system using SS2 for 96-charset in 7-bit code."
|
||||
'(charset-g0 ascii
|
||||
charset-g2 t ;; unspecified but can be used later.
|
||||
seven t
|
||||
short t
|
||||
mnemonic "ISO7/SS2"
|
||||
eol-type nil)))
|
||||
|
||||
(or (find-coding-system 'gb2312-dos)
|
||||
(copy-coding-system 'cn-gb-2312-dos 'gb2312-dos))
|
||||
(or (find-coding-system 'gb2312-mac)
|
||||
(copy-coding-system 'cn-gb-2312-mac 'gb2312-mac))
|
||||
(or (find-coding-system 'gb2312-unix)
|
||||
(copy-coding-system 'cn-gb-2312-unix 'gb2312-unix))
|
||||
|
||||
(or (find-coding-system 'euc-kr-dos)
|
||||
(make-coding-system
|
||||
'euc-kr 'iso2022
|
||||
"Coding-system of Korean EUC (Extended Unix Code)."
|
||||
'(charset-g0 ascii charset-g1 korean-ksc5601
|
||||
mnemonic "ko/EUC"
|
||||
eol-type nil)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces-xm) (require 'apel-ver))
|
||||
|
||||
;;; pces-xm.el ends here
|
||||
59
apel-10.7/pces.el
Normal file
59
apel-10.7/pces.el
Normal file
@ -0,0 +1,59 @@
|
||||
;;; pces.el --- Portable Character Encoding Scheme (coding-system) features
|
||||
|
||||
;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: coding-system, emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
(eval-and-compile
|
||||
(unless (fboundp 'open-network-stream)
|
||||
(require 'tcp)))
|
||||
|
||||
(cond ((featurep 'xemacs)
|
||||
(if (featurep 'file-coding)
|
||||
(require 'pces-xfc)
|
||||
(require 'pces-raw)
|
||||
))
|
||||
((featurep 'mule)
|
||||
(if (>= emacs-major-version 20)
|
||||
(require 'pces-e20)
|
||||
;; for MULE 1.* and 2.*
|
||||
(require 'pces-om)
|
||||
))
|
||||
((boundp 'NEMACS)
|
||||
;; for Nemacs and Nepoch
|
||||
(require 'pces-nemacs)
|
||||
)
|
||||
(t
|
||||
(require 'pces-raw)
|
||||
))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pces) (require 'apel-ver))
|
||||
|
||||
;;; pces.el ends here
|
||||
65
apel-10.7/pcustom.el
Normal file
65
apel-10.7/pcustom.el
Normal file
@ -0,0 +1,65 @@
|
||||
;;; pcustom.el -- a portable custom.el.
|
||||
|
||||
;; Copyright (C) 1999 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1999 Mikio Nakajima <minakaji@osaka.email.ne.jp>
|
||||
|
||||
;; Author: Mikio Nakajima <minakaji@osaka.email.ne.jp>
|
||||
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: emulating, custom
|
||||
|
||||
;; 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 this program; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
(eval-when-compile (require 'static))
|
||||
|
||||
(static-if (condition-case nil
|
||||
;; compile-time check.
|
||||
(if (and (require 'custom)
|
||||
(fboundp 'custom-declare-variable))
|
||||
;; you have "new custom".
|
||||
t
|
||||
;; you have custom, but it is "old".
|
||||
(message "\
|
||||
** \"old custom\" is loaded. See README if you want to use \"new custom\".")
|
||||
(sleep-for 1)
|
||||
nil)
|
||||
;; you don't have custom.
|
||||
(error nil))
|
||||
;; you have "new custom". no load-time check.
|
||||
(require 'custom)
|
||||
;; your custom is "old custom",
|
||||
;; or you don't have custom library at compile-time.
|
||||
(or (condition-case nil
|
||||
;; load-time check.
|
||||
;; load "custom" if exists.
|
||||
(and (require 'custom)
|
||||
(fboundp 'custom-declare-variable))
|
||||
(error nil))
|
||||
;; your custom is "old custom",
|
||||
;; or you don't have custom library.
|
||||
;; load emulation version of "new custom".
|
||||
(require 'tinycustom)))
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pcustom) (require 'apel-ver))
|
||||
|
||||
;;; pcustom.el ends here
|
||||
847
apel-10.7/poe-18.el
Normal file
847
apel-10.7/poe-18.el
Normal file
@ -0,0 +1,847 @@
|
||||
;;; poe-18.el --- poe API implementation for Emacs 18.*
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1999 Yuuichi Teranishi
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Yuuichi Teranishi <teranisi@gohome.org>
|
||||
;; Keywords: emulation, compatibility
|
||||
|
||||
;; 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 this program; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Note to APEL developers and APEL programmers:
|
||||
;;
|
||||
;; If old (v18) compiler is used, top-level macros are expanded at
|
||||
;; *load-time*, not compile-time. Therefore,
|
||||
;;
|
||||
;; (1) Definitions with `*-maybe' won't be compiled.
|
||||
;;
|
||||
;; (2) you cannot use macros defined with `defmacro-maybe' within function
|
||||
;; definitions in the same file.
|
||||
;; (`defmacro-maybe' is evaluated at load-time, therefore byte-compiler
|
||||
;; treats such use of macros as (unknown) functions and compiles them
|
||||
;; into function calls, which will cause errors at run-time.)
|
||||
;;
|
||||
;; (3) `eval-when-compile' and `eval-and-compile' are evaluated at
|
||||
;; load-time if used at top-level.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'pym)
|
||||
|
||||
|
||||
;;; @ Compilation.
|
||||
;;;
|
||||
(defun defalias (sym newdef)
|
||||
"Set SYMBOL's function definition to NEWVAL, and return NEWVAL."
|
||||
(fset sym newdef))
|
||||
|
||||
(defun byte-code-function-p (object)
|
||||
"Return t if OBJECT is a byte-compiled function object."
|
||||
(and (consp object) (consp (cdr object))
|
||||
(let ((rest (cdr (cdr object)))
|
||||
elt)
|
||||
(if (stringp (car rest))
|
||||
(setq rest (cdr rest)))
|
||||
(catch 'tag
|
||||
(while rest
|
||||
(setq elt (car rest))
|
||||
(if (and (consp elt)
|
||||
(eq (car elt) 'byte-code))
|
||||
(throw 'tag t))
|
||||
(setq rest (cdr rest)))))))
|
||||
|
||||
;; (symbol-plist 'cyclic-function-indirection)
|
||||
(put 'cyclic-function-indirection
|
||||
'error-conditions
|
||||
'(cyclic-function-indirection error))
|
||||
(put 'cyclic-function-indirection
|
||||
'error-message
|
||||
"Symbol's chain of function indirections contains a loop")
|
||||
|
||||
;; The following function definition is a direct translation of its
|
||||
;; C definition in emacs-20.4/src/data.c.
|
||||
(defun indirect-function (object)
|
||||
"Return the function at the end of OBJECT's function chain.
|
||||
If OBJECT is a symbol, follow all function indirections and return the final
|
||||
function binding.
|
||||
If OBJECT is not a symbol, just return it.
|
||||
Signal a void-function error if the final symbol is unbound.
|
||||
Signal a cyclic-function-indirection error if there is a loop in the
|
||||
function chain of symbols."
|
||||
(let* ((hare object)
|
||||
(tortoise hare))
|
||||
(catch 'found
|
||||
(while t
|
||||
(or (symbolp hare) (throw 'found hare))
|
||||
(or (fboundp hare) (signal 'void-function (cons object nil)))
|
||||
(setq hare (symbol-function hare))
|
||||
(or (symbolp hare) (throw 'found hare))
|
||||
(or (fboundp hare) (signal 'void-function (cons object nil)))
|
||||
(setq hare (symbol-function hare))
|
||||
|
||||
(setq tortoise (symbol-function tortoise))
|
||||
|
||||
(if (eq hare tortoise)
|
||||
(signal 'cyclic-function-indirection (cons object nil)))))
|
||||
hare))
|
||||
|
||||
;;; Emulate all functions and macros of emacs-20.3/lisp/byte-run.el.
|
||||
;;; (note: jwz's original compiler and XEmacs compiler have some more
|
||||
;;; macros; they are "nuked" by rms in FSF version.)
|
||||
|
||||
;; Use `*-maybe' here because new byte-compiler may be installed.
|
||||
(put 'inline 'lisp-indent-hook 0)
|
||||
(defmacro-maybe inline (&rest body)
|
||||
"Eval BODY forms sequentially and return value of last one.
|
||||
|
||||
This emulating macro does not support function inlining because old \(v18\)
|
||||
compiler does not support inlining feature."
|
||||
(cons 'progn body))
|
||||
|
||||
(put 'defsubst 'lisp-indent-hook 'defun)
|
||||
(put 'defsubst 'edebug-form-spec 'defun)
|
||||
(defmacro-maybe defsubst (name arglist &rest body)
|
||||
"Define an inline function. The syntax is just like that of `defun'.
|
||||
|
||||
This emulating macro does not support function inlining because old \(v18\)
|
||||
compiler does not support inlining feature."
|
||||
(cons 'defun (cons name (cons arglist body))))
|
||||
|
||||
(defun-maybe make-obsolete (fn new)
|
||||
"Make the byte-compiler warn that FUNCTION is obsolete.
|
||||
The warning will say that NEW should be used instead.
|
||||
If NEW is a string, that is the `use instead' message.
|
||||
|
||||
This emulating function does nothing because old \(v18\) compiler does not
|
||||
support this feature."
|
||||
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
|
||||
fn)
|
||||
|
||||
(defun-maybe make-obsolete-variable (var new)
|
||||
"Make the byte-compiler warn that VARIABLE is obsolete,
|
||||
and NEW should be used instead. If NEW is a string, then that is the
|
||||
`use instead' message.
|
||||
|
||||
This emulating function does nothing because old \(v18\) compiler does not
|
||||
support this feature."
|
||||
(interactive "vMake variable obsolete: \nxObsoletion replacement: ")
|
||||
var)
|
||||
|
||||
(put 'dont-compile 'lisp-indent-hook 0)
|
||||
(defmacro-maybe dont-compile (&rest body)
|
||||
"Like `progn', but the body always runs interpreted \(not compiled\).
|
||||
If you think you need this, you're probably making a mistake somewhere."
|
||||
(list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
|
||||
|
||||
(put 'eval-when-compile 'lisp-indent-hook 0)
|
||||
(defmacro-maybe eval-when-compile (&rest body)
|
||||
"Like progn, but evaluates the body at compile-time.
|
||||
|
||||
This emulating macro does not do compile-time evaluation at all because
|
||||
of the limitation of old \(v18\) compiler."
|
||||
(cons 'progn body))
|
||||
|
||||
(put 'eval-and-compile 'lisp-indent-hook 0)
|
||||
(defmacro-maybe eval-and-compile (&rest body)
|
||||
"Like progn, but evaluates the body at compile-time as well as at load-time.
|
||||
|
||||
This emulating macro does not do compile-time evaluation at all because
|
||||
of the limitation of old \(v18\) compiler."
|
||||
(cons 'progn body))
|
||||
|
||||
|
||||
;;; @ C primitives emulation.
|
||||
;;;
|
||||
|
||||
(defun member (elt list)
|
||||
"Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.
|
||||
The value is actually the tail of LIST whose car is ELT."
|
||||
(while (and list (not (equal elt (car list))))
|
||||
(setq list (cdr list)))
|
||||
list)
|
||||
|
||||
(defun delete (elt list)
|
||||
"Delete by side effect any occurrences of ELT as a member of LIST.
|
||||
The modified LIST is returned. Comparison is done with `equal'.
|
||||
If the first member of LIST is ELT, deleting it is not a side effect;
|
||||
it is simply using a different list.
|
||||
Therefore, write `(setq foo (delete element foo))'
|
||||
to be sure of changing the value of `foo'."
|
||||
(if list
|
||||
(if (equal elt (car list))
|
||||
(cdr list)
|
||||
(let ((rest list)
|
||||
(rrest (cdr list)))
|
||||
(while (and rrest (not (equal elt (car rrest))))
|
||||
(setq rest rrest
|
||||
rrest (cdr rrest)))
|
||||
(setcdr rest (cdr rrest))
|
||||
list))))
|
||||
|
||||
(defun default-boundp (symbol)
|
||||
"Return t if SYMBOL has a non-void default value.
|
||||
This is the value that is seen in buffers that do not have their own values
|
||||
for this variable."
|
||||
(condition-case error
|
||||
(progn
|
||||
(default-value symbol)
|
||||
t)
|
||||
(void-variable nil)))
|
||||
|
||||
;;; @@ current-time.
|
||||
;;;
|
||||
|
||||
(defvar current-time-world-timezones
|
||||
'(("PST" . -800)("PDT" . -700)("MST" . -700)
|
||||
("MDT" . -600)("CST" . -600)("CDT" . -500)
|
||||
("EST" . -500)("EDT" . -400)("AST" . -400)
|
||||
("NST" . -330)("UT" . +000)("GMT" . +000)
|
||||
("BST" . +100)("MET" . +100)("EET" . +200)
|
||||
("JST" . +900)("GMT+1" . +100)("GMT+2" . +200)
|
||||
("GMT+3" . +300)("GMT+4" . +400)("GMT+5" . +500)
|
||||
("GMT+6" . +600)("GMT+7" . +700)("GMT+8" . +800)
|
||||
("GMT+9" . +900)("GMT+10" . +1000)("GMT+11" . +1100)
|
||||
("GMT+12" . +1200)("GMT+13" . +1300)("GMT-1" . -100)
|
||||
("GMT-2" . -200)("GMT-3" . -300)("GMT-4" . -400)
|
||||
("GMT-5" . -500)("GMT-6" . -600)("GMT-7" . -700)
|
||||
("GMT-8" . -800)("GMT-9" . -900)("GMT-10" . -1000)
|
||||
("GMT-11" . -1100) ("GMT-12" . -1200))
|
||||
"Time differentials of timezone from GMT in +-HHMM form.
|
||||
Used in `current-time-zone' (Emacs 19 emulating function by APEL).")
|
||||
|
||||
(defvar current-time-local-timezone nil
|
||||
"*Local timezone name.
|
||||
Used in `current-time-zone' (Emacs 19 emulating function by APEL).")
|
||||
|
||||
(defun set-time-zone-rule (tz)
|
||||
"Set the local time zone using TZ, a string specifying a time zone rule.
|
||||
If TZ is nil, use implementation-defined default time zone information.
|
||||
If TZ is t, use Universal Time."
|
||||
(cond
|
||||
((stringp tz)
|
||||
(setq current-time-local-timezone tz))
|
||||
(tz
|
||||
(setq current-time-local-timezone "GMT"))
|
||||
(t
|
||||
(setq current-time-local-timezone
|
||||
(with-temp-buffer
|
||||
;; We use `date' command to get timezone information.
|
||||
(call-process "date" nil (current-buffer) t)
|
||||
(goto-char (point-min))
|
||||
(if (looking-at
|
||||
"^.*\\([A-Z][A-Z][A-Z]\\([^ \n\t]*\\)\\).*$")
|
||||
(buffer-substring (match-beginning 1)
|
||||
(match-end 1))))))))
|
||||
|
||||
(defun current-time-zone (&optional specified-time)
|
||||
"Return the offset and name for the local time zone.
|
||||
This returns a list of the form (OFFSET NAME).
|
||||
OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
|
||||
A negative value means west of Greenwich.
|
||||
NAME is a string giving the name of the time zone.
|
||||
Optional argument SPECIFIED-TIME is ignored in this implementation.
|
||||
Some operating systems cannot provide all this information to Emacs;
|
||||
in this case, `current-time-zone' returns a list containing nil for
|
||||
the data it can't find."
|
||||
(let ((local-timezone (or current-time-local-timezone
|
||||
(progn
|
||||
(set-time-zone-rule nil)
|
||||
current-time-local-timezone)))
|
||||
timezone abszone seconds)
|
||||
(setq timezone
|
||||
(or (cdr (assoc (upcase local-timezone)
|
||||
current-time-world-timezones))
|
||||
;; "+900" style or nil.
|
||||
local-timezone))
|
||||
(when timezone
|
||||
(if (stringp timezone)
|
||||
(setq timezone (string-to-int timezone)))
|
||||
;; Taking account of minute in timezone.
|
||||
;; HHMM -> MM
|
||||
(setq abszone (abs timezone))
|
||||
(setq seconds (* 60 (+ (* 60 (/ abszone 100)) (% abszone 100))))
|
||||
(list (if (< timezone 0) (- seconds) seconds)
|
||||
local-timezone))))
|
||||
|
||||
(or (fboundp 'si:current-time-string)
|
||||
(fset 'si:current-time-string (symbol-function 'current-time-string)))
|
||||
(defun current-time-string (&optional specified-time)
|
||||
"Return the current time, as a human-readable string.
|
||||
Programs can use this function to decode a time,
|
||||
since the number of columns in each field is fixed.
|
||||
The format is `Sun Sep 16 01:03:52 1973'.
|
||||
If an argument SPECIFIED-TIME is given, it specifies a time to format
|
||||
instead of the current time. The argument should have the form:
|
||||
(HIGH . LOW)
|
||||
or the form:
|
||||
(HIGH LOW . IGNORED).
|
||||
Thus, you can use times obtained from `current-time'
|
||||
and from `file-attributes'."
|
||||
(if (null specified-time)
|
||||
(si:current-time-string)
|
||||
(or (consp specified-time)
|
||||
(error "Wrong type argument %s" specified-time))
|
||||
(let ((high (car specified-time))
|
||||
(low (cdr specified-time))
|
||||
(offset (or (car (current-time-zone)) 0))
|
||||
(mdays '(31 28 31 30 31 30 31 31 30 31 30 31))
|
||||
(mnames '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
|
||||
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
|
||||
(wnames '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
|
||||
days dd yyyy lyear mm HH MM SS)
|
||||
(if (consp low)
|
||||
(setq low (car low)))
|
||||
(or (integerp high)
|
||||
(error "Wrong type argument %s" high))
|
||||
(or (integerp low)
|
||||
(error "Wrong type argument %s" low))
|
||||
(setq low (+ low offset))
|
||||
(while (> low 65535)
|
||||
(setq high (1+ high)
|
||||
low (- low 65536)))
|
||||
(setq yyyy 1970)
|
||||
(while (or (> high 481)
|
||||
(and (= high 481)
|
||||
(>= low 13184)))
|
||||
(if (and (> high 0)
|
||||
(< low 13184))
|
||||
(setq high (1- high)
|
||||
low (+ 65536 low)))
|
||||
(setq high (- high 481)
|
||||
low (- low 13184))
|
||||
(if (and (zerop (% yyyy 4))
|
||||
(or (not (zerop (% yyyy 100)))
|
||||
(zerop (% yyyy 400))))
|
||||
(progn
|
||||
(if (and (> high 0)
|
||||
(< low 20864))
|
||||
(setq high (1- high)
|
||||
low (+ 65536 low)))
|
||||
(setq high (- high 1)
|
||||
low (- low 20864))))
|
||||
(setq yyyy (1+ yyyy)))
|
||||
(setq dd 1)
|
||||
(while (or (> high 1)
|
||||
(and (= high 1)
|
||||
(>= low 20864)))
|
||||
(if (and (> high 0)
|
||||
(< low 20864))
|
||||
(setq high (1- high)
|
||||
low (+ 65536 low)))
|
||||
(setq high (- high 1)
|
||||
low (- low 20864)
|
||||
dd (1+ dd)))
|
||||
(setq days dd)
|
||||
(if (= high 1)
|
||||
(setq low (+ 65536 low)))
|
||||
(setq mm 0)
|
||||
(setq lyear (and (zerop (% yyyy 4))
|
||||
(or (not (zerop (% yyyy 100)))
|
||||
(zerop (% yyyy 400)))))
|
||||
(while (> (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))) 0)
|
||||
(setq dd (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))))
|
||||
(setq mm (1+ mm)))
|
||||
(setq HH (/ low 3600)
|
||||
low (% low 3600)
|
||||
MM (/ low 60)
|
||||
SS (% low 60))
|
||||
(format "%s %s %2d %02d:%02d:%02d %4d"
|
||||
(nth (% (+ days
|
||||
(- (+ (* (1- yyyy) 365) (/ (1- yyyy) 400)
|
||||
(/ (1- yyyy) 4)) (/ (1- yyyy) 100))) 7)
|
||||
wnames)
|
||||
(nth mm mnames)
|
||||
dd HH MM SS yyyy))))
|
||||
|
||||
(defun current-time ()
|
||||
"Return the current time, as the number of seconds since 1970-01-01 00:00:00.
|
||||
The time is returned as a list of three integers. The first has the
|
||||
most significant 16 bits of the seconds, while the second has the
|
||||
least significant 16 bits. The third integer gives the microsecond
|
||||
count.
|
||||
|
||||
The microsecond count is zero on systems that do not provide
|
||||
resolution finer than a second."
|
||||
(let* ((str (current-time-string))
|
||||
(yyyy (string-to-int (substring str 20 24)))
|
||||
(mm (length (member (substring str 4 7)
|
||||
'("Dec" "Nov" "Oct" "Sep" "Aug" "Jul"
|
||||
"Jun" "May" "Apr" "Mar" "Feb" "Jan"))))
|
||||
(dd (string-to-int (substring str 8 10)))
|
||||
(HH (string-to-int (substring str 11 13)))
|
||||
(MM (string-to-int (substring str 14 16)))
|
||||
(SS (string-to-int (substring str 17 19)))
|
||||
(offset (or (car (current-time-zone)) 0))
|
||||
dn ct1 ct2 i1 i2
|
||||
year uru)
|
||||
(setq ct1 0 ct2 0 i1 0 i2 0)
|
||||
(setq year (- yyyy 1970))
|
||||
(while (> year 0)
|
||||
(setq year (1- year)
|
||||
ct1 (+ ct1 481)
|
||||
ct2 (+ ct2 13184))
|
||||
(while (> ct2 65535)
|
||||
(setq ct1 (1+ ct1)
|
||||
ct2 (- ct2 65536))))
|
||||
(setq year (- yyyy 1))
|
||||
(setq uru (- (+ (- (/ year 4) (/ year 100))
|
||||
(/ year 400)) 477))
|
||||
(while (> uru 0)
|
||||
(setq uru (1- uru)
|
||||
i1 (1+ i1)
|
||||
i2 (+ i2 20864))
|
||||
(if (> i2 65535)
|
||||
(setq i1 (1+ i1)
|
||||
i2 (- i2 65536))))
|
||||
(setq ct1 (+ ct1 i1)
|
||||
ct2 (+ ct2 i2))
|
||||
(while (> ct2 65535)
|
||||
(setq ct1 (1+ ct1)
|
||||
ct2 (- ct2 65536)))
|
||||
(setq dn (+ dd (* 31 (1- mm))))
|
||||
(if (> mm 2)
|
||||
(setq dn (+ (- dn (/ (+ 23 (* 4 mm)) 10))
|
||||
(if (and (zerop (% yyyy 4))
|
||||
(or (not (zerop (% yyyy 100)))
|
||||
(zerop (% yyyy 400))))
|
||||
1 0))))
|
||||
(setq dn (1- dn)
|
||||
i1 0
|
||||
i2 0)
|
||||
(while (> dn 0)
|
||||
(setq dn (1- dn)
|
||||
i1 (1+ i1)
|
||||
i2 (+ i2 20864))
|
||||
(if (> i2 65535)
|
||||
(setq i1 (1+ i1)
|
||||
i2 (- i2 65536))))
|
||||
(setq ct1 (+ (+ (+ ct1 i1) (/ ct2 65536))
|
||||
(/ (+ (* HH 3600) (* MM 60) SS)
|
||||
65536))
|
||||
ct2 (+ (+ i2 (% ct2 65536))
|
||||
(% (+ (* HH 3600) (* MM 60) SS)
|
||||
65536)))
|
||||
(while (< (- ct2 offset) 0)
|
||||
(setq ct1 (1- ct1)
|
||||
ct2 (+ ct2 65536)))
|
||||
(setq ct2 (- ct2 offset))
|
||||
(while (> ct2 65535)
|
||||
(setq ct1 (1+ ct1)
|
||||
ct2 (- ct2 65536)))
|
||||
(list ct1 ct2 0)))
|
||||
|
||||
;;; @@ Floating point numbers.
|
||||
;;;
|
||||
|
||||
(defun abs (arg)
|
||||
"Return the absolute value of ARG."
|
||||
(if (< arg 0) (- arg) arg))
|
||||
|
||||
;;; @ Basic lisp subroutines.
|
||||
;;;
|
||||
|
||||
(defmacro lambda (&rest cdr)
|
||||
"Return a lambda expression.
|
||||
A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
|
||||
self-quoting; the result of evaluating the lambda expression is the
|
||||
expression itself. The lambda expression may then be treated as a
|
||||
function, i.e., stored as the function value of a symbol, passed to
|
||||
funcall or mapcar, etc.
|
||||
|
||||
ARGS should take the same form as an argument list for a `defun'.
|
||||
DOCSTRING is an optional documentation string.
|
||||
If present, it should describe how to call the function.
|
||||
But documentation strings are usually not useful in nameless functions.
|
||||
INTERACTIVE should be a call to the function `interactive', which see.
|
||||
It may also be omitted.
|
||||
BODY should be a list of lisp expressions."
|
||||
;; Note that this definition should not use backquotes; subr.el should not
|
||||
;; depend on backquote.el.
|
||||
(list 'function (cons 'lambda cdr)))
|
||||
|
||||
(defun force-mode-line-update (&optional all)
|
||||
"Force the mode-line of the current buffer to be redisplayed.
|
||||
With optional non-nil ALL, force redisplay of all mode-lines."
|
||||
(if all (save-excursion (set-buffer (other-buffer))))
|
||||
(set-buffer-modified-p (buffer-modified-p)))
|
||||
|
||||
(defalias 'set-match-data 'store-match-data)
|
||||
|
||||
(defvar save-match-data-internal)
|
||||
|
||||
;; We use save-match-data-internal as the local variable because
|
||||
;; that works ok in practice (people should not use that variable elsewhere).
|
||||
(defmacro save-match-data (&rest body)
|
||||
"Execute the BODY forms, restoring the global value of the match data."
|
||||
(` (let ((save-match-data-internal (match-data)))
|
||||
(unwind-protect (progn (,@ body))
|
||||
(set-match-data save-match-data-internal)))))
|
||||
|
||||
|
||||
;;; @ Basic editing commands.
|
||||
;;;
|
||||
|
||||
;; 18.55 does not have these variables.
|
||||
(defvar-maybe buffer-undo-list nil
|
||||
"List of undo entries in current buffer.
|
||||
APEL provides this as dummy for a compatibility.")
|
||||
|
||||
(defvar-maybe auto-fill-function nil
|
||||
"Function called (if non-nil) to perform auto-fill.
|
||||
APEL provides this as dummy for a compatibility.")
|
||||
|
||||
(defvar-maybe unread-command-event nil
|
||||
"APEL provides this as dummy for a compatibility.")
|
||||
(defvar-maybe unread-command-events nil
|
||||
"List of events to be read as the command input.
|
||||
APEL provides this as dummy for a compatibility.")
|
||||
|
||||
;; (defvar-maybe minibuffer-setup-hook nil
|
||||
;; "Normal hook run just after entry to minibuffer.")
|
||||
;; (defvar-maybe minibuffer-exit-hook nil
|
||||
;; "Normal hook run just after exit from minibuffer.")
|
||||
|
||||
(defvar-maybe minor-mode-map-alist nil
|
||||
"Alist of keymaps to use for minor modes.
|
||||
APEL provides this as dummy for a compatibility.")
|
||||
|
||||
(defalias 'insert-and-inherit 'insert)
|
||||
(defalias 'insert-before-markers-and-inherit 'insert-before-markers)
|
||||
(defalias 'number-to-string 'int-to-string)
|
||||
|
||||
(defun generate-new-buffer-name (name &optional ignore)
|
||||
"Return a string that is the name of no existing buffer based on NAME.
|
||||
If there is no live buffer named NAME, then return NAME.
|
||||
Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
|
||||
until an unused name is found, and then return that name.
|
||||
Optional second argument IGNORE specifies a name that is okay to use
|
||||
\(if it is in the sequence to be tried\)
|
||||
even if a buffer with that name exists."
|
||||
(if (get-buffer name)
|
||||
(let ((n 2) new)
|
||||
(while (get-buffer (setq new (format "%s<%d>" name n)))
|
||||
(setq n (1+ n)))
|
||||
new)
|
||||
name))
|
||||
|
||||
(or (fboundp 'si:mark)
|
||||
(fset 'si:mark (symbol-function 'mark)))
|
||||
(defun mark (&optional force)
|
||||
(si:mark))
|
||||
|
||||
(defun-maybe window-minibuffer-p (&optional window)
|
||||
"Return non-nil if WINDOW is a minibuffer window."
|
||||
(eq (or window (selected-window)) (minibuffer-window)))
|
||||
|
||||
(defun-maybe window-live-p (obj)
|
||||
"Returns t if OBJECT is a window which is currently visible."
|
||||
(and (windowp obj)
|
||||
(or (eq obj (minibuffer-window))
|
||||
(eq obj (get-buffer-window (window-buffer obj))))))
|
||||
|
||||
;; Add optinal argument `hist'
|
||||
(or (fboundp 'si:read-from-minibuffer)
|
||||
(progn
|
||||
(fset 'si:read-from-minibuffer (symbol-function 'read-from-minibuffer))
|
||||
(defun read-from-minibuffer (prompt &optional
|
||||
initial-contents keymap read hist)
|
||||
|
||||
"Read a string from the minibuffer, prompting with string PROMPT.
|
||||
If optional second arg INITIAL-CONTENTS is non-nil, it is a string
|
||||
to be inserted into the minibuffer before reading input.
|
||||
If INITIAL-CONTENTS is (STRING . POSITION), the initial input
|
||||
is STRING, but point is placed at position POSITION in the minibuffer.
|
||||
Third arg KEYMAP is a keymap to use whilst reading;
|
||||
if omitted or nil, the default is `minibuffer-local-map'.
|
||||
If fourth arg READ is non-nil, then interpret the result as a lisp object
|
||||
and return that object:
|
||||
in other words, do `(car (read-from-string INPUT-STRING))'
|
||||
Fifth arg HIST is ignored in this implementation."
|
||||
(si:read-from-minibuffer prompt initial-contents keymap read))))
|
||||
|
||||
;; Add optional argument `frame'.
|
||||
(or (fboundp 'si:get-buffer-window)
|
||||
(progn
|
||||
(fset 'si:get-buffer-window (symbol-function 'get-buffer-window))
|
||||
(defun get-buffer-window (buffer &optional frame)
|
||||
"Return a window currently displaying BUFFER, or nil if none.
|
||||
Optional argument FRAME is ignored in this implementation."
|
||||
(si:get-buffer-window buffer))))
|
||||
|
||||
(defun-maybe walk-windows (proc &optional minibuf all-frames)
|
||||
"Cycle through all visible windows, calling PROC for each one.
|
||||
PROC is called with a window as argument.
|
||||
|
||||
Optional second arg MINIBUF t means count the minibuffer window even
|
||||
if not active. MINIBUF nil or omitted means count the minibuffer iff
|
||||
it is active. MINIBUF neither t nor nil means not to count the
|
||||
minibuffer even if it is active.
|
||||
Optional third argument ALL-FRAMES is ignored in this implementation."
|
||||
(if (window-minibuffer-p (selected-window))
|
||||
(setq minibuf t))
|
||||
(let* ((walk-windows-start (selected-window))
|
||||
(walk-windows-current walk-windows-start))
|
||||
(unwind-protect
|
||||
(while (progn
|
||||
(setq walk-windows-current
|
||||
(next-window walk-windows-current minibuf))
|
||||
(funcall proc walk-windows-current)
|
||||
(not (eq walk-windows-current walk-windows-start))))
|
||||
(select-window walk-windows-start))))
|
||||
|
||||
(defun buffer-disable-undo (&optional buffer)
|
||||
"Make BUFFER stop keeping undo information.
|
||||
No argument or nil as argument means do this for the current buffer."
|
||||
(buffer-flush-undo (or buffer (current-buffer))))
|
||||
|
||||
|
||||
;;; @@ Frame (Emacs 18 cannot make frame)
|
||||
;;;
|
||||
;; The following four are frequently used for manipulating the current frame.
|
||||
;; frame.el has `screen-width', `screen-height', `set-screen-width' and
|
||||
;; `set-screen-height' for backward compatibility and declare them as obsolete.
|
||||
(defun frame-width (&optional frame)
|
||||
"Return number of columns available for display on FRAME.
|
||||
If FRAME is omitted, describe the currently selected frame."
|
||||
(screen-width))
|
||||
|
||||
(defun frame-height (&optional frame)
|
||||
"Return number of lines available for display on FRAME.
|
||||
If FRAME is omitted, describe the currently selected frame."
|
||||
(screen-height))
|
||||
|
||||
(defun set-frame-width (frame cols &optional pretend)
|
||||
"Specify that the frame FRAME has COLS columns.
|
||||
Optional third arg non-nil means that redisplay should use COLS columns
|
||||
but that the idea of the actual width of the frame should not be changed."
|
||||
(set-screen-width cols pretend))
|
||||
|
||||
(defun set-frame-height (frame lines &optional pretend)
|
||||
"Specify that the frame FRAME has LINES lines.
|
||||
Optional third arg non-nil means that redisplay should use LINES lines
|
||||
but that the idea of the actual height of the frame should not be changed."
|
||||
(set-screen-height lines pretend))
|
||||
|
||||
;;; @@ Environment variables.
|
||||
;;;
|
||||
|
||||
(autoload 'setenv "env"
|
||||
"Set the value of the environment variable named VARIABLE to VALUE.
|
||||
VARIABLE should be a string. VALUE is optional; if not provided or is
|
||||
`nil', the environment variable VARIABLE will be removed.
|
||||
This function works by modifying `process-environment'."
|
||||
t)
|
||||
|
||||
|
||||
;;; @ File input and output commands.
|
||||
;;;
|
||||
|
||||
(defvar data-directory exec-directory)
|
||||
|
||||
;; In 18.55, `call-process' does not return exit status.
|
||||
(defun file-executable-p (filename)
|
||||
"Return t if FILENAME can be executed by you.
|
||||
For a directory, this means you can access files in that directory."
|
||||
(if (file-exists-p filename)
|
||||
(let ((process (start-process "test" nil "test" "-x" filename)))
|
||||
(while (eq 'run (process-status process)))
|
||||
(zerop (process-exit-status process)))))
|
||||
|
||||
(defun make-directory-internal (dirname)
|
||||
"Create a directory. One argument, a file name string."
|
||||
(let ((dir (expand-file-name dirname)))
|
||||
(if (file-exists-p dir)
|
||||
(signal 'file-already-exists
|
||||
(list "Creating directory: %s already exists" dir))
|
||||
(let ((exit-status (call-process "mkdir" nil nil nil dir)))
|
||||
(if (or (and (numberp exit-status)
|
||||
(not (zerop exit-status)))
|
||||
(stringp exit-status))
|
||||
(error "Create directory %s failed.")
|
||||
;; `make-directory' of v19 and later returns nil for success.
|
||||
)))))
|
||||
|
||||
(defun make-directory (dir &optional parents)
|
||||
"Create the directory DIR and any nonexistent parent dirs.
|
||||
The second (optional) argument PARENTS says whether
|
||||
to create parent directories if they don't exist."
|
||||
(let ((len (length dir))
|
||||
(p 0) p1 path)
|
||||
(catch 'tag
|
||||
(while (and (< p len) (string-match "[^/]*/?" dir p))
|
||||
(setq p1 (match-end 0))
|
||||
(if (= p1 len)
|
||||
(throw 'tag nil))
|
||||
(setq path (substring dir 0 p1))
|
||||
(if (not (file-directory-p path))
|
||||
(cond ((file-exists-p path)
|
||||
(error "Creating directory: %s is not directory" path))
|
||||
((null parents)
|
||||
(error "Creating directory: %s is not exist" path))
|
||||
(t
|
||||
(make-directory-internal path))))
|
||||
(setq p p1)))
|
||||
(make-directory-internal dir)))
|
||||
|
||||
(defun delete-directory (directory)
|
||||
"Delete the directory named DIRECTORY. Does not follow symlinks."
|
||||
(let ((exit-status (call-process "rmdir" nil nil nil directory)))
|
||||
(when (or (and (numberp exit-status) (not (zerop exit-status)))
|
||||
(stringp exit-status))
|
||||
(error "Delete directory %s failed."))))
|
||||
|
||||
(defun parse-colon-path (cd-path)
|
||||
"Explode a colon-separated list of paths into a string list."
|
||||
(and cd-path
|
||||
(let (cd-prefix cd-list (cd-start 0) cd-colon)
|
||||
(setq cd-path (concat cd-path path-separator))
|
||||
(while (setq cd-colon (string-match path-separator cd-path cd-start))
|
||||
(setq cd-list
|
||||
(nconc cd-list
|
||||
(list (if (= cd-start cd-colon)
|
||||
nil
|
||||
(substitute-in-file-name
|
||||
(file-name-as-directory
|
||||
(substring cd-path cd-start cd-colon)))))))
|
||||
(setq cd-start (+ cd-colon 1)))
|
||||
cd-list)))
|
||||
|
||||
(defun file-relative-name (filename &optional directory)
|
||||
"Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
|
||||
(setq filename (expand-file-name filename)
|
||||
directory (file-name-as-directory (expand-file-name
|
||||
(or directory default-directory))))
|
||||
(let ((ancestor ""))
|
||||
(while (not (string-match (concat "^" (regexp-quote directory)) filename))
|
||||
(setq directory (file-name-directory (substring directory 0 -1))
|
||||
ancestor (concat "../" ancestor)))
|
||||
(concat ancestor (substring filename (match-end 0)))))
|
||||
|
||||
(or (fboundp 'si:directory-files)
|
||||
(fset 'si:directory-files (symbol-function 'directory-files)))
|
||||
(defun directory-files (directory &optional full match nosort)
|
||||
"Return a list of names of files in DIRECTORY.
|
||||
There are three optional arguments:
|
||||
If FULL is non-nil, return absolute file names. Otherwise return names
|
||||
that are relative to the specified directory.
|
||||
If MATCH is non-nil, mention only file names that match the regexp MATCH.
|
||||
If NOSORT is dummy for compatibility."
|
||||
(si:directory-files directory full match))
|
||||
|
||||
(or (fboundp 'si:write-region)
|
||||
(fset 'si:write-region (symbol-function 'write-region)))
|
||||
(defun write-region (start end filename &optional append visit)
|
||||
"Write current region into specified file.
|
||||
When called from a program, requires three arguments:
|
||||
START, END and FILENAME. START and END are normally buffer positions
|
||||
specifying the part of the buffer to write.
|
||||
If START is nil, that means to use the entire buffer contents.
|
||||
If START is a string, then output that string to the file
|
||||
instead of any buffer contents; END is ignored.
|
||||
|
||||
Optional fourth argument APPEND if non-nil means
|
||||
append to existing file contents (if any). If it is an integer,
|
||||
seek to that offset in the file before writing.
|
||||
Optional fifth argument VISIT if t means
|
||||
set the last-save-file-modtime of buffer to this file's modtime
|
||||
and mark buffer not modified.
|
||||
If VISIT is a string, it is a second file name;
|
||||
the output goes to FILENAME, but the buffer is marked as visiting VISIT.
|
||||
VISIT is also the file name to lock and unlock for clash detection.
|
||||
If VISIT is neither t nor nil nor a string,
|
||||
that means do not display the \"Wrote file\" message."
|
||||
(cond
|
||||
((null start)
|
||||
(si:write-region (point-min) (point-max) filename append visit))
|
||||
((stringp start)
|
||||
(with-temp-buffer
|
||||
(insert start)
|
||||
(si:write-region (point-min) (point-max) filename append visit)))
|
||||
(t
|
||||
(si:write-region start end filename append visit))))
|
||||
|
||||
;;; @ Process.
|
||||
;;;
|
||||
(or (fboundp 'si:accept-process-output)
|
||||
(progn
|
||||
(fset 'si:accept-process-output (symbol-function 'accept-process-output))
|
||||
(defun accept-process-output (&optional process timeout timeout-msecs)
|
||||
"Allow any pending output from subprocesses to be read by Emacs.
|
||||
It is read into the process' buffers or given to their filter functions.
|
||||
Non-nil arg PROCESS means do not return until some output has been received
|
||||
from PROCESS. Nil arg PROCESS means do not return until some output has
|
||||
been received from any process.
|
||||
TIMEOUT and TIMEOUT-MSECS are ignored in this implementation."
|
||||
(si:accept-process-output process))))
|
||||
|
||||
;;; @ Text property.
|
||||
;;;
|
||||
|
||||
;; In Emacs 20.4, these functions are defined in src/textprop.c.
|
||||
(defun text-properties-at (position &optional object))
|
||||
(defun get-text-property (position prop &optional object))
|
||||
(defun get-char-property (position prop &optional object))
|
||||
(defun next-property-change (position &optional object limit))
|
||||
(defun next-single-property-change (position prop &optional object limit))
|
||||
(defun previous-property-change (position &optional object limit))
|
||||
(defun previous-single-property-change (position prop &optional object limit))
|
||||
(defun add-text-properties (start end properties &optional object))
|
||||
(defun put-text-property (start end property value &optional object))
|
||||
(defun set-text-properties (start end properties &optional object))
|
||||
(defun remove-text-properties (start end properties &optional object))
|
||||
(defun text-property-any (start end property value &optional object))
|
||||
(defun text-property-not-all (start end property value &optional object))
|
||||
;; the following two functions are new in v20.
|
||||
(defun next-char-property-change (position &optional object))
|
||||
(defun previous-char-property-change (position &optional object))
|
||||
;; the following two functions are obsolete.
|
||||
;; (defun erase-text-properties (start end &optional object)
|
||||
;; (defun copy-text-properties (start end src pos dest &optional prop)
|
||||
|
||||
|
||||
;;; @ Overlay.
|
||||
;;;
|
||||
|
||||
(defun overlayp (object))
|
||||
(defun make-overlay (beg end &optional buffer front-advance rear-advance))
|
||||
(defun move-overlay (overlay beg end &optional buffer))
|
||||
(defun delete-overlay (overlay))
|
||||
(defun overlay-start (overlay))
|
||||
(defun overlay-end (overlay))
|
||||
(defun overlay-buffer (overlay))
|
||||
(defun overlay-properties (overlay))
|
||||
(defun overlays-at (pos))
|
||||
(defun overlays-in (beg end))
|
||||
(defun next-overlay-change (pos))
|
||||
(defun previous-overlay-change (pos))
|
||||
(defun overlay-lists ())
|
||||
(defun overlay-recenter (pos))
|
||||
(defun overlay-get (overlay prop))
|
||||
(defun overlay-put (overlay prop value))
|
||||
|
||||
;;; @ End.
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poe-18) (require 'apel-ver))
|
||||
|
||||
;;; poe-18.el ends here
|
||||
239
apel-10.7/poe-xemacs.el
Normal file
239
apel-10.7/poe-xemacs.el
Normal file
@ -0,0 +1,239 @@
|
||||
;;; poe-xemacs.el --- poe submodule for XEmacs
|
||||
|
||||
;; Copyright (C) 1995 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, XEmacs
|
||||
|
||||
;; 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 XEmacs; see the file COPYING. If not, write to the Free
|
||||
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
|
||||
;; MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'pym)
|
||||
|
||||
|
||||
;;; @ color
|
||||
;;;
|
||||
|
||||
(defun-maybe set-cursor-color (color-name)
|
||||
"Set the text cursor color of the selected frame to COLOR.
|
||||
When called interactively, prompt for the name of the color to use."
|
||||
(interactive "sColor: ")
|
||||
(set-frame-property (selected-frame) 'cursor-color
|
||||
(if (color-instance-p color-name)
|
||||
color-name
|
||||
(make-color-instance color-name))))
|
||||
|
||||
|
||||
;;; @ face
|
||||
;;;
|
||||
|
||||
(defalias-maybe 'face-list 'list-faces)
|
||||
|
||||
(or (memq 'underline (face-list))
|
||||
(and (fboundp 'make-face)
|
||||
(make-face 'underline)))
|
||||
|
||||
(or (face-differs-from-default-p 'underline)
|
||||
(set-face-underline-p 'underline t))
|
||||
|
||||
|
||||
;;; @ overlay
|
||||
;;;
|
||||
|
||||
(condition-case nil
|
||||
(require 'overlay)
|
||||
(error
|
||||
(defalias 'make-overlay 'make-extent)
|
||||
(defalias 'overlayp 'extentp)
|
||||
(defalias 'overlay-put 'set-extent-property)
|
||||
(defalias 'overlay-buffer 'extent-buffer)
|
||||
(defun move-overlay (extent start end &optional buffer)
|
||||
(set-extent-endpoints extent start end))
|
||||
(defalias 'delete-overlay 'detach-extent)))
|
||||
|
||||
|
||||
;;; @ dired
|
||||
;;;
|
||||
|
||||
(defun-maybe dired-other-frame (dirname &optional switches)
|
||||
"\"Edit\" directory DIRNAME. Like `dired' but makes a new frame."
|
||||
(interactive (dired-read-dir-and-switches "in other frame "))
|
||||
(switch-to-buffer-other-frame (dired-noselect dirname switches)))
|
||||
|
||||
|
||||
;;; @ timer
|
||||
;;;
|
||||
|
||||
(condition-case nil
|
||||
(require 'timer-funcs)
|
||||
(error nil))
|
||||
(condition-case nil
|
||||
(require 'timer)
|
||||
(error nil))
|
||||
(or
|
||||
(or (featurep 'timer-funcs) (featurep 'timer))
|
||||
(progn
|
||||
(require 'itimer)
|
||||
(if (and (= emacs-major-version 19) (<= emacs-minor-version 14))
|
||||
(defun-maybe run-at-time (time repeat function &rest args)
|
||||
(start-itimer (make-temp-name "rat")
|
||||
`(lambda ()
|
||||
(,function ,@args))
|
||||
time repeat))
|
||||
(defun-maybe run-at-time (time repeat function &rest args)
|
||||
"Function emulating the function of the same name of Emacs.
|
||||
TIME should be nil meaning now, or a number of seconds from now.
|
||||
Return an itimer object which can be used in either `delete-itimer'
|
||||
or `cancel-timer'."
|
||||
(apply #'start-itimer "run-at-time"
|
||||
function (if time (max time 1e-9) 1e-9)
|
||||
repeat nil t args)))
|
||||
(defalias 'cancel-timer 'delete-itimer)
|
||||
(defun with-timeout-handler (tag)
|
||||
(throw tag 'timeout))
|
||||
(defmacro-maybe with-timeout (list &rest body)
|
||||
(let ((seconds (car list))
|
||||
(timeout-forms (cdr list)))
|
||||
`(let ((with-timeout-tag (cons nil nil))
|
||||
with-timeout-value with-timeout-timer)
|
||||
(if (catch with-timeout-tag
|
||||
(progn
|
||||
(setq with-timeout-timer
|
||||
(run-at-time ,seconds nil
|
||||
'with-timeout-handler
|
||||
with-timeout-tag))
|
||||
(setq with-timeout-value (progn . ,body))
|
||||
nil))
|
||||
(progn . ,timeout-forms)
|
||||
(cancel-timer with-timeout-timer)
|
||||
with-timeout-value))))))
|
||||
|
||||
(require 'broken)
|
||||
|
||||
(broken-facility run-at-time-tick-tock
|
||||
"`run-at-time' is not punctual."
|
||||
;; Note that it doesn't support XEmacsen prior to the version 19.15
|
||||
;; since `start-itimer' doesn't pass arguments to a timer function.
|
||||
(or (and (= emacs-major-version 19) (<= emacs-minor-version 14))
|
||||
(condition-case nil
|
||||
(progn
|
||||
(unless (or itimer-process itimer-timer)
|
||||
(itimer-driver-start))
|
||||
;; Check whether there is a bug to which the difference of
|
||||
;; the present time and the time when the itimer driver was
|
||||
;; woken up is subtracted from the initial itimer value.
|
||||
(let* ((inhibit-quit t)
|
||||
(ctime (current-time))
|
||||
(itimer-timer-last-wakeup
|
||||
(prog1
|
||||
ctime
|
||||
(setcar ctime (1- (car ctime)))))
|
||||
(itimer-list nil)
|
||||
(itimer (start-itimer "run-at-time" 'ignore 5)))
|
||||
(sleep-for 0.1) ;; Accept the timeout interrupt.
|
||||
(prog1
|
||||
(> (itimer-value itimer) 0)
|
||||
(delete-itimer itimer))))
|
||||
(error nil))))
|
||||
|
||||
(when-broken run-at-time-tick-tock
|
||||
(defalias 'run-at-time
|
||||
(lambda (time repeat function &rest args)
|
||||
"Function emulating the function of the same name of Emacs.
|
||||
It works correctly for TIME even if there is a bug in the XEmacs core.
|
||||
TIME should be nil meaning now, or a number of seconds from now.
|
||||
Return an itimer object which can be used in either `delete-itimer'
|
||||
or `cancel-timer'."
|
||||
(let ((itimers (list nil)))
|
||||
(setcar
|
||||
itimers
|
||||
(apply #'start-itimer "fixed-run-at-time"
|
||||
(lambda (itimers repeat function &rest args)
|
||||
(let ((itimer (car itimers)))
|
||||
(if repeat
|
||||
(progn
|
||||
(set-itimer-function
|
||||
itimer
|
||||
(lambda (itimer repeat function &rest args)
|
||||
(set-itimer-restart itimer repeat)
|
||||
(set-itimer-function itimer function)
|
||||
(set-itimer-function-arguments itimer args)
|
||||
(apply function args)))
|
||||
(set-itimer-function-arguments
|
||||
itimer
|
||||
(append (list itimer repeat function) args)))
|
||||
(set-itimer-function
|
||||
itimer
|
||||
(lambda (itimer function &rest args)
|
||||
(delete-itimer itimer)
|
||||
(apply function args)))
|
||||
(set-itimer-function-arguments
|
||||
itimer
|
||||
(append (list itimer function) args)))))
|
||||
1e-9 (if time (max time 1e-9) 1e-9)
|
||||
nil t itimers repeat function args))))))
|
||||
|
||||
|
||||
;;; @ to avoid bug of XEmacs 19.14
|
||||
;;;
|
||||
|
||||
(or (string-match "^../"
|
||||
(file-relative-name "/usr/local/share" "/usr/local/lib"))
|
||||
;; This function was imported from Emacs 19.33.
|
||||
(defun file-relative-name (filename &optional directory)
|
||||
"Convert FILENAME to be relative to DIRECTORY
|
||||
(default: default-directory)."
|
||||
(setq filename (expand-file-name filename)
|
||||
directory (file-name-as-directory
|
||||
(expand-file-name
|
||||
(or directory default-directory))))
|
||||
(let ((ancestor ""))
|
||||
(while (not (string-match (concat "^" (regexp-quote directory))
|
||||
filename))
|
||||
(setq directory (file-name-directory (substring directory 0 -1))
|
||||
ancestor (concat "../" ancestor)))
|
||||
(concat ancestor (substring filename (match-end 0))))))
|
||||
|
||||
|
||||
;;; @ Emacs 20.3 emulation
|
||||
;;;
|
||||
|
||||
(defalias-maybe 'line-beginning-position 'point-at-bol)
|
||||
(defalias-maybe 'line-end-position 'point-at-eol)
|
||||
|
||||
;;; @ XEmacs 21 emulation
|
||||
;;;
|
||||
|
||||
;; XEmacs 20.5 and later: (set-extent-properties EXTENT PLIST)
|
||||
(defun-maybe set-extent-properties (extent plist)
|
||||
"Change some properties of EXTENT.
|
||||
PLIST is a property list.
|
||||
For a list of built-in properties, see `set-extent-property'."
|
||||
(while plist
|
||||
(set-extent-property extent (car plist) (cadr plist))
|
||||
(setq plist (cddr plist))))
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poe-xemacs) (require 'apel-ver))
|
||||
|
||||
;;; poe-xemacs.el ends here
|
||||
2031
apel-10.7/poe.el
Normal file
2031
apel-10.7/poe.el
Normal file
File diff suppressed because it is too large
Load Diff
65
apel-10.7/poem-e20.el
Normal file
65
apel-10.7/poem-e20.el
Normal file
@ -0,0 +1,65 @@
|
||||
;;; poem-e20.el --- poem submodule for Emacs 20; -*-byte-compile-dynamic: t;-*-
|
||||
|
||||
;; Copyright (C) 1998 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defun fontset-pixel-size (fontset)
|
||||
(let* ((info (fontset-info fontset))
|
||||
(height (aref info 1))
|
||||
)
|
||||
(cond ((> height 0) height)
|
||||
((string-match "-\\([0-9]+\\)-" fontset)
|
||||
(string-to-number
|
||||
(substring fontset (match-beginning 1)(match-end 1))))
|
||||
(t 0))))
|
||||
|
||||
|
||||
;;; @ character set
|
||||
;;;
|
||||
|
||||
;; (defalias 'charset-columns 'charset-width)
|
||||
|
||||
(defun find-non-ascii-charset-string (string)
|
||||
"Return a list of charsets in the STRING except ascii."
|
||||
(delq 'ascii (find-charset-string string)))
|
||||
|
||||
(defun find-non-ascii-charset-region (start end)
|
||||
"Return a list of charsets except ascii
|
||||
in the region between START and END."
|
||||
(delq 'ascii (find-charset-string (buffer-substring start end))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(if (and (fboundp 'set-buffer-multibyte)
|
||||
(subrp (symbol-function 'set-buffer-multibyte)))
|
||||
(require 'poem-e20_3) ; for Emacs 20.3
|
||||
(require 'poem-e20_2) ; for Emacs 20.1 and 20.2
|
||||
)
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-e20) (require 'apel-ver))
|
||||
|
||||
;;; poem-e20.el ends here
|
||||
93
apel-10.7/poem-e20_2.el
Normal file
93
apel-10.7/poem-e20_2.el
Normal file
@ -0,0 +1,93 @@
|
||||
;;; poem-e20_2.el --- poem implementation for Emacs 20.1 and 20.2
|
||||
|
||||
;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.1 and 20.2.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ buffer representation
|
||||
;;;
|
||||
|
||||
(defun-maybe set-buffer-multibyte (flag)
|
||||
"Set the multibyte flag of the current buffer to FLAG.
|
||||
If FLAG is t, this makes the buffer a multibyte buffer.
|
||||
If FLAG is nil, this makes the buffer a single-byte buffer.
|
||||
The buffer contents remain unchanged as a sequence of bytes
|
||||
but the contents viewed as characters do change.
|
||||
\[Emacs 20.3 emulating function]"
|
||||
(setq enable-multibyte-characters flag)
|
||||
)
|
||||
|
||||
|
||||
;;; @ character
|
||||
;;;
|
||||
|
||||
(defalias 'char-length 'char-bytes)
|
||||
|
||||
(defmacro char-next-index (char index)
|
||||
"Return index of character succeeding CHAR whose index is INDEX."
|
||||
`(+ ,index (char-bytes ,char)))
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
(defalias 'sset 'store-substring)
|
||||
|
||||
(defun string-to-char-list (string)
|
||||
"Return a list of which elements are characters in the STRING."
|
||||
(let* ((len (length string))
|
||||
(i 0)
|
||||
l chr)
|
||||
(while (< i len)
|
||||
(setq chr (sref string i))
|
||||
(setq l (cons chr l))
|
||||
(setq i (+ i (char-bytes chr)))
|
||||
)
|
||||
(nreverse l)))
|
||||
|
||||
(defalias 'string-to-int-list 'string-to-char-list)
|
||||
|
||||
(defun looking-at-as-unibyte (regexp)
|
||||
"Like `looking-at', but string is regarded as unibyte sequence."
|
||||
(let (enable-multibyte-characters)
|
||||
(looking-at regexp)))
|
||||
|
||||
;;; @@ obsoleted aliases
|
||||
;;;
|
||||
;;; You should not use them.
|
||||
|
||||
(defalias 'string-columns 'string-width)
|
||||
(make-obsolete 'string-columns 'string-width)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-e20_2) (require 'apel-ver))
|
||||
|
||||
;;; poem-e20_2.el ends here
|
||||
68
apel-10.7/poem-e20_3.el
Normal file
68
apel-10.7/poem-e20_3.el
Normal file
@ -0,0 +1,68 @@
|
||||
;;; -*-byte-compile-dynamic: t;-*-
|
||||
;;; poem-e20_3.el --- poem submodule for Emacs 20.3
|
||||
|
||||
;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module requires Emacs 20.2.91 or later.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'pym)
|
||||
|
||||
;;; @ character
|
||||
;;;
|
||||
|
||||
(defsubst char-length (char)
|
||||
"Return indexing length of multi-byte form of CHAR."
|
||||
1)
|
||||
|
||||
(defmacro char-next-index (char index)
|
||||
"Return index of character succeeding CHAR whose index is INDEX."
|
||||
`(1+ ,index))
|
||||
|
||||
(defalias-maybe 'characterp 'char-valid-p)
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
(defalias 'sset 'store-substring)
|
||||
|
||||
(defun string-to-char-list (string)
|
||||
"Return a list of which elements are characters in the STRING."
|
||||
(mapcar #'identity string))
|
||||
|
||||
(defalias 'string-to-int-list 'string-to-char-list)
|
||||
|
||||
(defalias 'looking-at-as-unibyte 'looking-at)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-e20_3) (require 'apel-ver))
|
||||
|
||||
;;; poem-e20_3.el ends here
|
||||
154
apel-10.7/poem-ltn1.el
Normal file
154
apel-10.7/poem-ltn1.el
Normal file
@ -0,0 +1,154 @@
|
||||
;;; poem-ltn1.el --- poem implementation for Emacs 19 and XEmacs without MULE
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ buffer representation
|
||||
;;;
|
||||
|
||||
(eval-when-compile
|
||||
(require 'poe))
|
||||
|
||||
(defun-maybe set-buffer-multibyte (flag)
|
||||
"Set the multibyte flag of the current buffer to FLAG.
|
||||
If FLAG is t, this makes the buffer a multibyte buffer.
|
||||
If FLAG is nil, this makes the buffer a single-byte buffer.
|
||||
The buffer contents remain unchanged as a sequence of bytes
|
||||
but the contents viewed as characters do change.
|
||||
\[Emacs 20.3 emulating macro]"
|
||||
)
|
||||
|
||||
|
||||
;;; @ character set
|
||||
;;;
|
||||
|
||||
(put 'ascii 'charset-description "Character set of ASCII")
|
||||
(put 'ascii 'charset-registry "ASCII")
|
||||
|
||||
(put 'latin-iso8859-1 'charset-description "Character set of ISO-8859-1")
|
||||
(put 'latin-iso8859-1 'charset-registry "ISO8859-1")
|
||||
|
||||
(defun charset-description (charset)
|
||||
"Return description of CHARSET."
|
||||
(get charset 'charset-description))
|
||||
|
||||
(defun charset-registry (charset)
|
||||
"Return registry name of CHARSET."
|
||||
(get charset 'charset-registry))
|
||||
|
||||
(defun charset-width (charset)
|
||||
"Return number of columns a CHARSET occupies when displayed."
|
||||
1)
|
||||
|
||||
(defun charset-direction (charset)
|
||||
"Return the direction of a character of CHARSET by
|
||||
0 (left-to-right) or 1 (right-to-left)."
|
||||
0)
|
||||
|
||||
(defun find-charset-string (str)
|
||||
"Return a list of charsets in the string."
|
||||
(if (string-match "[\200-\377]" str)
|
||||
'(latin-iso8859-1)
|
||||
))
|
||||
|
||||
(defalias 'find-non-ascii-charset-string 'find-charset-string)
|
||||
|
||||
(defun find-charset-region (start end)
|
||||
"Return a list of charsets in the region between START and END."
|
||||
(if (save-excursion
|
||||
(goto-char start)
|
||||
(re-search-forward "[\200-\377]" end t))
|
||||
'(latin-iso8859-1)
|
||||
))
|
||||
|
||||
(defalias 'find-non-ascii-charset-region 'find-charset-region)
|
||||
|
||||
|
||||
;;; @ character
|
||||
;;;
|
||||
|
||||
(defun char-charset (char)
|
||||
"Return the character set of char CHAR."
|
||||
(if (< char 128)
|
||||
'ascii
|
||||
'latin-iso8859-1))
|
||||
|
||||
(defun char-bytes (char)
|
||||
"Return number of bytes a character in CHAR occupies in a buffer."
|
||||
1)
|
||||
|
||||
(defun char-width (char)
|
||||
"Return number of columns a CHAR occupies when displayed."
|
||||
1)
|
||||
|
||||
(defun split-char (character)
|
||||
"Return list of charset and one or two position-codes of CHARACTER."
|
||||
(cons (char-charset character) character))
|
||||
|
||||
(defalias 'char-length 'char-bytes)
|
||||
|
||||
(defmacro char-next-index (char index)
|
||||
"Return index of character succeeding CHAR whose index is INDEX."
|
||||
(` (1+ (, index))))
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
(defalias 'string-width 'length)
|
||||
|
||||
(defun string-to-char-list (str)
|
||||
(mapcar (function identity) str))
|
||||
|
||||
(defalias 'string-to-int-list 'string-to-char-list)
|
||||
|
||||
(defalias 'sref 'aref)
|
||||
|
||||
(defun truncate-string (str width &optional start-column)
|
||||
"Truncate STR to fit in WIDTH columns.
|
||||
Optional non-nil arg START-COLUMN specifies the starting column.
|
||||
\[emu-latin1.el; MULE 2.3 emulating function]"
|
||||
(or start-column
|
||||
(setq start-column 0))
|
||||
(if (> (length str) width)
|
||||
(substring str start-column width)
|
||||
str))
|
||||
|
||||
(defalias 'looking-at-as-unibyte 'looking-at)
|
||||
|
||||
;;; @@ obsoleted aliases
|
||||
;;;
|
||||
;;; You should not use them.
|
||||
|
||||
(defalias 'string-columns 'length)
|
||||
(make-obsolete 'string-columns 'string-width)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-ltn1) (require 'apel-ver))
|
||||
|
||||
;;; poem-ltn1.el ends here
|
||||
219
apel-10.7/poem-nemacs.el
Normal file
219
apel-10.7/poem-nemacs.el
Normal file
@ -0,0 +1,219 @@
|
||||
;;; poem-nemacs.el --- poem implementation for Nemacs
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; @ character set
|
||||
;;;
|
||||
|
||||
(put 'ascii
|
||||
'charset-description "Character set of ASCII")
|
||||
(put 'ascii
|
||||
'charset-registry "ASCII")
|
||||
|
||||
(put 'japanese-jisx0208
|
||||
'charset-description "Character set of JIS X0208-1983")
|
||||
(put 'japanese-jisx0208
|
||||
'charset-registry "JISX0208.1983")
|
||||
|
||||
(defun charset-description (charset)
|
||||
"Return description of CHARSET. [emu-nemacs.el]"
|
||||
(get charset 'charset-description))
|
||||
|
||||
(defun charset-registry (charset)
|
||||
"Return registry name of CHARSET. [emu-nemacs.el]"
|
||||
(get charset 'charset-registry))
|
||||
|
||||
(defun charset-width (charset)
|
||||
"Return number of columns a CHARSET occupies when displayed.
|
||||
\[emu-nemacs.el]"
|
||||
(if (eq charset 'ascii)
|
||||
1
|
||||
2))
|
||||
|
||||
(defun charset-direction (charset)
|
||||
"Return the direction of a character of CHARSET by
|
||||
0 (left-to-right) or 1 (right-to-left). [emu-nemacs.el]"
|
||||
0)
|
||||
|
||||
(defun find-charset-string (str)
|
||||
"Return a list of charsets in the string.
|
||||
\[emu-nemacs.el; Mule emulating function]"
|
||||
(if (string-match "[\200-\377]" str)
|
||||
'(japanese-jisx0208)
|
||||
))
|
||||
|
||||
(defalias 'find-non-ascii-charset-string 'find-charset-string)
|
||||
|
||||
(defun find-charset-region (start end)
|
||||
"Return a list of charsets in the region between START and END.
|
||||
\[emu-nemacs.el; Mule emulating function]"
|
||||
(if (save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char start)
|
||||
(re-search-forward "[\200-\377]" nil t)))
|
||||
'(japanese-jisx0208)
|
||||
))
|
||||
|
||||
(defalias 'find-non-ascii-charset-region 'find-charset-region)
|
||||
|
||||
(defun check-ASCII-string (str)
|
||||
(let ((i 0)
|
||||
len)
|
||||
(setq len (length str))
|
||||
(catch 'label
|
||||
(while (< i len)
|
||||
(if (>= (elt str i) 128)
|
||||
(throw 'label nil))
|
||||
(setq i (+ i 1)))
|
||||
str)))
|
||||
|
||||
;;; @@ for old MULE emulation
|
||||
;;;
|
||||
|
||||
;;(defconst lc-ascii 0)
|
||||
;;(defconst lc-jp 146)
|
||||
|
||||
|
||||
;;; @ buffer representation
|
||||
;;;
|
||||
|
||||
(defsubst-maybe set-buffer-multibyte (flag)
|
||||
"Set the multibyte flag of the current buffer to FLAG.
|
||||
If FLAG is t, this makes the buffer a multibyte buffer.
|
||||
If FLAG is nil, this makes the buffer a single-byte buffer.
|
||||
The buffer contents remain unchanged as a sequence of bytes
|
||||
but the contents viewed as characters do change.
|
||||
\[Emacs 20.3 emulating function]"
|
||||
(setq kanji-flag flag)
|
||||
)
|
||||
|
||||
|
||||
;;; @ character
|
||||
;;;
|
||||
|
||||
(defun char-charset (chr)
|
||||
"Return the character set of char CHR.
|
||||
\[emu-nemacs.el; MULE emulating function]"
|
||||
(if (< chr 128)
|
||||
'ascii
|
||||
'japanese-jisx0208))
|
||||
|
||||
(defun char-bytes (chr)
|
||||
"Return number of bytes CHAR will occupy in a buffer.
|
||||
\[emu-nemacs.el; Mule emulating function]"
|
||||
(if (< chr 128)
|
||||
1
|
||||
2))
|
||||
|
||||
(defun char-width (char)
|
||||
"Return number of columns a CHAR occupies when displayed.
|
||||
\[emu-nemacs.el]"
|
||||
(if (< char 128)
|
||||
1
|
||||
2))
|
||||
|
||||
(defalias 'char-length 'char-bytes)
|
||||
|
||||
(defmacro char-next-index (char index)
|
||||
"Return index of character succeeding CHAR whose index is INDEX.
|
||||
\[emu-nemacs.el]"
|
||||
(` (+ (, index) (char-bytes (, char)))))
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
(defalias 'string-width 'length)
|
||||
|
||||
(defun sref (str idx)
|
||||
"Return the character in STR at index IDX.
|
||||
\[emu-nemacs.el; Mule emulating function]"
|
||||
(let ((chr (aref str idx)))
|
||||
(if (< chr 128)
|
||||
chr
|
||||
(logior (lsh (aref str (1+ idx)) 8) chr))))
|
||||
|
||||
(defun string-to-char-list (str)
|
||||
(let ((i 0)(len (length str)) dest chr)
|
||||
(while (< i len)
|
||||
(setq chr (aref str i))
|
||||
(if (>= chr 128)
|
||||
(setq i (1+ i)
|
||||
chr (+ (lsh chr 8) (aref str i)))
|
||||
)
|
||||
(setq dest (cons chr dest))
|
||||
(setq i (1+ i)))
|
||||
(reverse dest)))
|
||||
|
||||
(fset 'string-to-int-list (symbol-function 'string-to-char-list))
|
||||
|
||||
;;; Imported from Mule-2.3
|
||||
(defun truncate-string (str width &optional start-column)
|
||||
"Truncate STR to fit in WIDTH columns.
|
||||
Optional non-nil arg START-COLUMN specifies the starting column.
|
||||
\[emu-mule.el; Mule 2.3 emulating function]"
|
||||
(or start-column
|
||||
(setq start-column 0))
|
||||
(let ((max-width (string-width str))
|
||||
(len (length str))
|
||||
(from 0)
|
||||
(column 0)
|
||||
to-prev to ch)
|
||||
(if (>= width max-width)
|
||||
(setq width max-width))
|
||||
(if (>= start-column width)
|
||||
""
|
||||
(while (< column start-column)
|
||||
(setq ch (aref str from)
|
||||
column (+ column (char-width ch))
|
||||
from (+ from (char-bytes ch))))
|
||||
(if (< width max-width)
|
||||
(progn
|
||||
(setq to from)
|
||||
(while (<= column width)
|
||||
(setq ch (aref str to)
|
||||
column (+ column (char-width ch))
|
||||
to-prev to
|
||||
to (+ to (char-bytes ch))))
|
||||
(setq to to-prev)))
|
||||
(substring str from to))))
|
||||
|
||||
(defalias 'looking-at-as-unibyte 'looking-at)
|
||||
|
||||
;;; @@ obsoleted aliases
|
||||
;;;
|
||||
;;; You should not use them.
|
||||
|
||||
(defalias 'string-columns 'length)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-nemacs) (require 'apel-ver))
|
||||
|
||||
;;; poem-nemacs.el ends here
|
||||
164
apel-10.7/poem-om.el
Normal file
164
apel-10.7/poem-om.el
Normal file
@ -0,0 +1,164 @@
|
||||
;;; poem-om.el --- poem implementation for Mule 1.* and Mule 2.*
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
|
||||
;;; @ version specific features
|
||||
;;;
|
||||
|
||||
(if (= emacs-major-version 19)
|
||||
;; Suggested by SASAKI Osamu <osamu@shuugr.bekkoame.or.jp>
|
||||
;; (cf. [os2-emacs-ja:78])
|
||||
(defun fontset-pixel-size (fontset)
|
||||
(let* ((font (get-font-info
|
||||
(aref (cdr (get-fontset-info fontset)) 0)))
|
||||
(open (aref font 4)))
|
||||
(if (= open 1)
|
||||
(aref font 5)
|
||||
(if (= open 0)
|
||||
(let ((pat (aref font 1)))
|
||||
(if (string-match "-[0-9]+-" pat)
|
||||
(string-to-number
|
||||
(substring
|
||||
pat (1+ (match-beginning 0)) (1- (match-end 0))))
|
||||
0))
|
||||
))))
|
||||
)
|
||||
|
||||
|
||||
;;; @ character set
|
||||
;;;
|
||||
|
||||
(defalias 'make-char 'make-character)
|
||||
|
||||
(defalias 'find-non-ascii-charset-string 'find-charset-string)
|
||||
(defalias 'find-non-ascii-charset-region 'find-charset-region)
|
||||
|
||||
(defalias 'charset-bytes 'char-bytes)
|
||||
(defalias 'charset-description 'char-description)
|
||||
(defalias 'charset-registry 'char-registry)
|
||||
(defalias 'charset-columns 'char-width)
|
||||
(defalias 'charset-direction 'char-direction)
|
||||
|
||||
(defun charset-chars (charset)
|
||||
"Return the number of characters per dimension of CHARSET."
|
||||
(if (= (logand (nth 2 (character-set charset)) 1) 1)
|
||||
96
|
||||
94))
|
||||
|
||||
|
||||
;;; @ buffer representation
|
||||
;;;
|
||||
|
||||
(defsubst-maybe set-buffer-multibyte (flag)
|
||||
"Set the multibyte flag of the current buffer to FLAG.
|
||||
If FLAG is t, this makes the buffer a multibyte buffer.
|
||||
If FLAG is nil, this makes the buffer a single-byte buffer.
|
||||
The buffer contents remain unchanged as a sequence of bytes
|
||||
but the contents viewed as characters do change.
|
||||
\[Emacs 20.3 emulating function]"
|
||||
(setq mc-flag flag)
|
||||
)
|
||||
|
||||
|
||||
;;; @ character
|
||||
;;;
|
||||
|
||||
(defalias 'char-charset 'char-leading-char)
|
||||
|
||||
(defun split-char (character)
|
||||
"Return list of charset and one or two position-codes of CHARACTER."
|
||||
(let ((p (1- (char-bytes character)))
|
||||
dest)
|
||||
(while (>= p 1)
|
||||
(setq dest (cons (- (char-component character p) 128) dest)
|
||||
p (1- p)))
|
||||
(cons (char-charset character) dest)))
|
||||
|
||||
(defmacro char-next-index (char index)
|
||||
"Return index of character succeeding CHAR whose index is INDEX."
|
||||
(` (+ (, index) (char-bytes (, char)))))
|
||||
|
||||
|
||||
;;; @@ obsoleted aliases
|
||||
;;;
|
||||
;;; You should not use them.
|
||||
|
||||
(defalias 'char-length 'char-bytes)
|
||||
;;(defalias 'char-columns 'char-width)
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
(defalias 'string-columns 'string-width)
|
||||
|
||||
(defalias 'string-to-int-list 'string-to-char-list)
|
||||
|
||||
;; Imported from Mule-2.3
|
||||
(defun-maybe truncate-string (str width &optional start-column)
|
||||
"\
|
||||
Truncate STR to fit in WIDTH columns.
|
||||
Optional non-nil arg START-COLUMN specifies the starting column.
|
||||
\[emu-mule.el; Mule 2.3 emulating function]"
|
||||
(or start-column
|
||||
(setq start-column 0))
|
||||
(let ((max-width (string-width str))
|
||||
(len (length str))
|
||||
(from 0)
|
||||
(column 0)
|
||||
to-prev to ch)
|
||||
(if (>= width max-width)
|
||||
(setq width max-width))
|
||||
(if (>= start-column width)
|
||||
""
|
||||
(while (< column start-column)
|
||||
(setq ch (aref str from)
|
||||
column (+ column (char-width ch))
|
||||
from (+ from (char-bytes ch))))
|
||||
(if (< width max-width)
|
||||
(progn
|
||||
(setq to from)
|
||||
(while (<= column width)
|
||||
(setq ch (aref str to)
|
||||
column (+ column (char-width ch))
|
||||
to-prev to
|
||||
to (+ to (char-bytes ch))))
|
||||
(setq to to-prev)))
|
||||
(substring str from to))))
|
||||
|
||||
(defalias 'looking-at-as-unibyte 'looking-at)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-om) (require 'apel-ver))
|
||||
|
||||
;;; poem-om.el ends here
|
||||
99
apel-10.7/poem-xm.el
Normal file
99
apel-10.7/poem-xm.el
Normal file
@ -0,0 +1,99 @@
|
||||
;;; poem-xm.el --- poem module for XEmacs-mule; -*-byte-compile-dynamic: t;-*-
|
||||
|
||||
;; Copyright (C) 1998,1999,2002,2003,2005 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile
|
||||
(require 'poe))
|
||||
|
||||
|
||||
;;; @ buffer representation
|
||||
;;;
|
||||
|
||||
(defsubst-maybe set-buffer-multibyte (flag)
|
||||
"Set the multibyte flag of the current buffer to FLAG.
|
||||
If FLAG is t, this makes the buffer a multibyte buffer.
|
||||
If FLAG is nil, this makes the buffer a single-byte buffer.
|
||||
The buffer contents remain unchanged as a sequence of bytes
|
||||
but the contents viewed as characters do change.
|
||||
\[Emacs 20.3 emulating function]"
|
||||
flag)
|
||||
|
||||
|
||||
;;; @ character
|
||||
;;;
|
||||
|
||||
;; avoid bug of XEmacs
|
||||
(or (integerp (car (cdr (split-char ?a))))
|
||||
(defun split-char (char)
|
||||
"Return list of charset and one or two position-codes of CHAR."
|
||||
(let ((charset (char-charset char)))
|
||||
(if (eq charset 'ascii)
|
||||
(list charset (char-int char))
|
||||
(let ((i 0)
|
||||
(len (charset-dimension charset))
|
||||
(code (if (integerp char)
|
||||
char
|
||||
(char-int char)))
|
||||
dest)
|
||||
(while (< i len)
|
||||
(setq dest (cons (logand code 127) dest)
|
||||
code (lsh code -7)
|
||||
i (1+ i)))
|
||||
(cons charset dest)))))
|
||||
)
|
||||
|
||||
(defmacro char-next-index (char index)
|
||||
"Return index of character succeeding CHAR whose index is INDEX."
|
||||
`(1+ ,index))
|
||||
|
||||
(if (not (fboundp 'char-length))
|
||||
(defalias 'char-length
|
||||
(lambda (char)
|
||||
"Return number of bytes a CHARACTER occupies in a string or buffer.
|
||||
It always returns 1 in XEmacs. It is for compatibility with MULE 2.3."
|
||||
1)))
|
||||
|
||||
(defalias-maybe 'char-valid-p 'characterp)
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
(defun-maybe string-to-int-list (str)
|
||||
(mapcar #'char-int str))
|
||||
|
||||
(defun-maybe string-to-char-list (str)
|
||||
(mapcar #'identity str))
|
||||
|
||||
(defalias 'looking-at-as-unibyte 'looking-at)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem-xm) (require 'apel-ver))
|
||||
|
||||
;;; poem-xm.el ends here
|
||||
106
apel-10.7/poem.el
Normal file
106
apel-10.7/poem.el
Normal file
@ -0,0 +1,106 @@
|
||||
;;; poem.el --- Emulate latest MULE features; -*-byte-compile-dynamic: t;-*-
|
||||
|
||||
;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;; Keywords: emulation, compatibility, Mule
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'pces)
|
||||
|
||||
(cond ((featurep 'mule)
|
||||
(cond ((featurep 'xemacs)
|
||||
(require 'poem-xm)
|
||||
)
|
||||
((>= emacs-major-version 20)
|
||||
(require 'poem-e20)
|
||||
)
|
||||
(t
|
||||
;; for MULE 1.* and 2.*
|
||||
(require 'poem-om)
|
||||
))
|
||||
)
|
||||
((boundp 'NEMACS)
|
||||
;; for Nemacs and Nepoch
|
||||
(require 'poem-nemacs)
|
||||
)
|
||||
(t
|
||||
(require 'poem-ltn1)
|
||||
))
|
||||
|
||||
|
||||
;;; @ Emacs 20.3 emulation
|
||||
;;;
|
||||
|
||||
(defsubst-maybe string-as-unibyte (string)
|
||||
"Return a unibyte string with the same individual bytes as STRING.
|
||||
If STRING is unibyte, the result is STRING itself.
|
||||
\[Emacs 20.3 emulating macro]"
|
||||
string)
|
||||
|
||||
(defsubst-maybe string-as-multibyte (string)
|
||||
"Return a multibyte string with the same individual bytes as STRING.
|
||||
If STRING is multibyte, the result is STRING itself.
|
||||
\[Emacs 20.3 emulating macro]"
|
||||
string)
|
||||
|
||||
(defun-maybe charset-after (&optional pos)
|
||||
"Return charset of a character in current buffer at position POS.
|
||||
If POS is nil, it defaults to the current point.
|
||||
If POS is out of range, the value is nil.
|
||||
\[Emacs 20.3 emulating function]"
|
||||
(char-charset (char-after pos))
|
||||
)
|
||||
|
||||
;;; @ XEmacs-mule emulation
|
||||
;;;
|
||||
|
||||
(defalias-maybe 'char-int 'identity)
|
||||
|
||||
(defalias-maybe 'int-char 'identity)
|
||||
|
||||
(defalias-maybe 'characterp
|
||||
(cond
|
||||
((fboundp 'char-valid-p) 'char-valid-p)
|
||||
(t 'integerp)))
|
||||
|
||||
(defalias-maybe 'char-or-char-int-p
|
||||
(cond
|
||||
((fboundp 'char-valid-p) 'char-valid-p)
|
||||
(t 'integerp)))
|
||||
|
||||
(defun-maybe char-octet (ch &optional n)
|
||||
"Return the octet numbered N (should be 0 or 1) of char CH.
|
||||
N defaults to 0 if omitted. [XEmacs-mule emulating function]"
|
||||
(or (nth (if n
|
||||
(1+ n)
|
||||
1)
|
||||
(split-char ch))
|
||||
0))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'poem) (require 'apel-ver))
|
||||
|
||||
;;; poem.el ends here
|
||||
428
apel-10.7/product.el
Normal file
428
apel-10.7/product.el
Normal file
@ -0,0 +1,428 @@
|
||||
;;; product.el --- Functions for product version information.
|
||||
|
||||
;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keiichi Suzuki <keiichi@nanap.org>
|
||||
;; Keywords: compatibility, User-Agent
|
||||
|
||||
;; 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 this program; see the file COPYING. If not, write to
|
||||
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module defines some utility functions for product information,
|
||||
;; used for User-Agent header field.
|
||||
;;
|
||||
;; User-Agent header field first appeared in HTTP [RFC 1945, RFC 2616]
|
||||
;; and adopted to News Article Format draft [USEFOR].
|
||||
;;
|
||||
;; [RFC 1945] Hypertext Transfer Protocol -- HTTP/1.0.
|
||||
;; T. Berners-Lee, R. Fielding & H. Frystyk. May 1996.
|
||||
;;
|
||||
;; [RFC 2616] Hypertext Transfer Protocol -- HTTP/1.1.
|
||||
;; R. Fielding, J. Gettys, J. Mogul, H. Frystyk, L. Masinter, P. Leach,
|
||||
;; T. Berners-Lee. June 1999.
|
||||
;;
|
||||
;; [USEFOR] News Article Format, <draft-ietf-usefor-article-02.txt>.
|
||||
;; USEFOR Working Group. March 1999.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar product-obarray (make-vector 13 0))
|
||||
|
||||
(defvar product-ignore-checkers nil)
|
||||
|
||||
(defun product-define (name &optional family version code-name)
|
||||
"Define a product as a set of NAME, FAMILY, VERSION, and CODE-NAME.
|
||||
NAME is a string. Optional 2nd argument FAMILY is a string of
|
||||
family product name. Optional 3rd argument VERSION is a list of
|
||||
numbers. Optional 4th argument CODE-NAME is a string."
|
||||
(and family
|
||||
(product-add-to-family family name))
|
||||
(set (intern name product-obarray)
|
||||
(vector name family version code-name nil nil nil nil)))
|
||||
|
||||
(defun product-name (product)
|
||||
"Return the name of PRODUCT, a string."
|
||||
(aref product 0))
|
||||
(defun product-family (product)
|
||||
"Return the family name of PRODUCT, a string."
|
||||
(aref product 1))
|
||||
(defun product-version (product)
|
||||
"Return the version of PRODUCT, a list of numbers."
|
||||
(aref product 2))
|
||||
(defun product-code-name (product)
|
||||
"Return the code-name of PRODUCT, a string."
|
||||
(aref product 3))
|
||||
(defun product-checkers (product)
|
||||
"Return the checkers of PRODUCT, a list of functions."
|
||||
(aref product 4))
|
||||
(defun product-family-products (product)
|
||||
"Return the family products of PRODUCT, a list of strings."
|
||||
(aref product 5))
|
||||
(defun product-features (product)
|
||||
"Return the features of PRODUCT, a list of feature."
|
||||
(aref product 6))
|
||||
(defun product-version-string (product)
|
||||
"Return the version string of PRODUCT, a string."
|
||||
(aref product 7))
|
||||
|
||||
(defun product-set-name (product name)
|
||||
"Set name of PRODUCT to NAME."
|
||||
(aset product 0 name))
|
||||
(defun product-set-family (product family)
|
||||
"Set family name of PRODUCT to FAMILY."
|
||||
(aset product 1 family))
|
||||
(defun product-set-version (product version)
|
||||
"Set version of PRODUCT to VERSION."
|
||||
(aset product 2 version))
|
||||
;; Some people want to translate code-name.
|
||||
(defun product-set-code-name (product code-name)
|
||||
"Set code-name of PRODUCT to CODE-NAME."
|
||||
(aset product 3 code-name))
|
||||
(defun product-set-checkers (product checkers)
|
||||
"Set checker functions of PRODUCT to CHECKERS."
|
||||
(aset product 4 checkers))
|
||||
(defun product-set-family-products (product products)
|
||||
"Set family products of PRODUCT to PRODUCTS."
|
||||
(aset product 5 products))
|
||||
(defun product-set-features (product features)
|
||||
"Set features of PRODUCT to FEATURES."
|
||||
(aset product 6 features))
|
||||
(defun product-set-version-string (product version-string)
|
||||
"Set version string of PRODUCT to VERSION-STRING."
|
||||
(aset product 7 version-string))
|
||||
|
||||
(defun product-add-to-family (family product-name)
|
||||
"Add a product to a family.
|
||||
FAMILY is a product structure which returned by `product-define'.
|
||||
PRODUCT-NAME is a string of the product's name ."
|
||||
(let ((family-product (product-find-by-name family)))
|
||||
(if family-product
|
||||
(let ((dest (product-family-products family-product)))
|
||||
(or (member product-name dest)
|
||||
(product-set-family-products
|
||||
family-product (cons product-name dest))))
|
||||
(error "Family product `%s' is not defined" family))))
|
||||
|
||||
(defun product-remove-from-family (family product-name)
|
||||
"Remove a product from a family.
|
||||
FAMILY is a product string which returned by `product-define'.
|
||||
PRODUCT-NAME is a string of the product's name."
|
||||
(let ((family-product (product-find-by-name family)))
|
||||
(if family-product
|
||||
(product-set-family-products
|
||||
family-product
|
||||
(delete product-name (product-family-products family-product)))
|
||||
(error "Family product `%s' is not defined" family))))
|
||||
|
||||
(defun product-add-checkers (product &rest checkers)
|
||||
"Add checker function(s) to a product.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
The rest arguments CHECKERS should be functions. These functions
|
||||
are registered to the product's checkers list, and will be called by
|
||||
`product-run-checkers'.
|
||||
If a checker is `ignore' will be ignored all checkers after this."
|
||||
(setq product (product-find product))
|
||||
(or product-ignore-checkers
|
||||
(let ((dest (product-checkers product))
|
||||
checker)
|
||||
(while checkers
|
||||
(setq checker (car checkers)
|
||||
checkers (cdr checkers))
|
||||
(or (memq checker dest)
|
||||
(setq dest (cons checker dest))))
|
||||
(product-set-checkers product dest))))
|
||||
|
||||
(defun product-remove-checkers (product &rest checkers)
|
||||
"Remove checker function(s) from a product.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
The rest arguments CHECKERS should be functions. These functions removed
|
||||
from the product's checkers list."
|
||||
(setq product (product-find product))
|
||||
(let ((dest (product-checkers product)))
|
||||
(while checkers
|
||||
(setq checkers (cdr checkers)
|
||||
dest (delq (car checkers) dest)))
|
||||
(product-set-checkers product dest)))
|
||||
|
||||
(defun product-add-feature (product feature)
|
||||
"Add a feature to the features list of a product.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
FEATURE is a feature in the PRODUCT's."
|
||||
(setq product (product-find product))
|
||||
(let ((dest (product-features product)))
|
||||
(or (memq feature dest)
|
||||
(product-set-features product (cons feature dest)))))
|
||||
|
||||
(defun product-remove-feature (product feature)
|
||||
"Remove a feature from the features list of a product.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
FEATURE is a feature which registered in the products list of PRODUCT."
|
||||
(setq product (product-find product))
|
||||
(product-set-features product
|
||||
(delq feature (product-features product))))
|
||||
|
||||
(defun product-run-checkers (product version &optional force)
|
||||
"Run checker functions of product.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
VERSION is target version.
|
||||
If optional 3rd argument FORCE is non-nil then do not ignore
|
||||
all checkers."
|
||||
(let ((checkers (product-checkers product)))
|
||||
(if (or force
|
||||
(not (memq 'ignore checkers)))
|
||||
(let ((version (or version
|
||||
(product-version product))))
|
||||
(while checkers
|
||||
(funcall (car checkers) version version)
|
||||
(setq checkers (cdr checkers)))))))
|
||||
|
||||
(defun product-find-by-name (name)
|
||||
"Find product by name and return a product structure.
|
||||
NAME is a string of the product's name."
|
||||
(symbol-value (intern-soft name product-obarray)))
|
||||
|
||||
(defun product-find-by-feature (feature)
|
||||
"Get a product structure of a feature's product.
|
||||
FEATURE is a symbol of the feature."
|
||||
(get feature 'product))
|
||||
|
||||
(defun product-find (product)
|
||||
"Find product information.
|
||||
If PRODUCT is a product structure, then return PRODUCT itself.
|
||||
If PRODUCT is a string, then find product by name and return a
|
||||
product structure. If PRODUCT is symbol of feature, then return
|
||||
the feature's product."
|
||||
(cond
|
||||
((and (symbolp product)
|
||||
(featurep product))
|
||||
(product-find-by-feature product))
|
||||
((stringp product)
|
||||
(product-find-by-name product))
|
||||
((vectorp product)
|
||||
product)
|
||||
(t
|
||||
(error "Invalid product %s" product))))
|
||||
|
||||
(put 'product-provide 'lisp-indent-function 1)
|
||||
(defmacro product-provide (feature-def product-def)
|
||||
"Declare a feature as a part of product.
|
||||
FEATURE-DEF is a definition of the feature.
|
||||
PRODUCT-DEF is a definition of the product."
|
||||
(let* ((feature feature-def)
|
||||
(product (product-find (eval product-def)))
|
||||
(product-name (product-name product))
|
||||
(product-family (product-family product))
|
||||
(product-version (product-version product))
|
||||
(product-code-name (product-code-name product))
|
||||
(product-version-string (product-version-string product)))
|
||||
(` (progn
|
||||
(, product-def)
|
||||
(put (, feature) 'product
|
||||
(let ((product (product-find-by-name (, product-name))))
|
||||
(product-run-checkers product '(, product-version))
|
||||
(and (, product-family)
|
||||
(product-add-to-family (, product-family)
|
||||
(, product-name)))
|
||||
(product-add-feature product (, feature))
|
||||
(if (equal '(, product-version) (product-version product))
|
||||
product
|
||||
(vector (, product-name) (, product-family)
|
||||
'(, product-version) (, product-code-name)
|
||||
nil nil nil (, product-version-string)))))
|
||||
(, feature-def)))))
|
||||
|
||||
(defun product-version-as-string (product)
|
||||
"Return version number of product as a string.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
If optional argument UPDATE is non-nil, then regenerate
|
||||
`product-version-string' from `product-version'."
|
||||
(setq product (product-find product))
|
||||
(or (product-version-string product)
|
||||
(and (product-version product)
|
||||
(product-set-version-string product
|
||||
(mapconcat (function int-to-string)
|
||||
(product-version product)
|
||||
".")))))
|
||||
|
||||
(defun product-string-1 (product &optional verbose)
|
||||
"Return information of product as a string of \"NAME/VERSION\".
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
If optional argument VERBOSE is non-nil, then return string of
|
||||
\"NAME/VERSION (CODE-NAME)\"."
|
||||
(setq product (product-find product))
|
||||
(concat (product-name product)
|
||||
(let ((version-string (product-version-as-string product)))
|
||||
(and version-string
|
||||
(concat "/" version-string)))
|
||||
(and verbose (product-code-name product)
|
||||
(concat " (" (product-code-name product) ")"))))
|
||||
|
||||
(defun product-for-each (product all function &rest args)
|
||||
"Apply a function to a product and the product's family with args.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
If ALL is nil, apply function to only products which provided feature.
|
||||
FUNCTION is a function. The function called with following arguments.
|
||||
The 1st argument is a product structure. The rest arguments are ARGS."
|
||||
(setq product (product-find product))
|
||||
(let ((family (product-family-products product)))
|
||||
(and (or all (product-features product))
|
||||
(apply function product args))
|
||||
(while family
|
||||
(apply 'product-for-each (car family) all function args)
|
||||
(setq family (cdr family)))))
|
||||
|
||||
(defun product-string (product)
|
||||
"Return information of product as a string of \"NAME/VERSION\".
|
||||
PRODUCT is a product structure which returned by `product-define'."
|
||||
(let (dest)
|
||||
(product-for-each product nil
|
||||
(function
|
||||
(lambda (product)
|
||||
(let ((str (product-string-1 product nil)))
|
||||
(if str
|
||||
(setq dest (if dest
|
||||
(concat dest " " str)
|
||||
str)))))))
|
||||
dest))
|
||||
|
||||
(defun product-string-verbose (product)
|
||||
"Return information of product as a string of \"NAME/VERSION (CODE-NAME)\".
|
||||
PRODUCT is a product structure which returned by `product-define'."
|
||||
(let (dest)
|
||||
(product-for-each product nil
|
||||
(function
|
||||
(lambda (product)
|
||||
(let ((str (product-string-1 product t)))
|
||||
(if str
|
||||
(setq dest (if dest
|
||||
(concat dest " " str)
|
||||
str)))))))
|
||||
dest))
|
||||
|
||||
(defun product-version-compare (v1 v2)
|
||||
"Compare two versions.
|
||||
Return an integer greater than, equal to, or less than 0,
|
||||
according as the version V1 is greater than, equal to, or less
|
||||
than the version V2.
|
||||
Both V1 and V2 are a list of integer(s) respectively."
|
||||
(while (and v1 v2 (= (car v1) (car v2)))
|
||||
(setq v1 (cdr v1)
|
||||
v2 (cdr v2)))
|
||||
(if v1 (if v2 (- (car v1) (car v2)) 1) (if v2 -1 0)))
|
||||
|
||||
(defun product-version>= (product require-version)
|
||||
"Compare product version with required version.
|
||||
PRODUCT is a product structure which returned by `product-define'.
|
||||
REQUIRE-VERSION is a list of integer."
|
||||
(>= (product-version-compare (product-version (product-find product))
|
||||
require-version)
|
||||
0))
|
||||
|
||||
(defun product-list-products ()
|
||||
"List all products information."
|
||||
(let (dest)
|
||||
(mapatoms
|
||||
(function
|
||||
(lambda (sym)
|
||||
(setq dest (cons (symbol-value sym) dest))))
|
||||
product-obarray)
|
||||
dest))
|
||||
|
||||
(defun product-parse-version-string (verstr)
|
||||
"Parse version string \".*v1.v2... (CODE-NAME)\".
|
||||
Return list of version, code-name, and version-string.
|
||||
VERSTR is a string."
|
||||
(let (version version-string code-name)
|
||||
(and (string-match "\\(\\([0-9.]+\\)[^ ]*\\)[^(]*\\((\\(.+\\))\\)?" verstr)
|
||||
(let ((temp (substring verstr (match-beginning 2) (match-end 2))))
|
||||
(setq version-string (substring verstr
|
||||
(match-beginning 1)
|
||||
(match-end 1))
|
||||
code-name (and (match-beginning 4)
|
||||
(substring verstr
|
||||
(match-beginning 4)
|
||||
(match-end 4))))
|
||||
(while (string-match "^\\([0-9]+\\)\\.?" temp)
|
||||
(setq version (cons (string-to-number
|
||||
(substring temp
|
||||
(match-beginning 1)
|
||||
(match-end 1)))
|
||||
version)
|
||||
temp (substring temp (match-end 0))))))
|
||||
(list (nreverse version) code-name version-string)))
|
||||
|
||||
|
||||
;;; @ End.
|
||||
;;;
|
||||
|
||||
(provide 'product) ; beware of circular dependency.
|
||||
(require 'apel-ver) ; these two files depend on each other.
|
||||
(product-provide 'product 'apel-ver)
|
||||
|
||||
|
||||
;;; @ Define emacs versions.
|
||||
;;;
|
||||
|
||||
(require 'pym)
|
||||
|
||||
(defconst-maybe emacs-major-version
|
||||
(progn (string-match "^[0-9]+" emacs-version)
|
||||
(string-to-int (substring emacs-version
|
||||
(match-beginning 0)(match-end 0))))
|
||||
"Major version number of this version of Emacs.")
|
||||
(defconst-maybe emacs-minor-version
|
||||
(progn (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
|
||||
(string-to-int (substring emacs-version
|
||||
(match-beginning 1)(match-end 1))))
|
||||
"Minor version number of this version of Emacs.")
|
||||
|
||||
;;(or (product-find "emacs")
|
||||
;; (progn
|
||||
;; (product-define "emacs")
|
||||
;; (cond
|
||||
;; ((featurep 'meadow)
|
||||
;; (let* ((info (product-parse-version-string (Meadow-version)))
|
||||
;; (version (nth 0 info))
|
||||
;; (code-name (nth 1 info))
|
||||
;; (version-string (nth 2 info)))
|
||||
;; (product-set-version-string
|
||||
;; (product-define "Meadow" "emacs" version code-name)
|
||||
;; version-string)
|
||||
;; (product-provide 'Meadow "Meadow"))
|
||||
;; (and (featurep 'mule)
|
||||
;; (let* ((info (product-parse-version-string mule-version))
|
||||
;; (version (nth 0 info))
|
||||
;; (code-name (nth 1 info))
|
||||
;; (version-string (nth 2 info)))
|
||||
;; (product-set-version-string
|
||||
;; (product-define "MULE" "Meadow" version code-name)
|
||||
;; version-string)
|
||||
;; (product-provide 'mule "MULE")))
|
||||
;; (let* ((info (product-parse-version-string emacs-version))
|
||||
;; (version (nth 0 info))
|
||||
;; (code-name (nth 1 info))
|
||||
;; (version-string (nth 2 info)))
|
||||
;; (product-set-version-string
|
||||
;; (product-define "Emacs" "Meadow" version code-name)
|
||||
;; version-string)
|
||||
;; (product-provide 'emacs "Emacs")))
|
||||
;; )))
|
||||
|
||||
;;; product.el ends here
|
||||
296
apel-10.7/pym.el
Normal file
296
apel-10.7/pym.el
Normal file
@ -0,0 +1,296 @@
|
||||
;;; pym.el --- Macros for Your Poe.
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: byte-compile, evaluation, edebug, internal
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module provides `def*-maybe' macros for conditional definition.
|
||||
;;
|
||||
;; Many APEL modules use these macros to provide the emulating version
|
||||
;; of the Emacs builtins (both C primitives and lisp subroutines) for
|
||||
;; backward compatibility. While compilation time, if `def*-maybe'
|
||||
;; find that functions/variables being defined is already provided by
|
||||
;; Emacs used for compilation, it does not leave the definitions in
|
||||
;; compiled code and resulting .elc files will be highly specialized
|
||||
;; for your environment. Lisp programmers should be aware that these
|
||||
;; macros will never provide functions or variables at run-time if they
|
||||
;; are defined for some reason (or by accident) at compilation time.
|
||||
|
||||
;; For `find-function' lovers, the following definitions may work with
|
||||
;; `def*-maybe'.
|
||||
;;
|
||||
;; (setq find-function-regexp
|
||||
;; "^\\s-*(def[^cgvW]\\(\\w\\|-\\)+\\*?\\s-+'?%s\\(\\s-\\|$\\)")
|
||||
;; (setq find-variable-regexp
|
||||
;; "^\\s-*(def[^umaW]\\(\\w\\|-\\)+\\*?\\s-+%s\\(\\s-\\|$\\)")
|
||||
;;
|
||||
;; I'm too lazy to write better regexps, sorry. -- shuhei
|
||||
|
||||
;;; Code:
|
||||
|
||||
;; for `load-history'.
|
||||
(or (boundp 'current-load-list) (setq current-load-list nil))
|
||||
|
||||
(require 'static)
|
||||
|
||||
|
||||
;;; Conditional define.
|
||||
|
||||
(put 'defun-maybe 'lisp-indent-function 'defun)
|
||||
(defmacro defun-maybe (name &rest everything-else)
|
||||
"Define NAME as a function if NAME is not defined.
|
||||
See also the function `defun'."
|
||||
(or (and (fboundp name)
|
||||
(not (get name 'defun-maybe)))
|
||||
(` (or (fboundp (quote (, name)))
|
||||
(prog1
|
||||
(defun (, name) (,@ everything-else))
|
||||
;; This `defun' will be compiled to `fset',
|
||||
;; which does not update `load-history'.
|
||||
;; We must update `current-load-list' explicitly.
|
||||
(setq current-load-list
|
||||
(cons (quote (, name)) current-load-list))
|
||||
(put (quote (, name)) 'defun-maybe t))))))
|
||||
|
||||
(put 'defmacro-maybe 'lisp-indent-function 'defun)
|
||||
(defmacro defmacro-maybe (name &rest everything-else)
|
||||
"Define NAME as a macro if NAME is not defined.
|
||||
See also the function `defmacro'."
|
||||
(or (and (fboundp name)
|
||||
(not (get name 'defmacro-maybe)))
|
||||
(` (or (fboundp (quote (, name)))
|
||||
(prog1
|
||||
(defmacro (, name) (,@ everything-else))
|
||||
;; This `defmacro' will be compiled to `fset',
|
||||
;; which does not update `load-history'.
|
||||
;; We must update `current-load-list' explicitly.
|
||||
(setq current-load-list
|
||||
(cons (quote (, name)) current-load-list))
|
||||
(put (quote (, name)) 'defmacro-maybe t))))))
|
||||
|
||||
(put 'defsubst-maybe 'lisp-indent-function 'defun)
|
||||
(defmacro defsubst-maybe (name &rest everything-else)
|
||||
"Define NAME as an inline function if NAME is not defined.
|
||||
See also the macro `defsubst'."
|
||||
(or (and (fboundp name)
|
||||
(not (get name 'defsubst-maybe)))
|
||||
(` (or (fboundp (quote (, name)))
|
||||
(prog1
|
||||
(defsubst (, name) (,@ everything-else))
|
||||
;; This `defsubst' will be compiled to `fset',
|
||||
;; which does not update `load-history'.
|
||||
;; We must update `current-load-list' explicitly.
|
||||
(setq current-load-list
|
||||
(cons (quote (, name)) current-load-list))
|
||||
(put (quote (, name)) 'defsubst-maybe t))))))
|
||||
|
||||
(defmacro defalias-maybe (symbol definition)
|
||||
"Define SYMBOL as an alias for DEFINITION if SYMBOL is not defined.
|
||||
See also the function `defalias'."
|
||||
(setq symbol (eval symbol))
|
||||
(or (and (fboundp symbol)
|
||||
(not (get symbol 'defalias-maybe)))
|
||||
(` (or (fboundp (quote (, symbol)))
|
||||
(prog1
|
||||
(defalias (quote (, symbol)) (, definition))
|
||||
;; `defalias' updates `load-history' internally.
|
||||
(put (quote (, symbol)) 'defalias-maybe t))))))
|
||||
|
||||
(defmacro defvar-maybe (name &rest everything-else)
|
||||
"Define NAME as a variable if NAME is not defined.
|
||||
See also the function `defvar'."
|
||||
(or (and (boundp name)
|
||||
(not (get name 'defvar-maybe)))
|
||||
(` (or (boundp (quote (, name)))
|
||||
(prog1
|
||||
(defvar (, name) (,@ everything-else))
|
||||
;; byte-compiler will generate code to update
|
||||
;; `load-history'.
|
||||
(put (quote (, name)) 'defvar-maybe t))))))
|
||||
|
||||
(defmacro defconst-maybe (name &rest everything-else)
|
||||
"Define NAME as a constant variable if NAME is not defined.
|
||||
See also the function `defconst'."
|
||||
(or (and (boundp name)
|
||||
(not (get name 'defconst-maybe)))
|
||||
(` (or (boundp (quote (, name)))
|
||||
(prog1
|
||||
(defconst (, name) (,@ everything-else))
|
||||
;; byte-compiler will generate code to update
|
||||
;; `load-history'.
|
||||
(put (quote (, name)) 'defconst-maybe t))))))
|
||||
|
||||
(defmacro defun-maybe-cond (name args &optional doc &rest clauses)
|
||||
"Define NAME as a function if NAME is not defined.
|
||||
CLAUSES are like those of `cond' expression, but each condition is evaluated
|
||||
at compile-time and, if the value is non-nil, the body of the clause is used
|
||||
for function definition of NAME.
|
||||
See also the function `defun'."
|
||||
(or (stringp doc)
|
||||
(setq clauses (cons doc clauses)
|
||||
doc nil))
|
||||
(or (and (fboundp name)
|
||||
(not (get name 'defun-maybe)))
|
||||
(` (or (fboundp (quote (, name)))
|
||||
(prog1
|
||||
(static-cond
|
||||
(,@ (mapcar
|
||||
(function
|
||||
(lambda (case)
|
||||
(list (car case)
|
||||
(if doc
|
||||
(` (defun (, name) (, args)
|
||||
(, doc)
|
||||
(,@ (cdr case))))
|
||||
(` (defun (, name) (, args)
|
||||
(,@ (cdr case))))))))
|
||||
clauses)))
|
||||
;; This `defun' will be compiled to `fset',
|
||||
;; which does not update `load-history'.
|
||||
;; We must update `current-load-list' explicitly.
|
||||
(setq current-load-list
|
||||
(cons (quote (, name)) current-load-list))
|
||||
(put (quote (, name)) 'defun-maybe t))))))
|
||||
|
||||
(defmacro defmacro-maybe-cond (name args &optional doc &rest clauses)
|
||||
"Define NAME as a macro if NAME is not defined.
|
||||
CLAUSES are like those of `cond' expression, but each condition is evaluated
|
||||
at compile-time and, if the value is non-nil, the body of the clause is used
|
||||
for macro definition of NAME.
|
||||
See also the function `defmacro'."
|
||||
(or (stringp doc)
|
||||
(setq clauses (cons doc clauses)
|
||||
doc nil))
|
||||
(or (and (fboundp name)
|
||||
(not (get name 'defmacro-maybe)))
|
||||
(` (or (fboundp (quote (, name)))
|
||||
(prog1
|
||||
(static-cond
|
||||
(,@ (mapcar
|
||||
(function
|
||||
(lambda (case)
|
||||
(list (car case)
|
||||
(if doc
|
||||
(` (defmacro (, name) (, args)
|
||||
(, doc)
|
||||
(,@ (cdr case))))
|
||||
(` (defmacro (, name) (, args)
|
||||
(,@ (cdr case))))))))
|
||||
clauses)))
|
||||
;; This `defmacro' will be compiled to `fset',
|
||||
;; which does not update `load-history'.
|
||||
;; We must update `current-load-list' explicitly.
|
||||
(setq current-load-list
|
||||
(cons (quote (, name)) current-load-list))
|
||||
(put (quote (, name)) 'defmacro-maybe t))))))
|
||||
|
||||
(defmacro defsubst-maybe-cond (name args &optional doc &rest clauses)
|
||||
"Define NAME as an inline function if NAME is not defined.
|
||||
CLAUSES are like those of `cond' expression, but each condition is evaluated
|
||||
at compile-time and, if the value is non-nil, the body of the clause is used
|
||||
for function definition of NAME.
|
||||
See also the macro `defsubst'."
|
||||
(or (stringp doc)
|
||||
(setq clauses (cons doc clauses)
|
||||
doc nil))
|
||||
(or (and (fboundp name)
|
||||
(not (get name 'defsubst-maybe)))
|
||||
(` (or (fboundp (quote (, name)))
|
||||
(prog1
|
||||
(static-cond
|
||||
(,@ (mapcar
|
||||
(function
|
||||
(lambda (case)
|
||||
(list (car case)
|
||||
(if doc
|
||||
(` (defsubst (, name) (, args)
|
||||
(, doc)
|
||||
(,@ (cdr case))))
|
||||
(` (defsubst (, name) (, args)
|
||||
(,@ (cdr case))))))))
|
||||
clauses)))
|
||||
;; This `defsubst' will be compiled to `fset',
|
||||
;; which does not update `load-history'.
|
||||
;; We must update `current-load-list' explicitly.
|
||||
(setq current-load-list
|
||||
(cons (quote (, name)) current-load-list))
|
||||
(put (quote (, name)) 'defsubst-maybe t))))))
|
||||
|
||||
|
||||
;;; Edebug spec.
|
||||
|
||||
;; `def-edebug-spec' is an autoloaded macro in v19 and later.
|
||||
;; (Note that recent XEmacs provides "edebug" as a separate package.)
|
||||
(defmacro-maybe def-edebug-spec (symbol spec)
|
||||
"Set the edebug-form-spec property of SYMBOL according to SPEC.
|
||||
Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol
|
||||
\(naming a function\), or a list."
|
||||
(` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec)))))
|
||||
|
||||
;; edebug-spec for `def*-maybe' macros.
|
||||
(def-edebug-spec defun-maybe defun)
|
||||
(def-edebug-spec defmacro-maybe defmacro)
|
||||
(def-edebug-spec defsubst-maybe defun)
|
||||
(def-edebug-spec defun-maybe-cond
|
||||
(&define name lambda-list
|
||||
[&optional stringp]
|
||||
[&rest ([¬ eval] [&rest sexp])]
|
||||
[&optional (eval [&optional ("interactive" interactive)] def-body)]
|
||||
&rest (&rest sexp)))
|
||||
(def-edebug-spec defmacro-maybe-cond
|
||||
(&define name lambda-list
|
||||
[&rest ([¬ eval] [&rest sexp])]
|
||||
[&optional (eval def-body)]
|
||||
&rest (&rest sexp)))
|
||||
(def-edebug-spec defsubst-maybe-cond
|
||||
(&define name lambda-list
|
||||
[&optional stringp]
|
||||
[&rest ([¬ eval] [&rest sexp])]
|
||||
[&optional (eval [&optional ("interactive" interactive)] def-body)]
|
||||
&rest (&rest sexp)))
|
||||
|
||||
;; edebug-spec for `static-*' macros are also defined here.
|
||||
(def-edebug-spec static-if t)
|
||||
(def-edebug-spec static-when when)
|
||||
(def-edebug-spec static-unless unless)
|
||||
(def-edebug-spec static-condition-case condition-case)
|
||||
(def-edebug-spec static-defconst defconst)
|
||||
(def-edebug-spec static-cond cond)
|
||||
|
||||
|
||||
;;; for backward compatibility.
|
||||
|
||||
(defun subr-fboundp (symbol)
|
||||
"Return t if SYMBOL's function definition is a built-in function."
|
||||
(and (fboundp symbol)
|
||||
(subrp (symbol-function symbol))))
|
||||
;; (make-obsolete 'subr-fboundp "don't use it.")
|
||||
|
||||
|
||||
;;; End.
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'pym) (require 'apel-ver))
|
||||
|
||||
;;; pym.el ends here
|
||||
185
apel-10.7/richtext.el
Normal file
185
apel-10.7/richtext.el
Normal file
@ -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 <morioka@jaist.ac.jp>
|
||||
;; Created: 1995/7/15
|
||||
;; Version: $Id: richtext.el,v 3.6 1997/06/28 17:58:34 morioka 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, 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
|
||||
89
apel-10.7/static.el
Normal file
89
apel-10.7/static.el
Normal file
@ -0,0 +1,89 @@
|
||||
;;; static.el --- tools for static evaluation.
|
||||
|
||||
;; Copyright (C) 1999 Tanaka Akira <akr@jaist.ac.jp>
|
||||
|
||||
;; Author: Tanaka Akira <akr@jaist.ac.jp>
|
||||
;; Keywords: byte compile, evaluation
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(put 'static-if 'lisp-indent-function 2)
|
||||
(defmacro static-if (cond then &rest else)
|
||||
"Like `if', but evaluate COND at compile time."
|
||||
(if (eval cond)
|
||||
then
|
||||
(` (progn (,@ else)))))
|
||||
|
||||
(put 'static-when 'lisp-indent-function 1)
|
||||
(defmacro static-when (cond &rest body)
|
||||
"Like `when', but evaluate COND at compile time."
|
||||
(if (eval cond)
|
||||
(` (progn (,@ body)))))
|
||||
|
||||
(put 'static-unless 'lisp-indent-function 1)
|
||||
(defmacro static-unless (cond &rest body)
|
||||
"Like `unless', but evaluate COND at compile time."
|
||||
(if (eval cond)
|
||||
nil
|
||||
(` (progn (,@ body)))))
|
||||
|
||||
(put 'static-condition-case 'lisp-indent-function 2)
|
||||
(defmacro static-condition-case (var bodyform &rest handlers)
|
||||
"Like `condition-case', but evaluate BODYFORM at compile time."
|
||||
(eval (` (condition-case (, var)
|
||||
(list (quote quote) (, bodyform))
|
||||
(,@ (mapcar
|
||||
(if var
|
||||
(function
|
||||
(lambda (h)
|
||||
(` ((, (car h))
|
||||
(list (quote funcall)
|
||||
(function (lambda ((, var)) (,@ (cdr h))))
|
||||
(list (quote quote) (, var)))))))
|
||||
(function
|
||||
(lambda (h)
|
||||
(` ((, (car h)) (quote (progn (,@ (cdr h)))))))))
|
||||
handlers))))))
|
||||
|
||||
(put 'static-defconst 'lisp-indent-function 'defun)
|
||||
(defmacro static-defconst (symbol initvalue &optional docstring)
|
||||
"Like `defconst', but evaluate INITVALUE at compile time.
|
||||
|
||||
The variable SYMBOL can be referred at both compile time and run time."
|
||||
(let ((value (eval initvalue)))
|
||||
(eval (` (defconst (, symbol) (quote (, value)) (, docstring))))
|
||||
(` (defconst (, symbol) (quote (, value)) (, docstring)))))
|
||||
|
||||
(defmacro static-cond (&rest clauses)
|
||||
"Like `cond', but evaluate CONDITION part of each clause at compile time."
|
||||
(while (and clauses
|
||||
(not (eval (car (car clauses)))))
|
||||
(setq clauses (cdr clauses)))
|
||||
(if clauses
|
||||
(cons 'progn (cdr (car clauses)))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'static) (require 'apel-ver))
|
||||
|
||||
;;; static.el ends here
|
||||
516
apel-10.7/timezone.el
Normal file
516
apel-10.7/timezone.el
Normal file
@ -0,0 +1,516 @@
|
||||
;;; timezone.el --- time zone package for GNU Emacs
|
||||
|
||||
;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Masanobu Umeda
|
||||
;; Maintainer: umerin@mse.kyutech.ac.jp
|
||||
;; Keywords: news
|
||||
|
||||
;; This file 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 file 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, 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Modified 1 February 1994 by Kyle Jones to fix broken
|
||||
;; timezone-floor function.
|
||||
|
||||
;; Modified 25 January 1994 by Kyle Jones so that it will
|
||||
;; work under version 18 of Emacs. Provided timezone-floor
|
||||
;; and timezone-abs functions.
|
||||
|
||||
;; Modified 4 October 1999 by Yuuichi Teranishi so that it will
|
||||
;; work with old GNUS 3.14.4 under version 18 of Emacs.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar timezone-world-timezones
|
||||
'(("PST" . -800)
|
||||
("PDT" . -700)
|
||||
("MST" . -700)
|
||||
("MDT" . -600)
|
||||
("CST" . -600)
|
||||
("CDT" . -500)
|
||||
("EST" . -500)
|
||||
("EDT" . -400)
|
||||
("AST" . -400) ;by <clamen@CS.CMU.EDU>
|
||||
("NST" . -330) ;by <clamen@CS.CMU.EDU>
|
||||
("UT" . +000)
|
||||
("GMT" . +000)
|
||||
("BST" . +100)
|
||||
("MET" . +100)
|
||||
("EET" . +200)
|
||||
("JST" . +900)
|
||||
("GMT+1" . +100) ("GMT+2" . +200) ("GMT+3" . +300)
|
||||
("GMT+4" . +400) ("GMT+5" . +500) ("GMT+6" . +600)
|
||||
("GMT+7" . +700) ("GMT+8" . +800) ("GMT+9" . +900)
|
||||
("GMT+10" . +1000) ("GMT+11" . +1100) ("GMT+12" . +1200) ("GMT+13" . +1300)
|
||||
("GMT-1" . -100) ("GMT-2" . -200) ("GMT-3" . -300)
|
||||
("GMT-4" . -400) ("GMT-5" . -500) ("GMT-6" . -600)
|
||||
("GMT-7" . -700) ("GMT-8" . -800) ("GMT-9" . -900)
|
||||
("GMT-10" . -1000) ("GMT-11" . -1100) ("GMT-12" . -1200))
|
||||
"*Time differentials of timezone from GMT in +-HHMM form.
|
||||
This list is obsolescent, and is present only for backwards compatibility,
|
||||
because time zone names are ambiguous in practice.
|
||||
Use `current-time-zone' instead.")
|
||||
|
||||
(defvar timezone-months-assoc
|
||||
'(("JAN" . 1)("FEB" . 2)("MAR" . 3)
|
||||
("APR" . 4)("MAY" . 5)("JUN" . 6)
|
||||
("JUL" . 7)("AUG" . 8)("SEP" . 9)
|
||||
("OCT" . 10)("NOV" . 11)("DEC" . 12))
|
||||
"Alist of first three letters of a month and its numerical representation.")
|
||||
|
||||
(defun timezone-make-date-arpa-standard (date &optional local timezone)
|
||||
"Convert DATE to an arpanet standard date.
|
||||
Optional 2nd argument LOCAL specifies the default local timezone of the DATE;
|
||||
if nil, GMT is assumed.
|
||||
Optional 3rd argument TIMEZONE specifies a time zone to be represented in;
|
||||
if nil, the local time zone is assumed."
|
||||
(let ((new (timezone-fix-time date local timezone)))
|
||||
(timezone-make-arpa-date (aref new 0) (aref new 1) (aref new 2)
|
||||
(timezone-make-time-string
|
||||
(aref new 3) (aref new 4) (aref new 5))
|
||||
(aref new 6))
|
||||
))
|
||||
|
||||
(defun timezone-make-date-sortable (date &optional local timezone)
|
||||
"Convert DATE to a sortable date string.
|
||||
Optional 2nd argument LOCAL specifies the default local timezone of the DATE;
|
||||
if nil, GMT is assumed.
|
||||
Optional 3rd argument TIMEZONE specifies a timezone to be represented in;
|
||||
if nil, the local time zone is assumed."
|
||||
(let ((new (timezone-fix-time date local timezone)))
|
||||
(timezone-make-sortable-date (aref new 0) (aref new 1) (aref new 2)
|
||||
(timezone-make-time-string
|
||||
(aref new 3) (aref new 4) (aref new 5)))
|
||||
))
|
||||
|
||||
|
||||
;;
|
||||
;; Parsers and Constructors of Date and Time
|
||||
;;
|
||||
|
||||
(defun timezone-make-arpa-date (year month day time &optional timezone)
|
||||
"Make arpanet standard date string from YEAR, MONTH, DAY, and TIME.
|
||||
Optional argument TIMEZONE specifies a time zone."
|
||||
(let ((zone
|
||||
(if (listp timezone)
|
||||
(let* ((m (timezone-zone-to-minute timezone))
|
||||
(absm (if (< m 0) (- m) m)))
|
||||
(format "%c%02d%02d"
|
||||
(if (< m 0) ?- ?+) (/ absm 60) (% absm 60)))
|
||||
timezone)))
|
||||
(format "%02d %s %04d %s %s"
|
||||
day
|
||||
(capitalize (car (rassq month timezone-months-assoc)))
|
||||
year
|
||||
time
|
||||
zone)))
|
||||
|
||||
(defun timezone-make-sortable-date (year month day time)
|
||||
"Make sortable date string from YEAR, MONTH, DAY, and TIME."
|
||||
(format "%4d%02d%02d%s"
|
||||
year month day time))
|
||||
|
||||
(defun timezone-make-time-string (hour minute second)
|
||||
"Make time string from HOUR, MINUTE, and SECOND."
|
||||
(format "%02d:%02d:%02d" hour minute second))
|
||||
|
||||
(defun timezone-parse-date (date)
|
||||
"Parse DATE and return a vector [YEAR MONTH DAY TIME TIMEZONE].
|
||||
19 is prepended to year if necessary. Timezone may be nil if nothing.
|
||||
Understands the following styles:
|
||||
(1) 14 Apr 89 03:20[:12] [GMT]
|
||||
(2) Fri, 17 Mar 89 4:01[:33] [GMT]
|
||||
(3) Mon Jan 16 16:12[:37] [GMT] 1989
|
||||
(4) 6 May 1992 1641-JST (Wednesday)
|
||||
(5) 22-AUG-1993 10:59:12.82
|
||||
(6) Thu, 11 Apr 16:17:12 91 [MET]
|
||||
(7) Mon, 6 Jul 16:47:20 T 1992 [MET]
|
||||
(8) 1996-06-24 21:13:12 [GMT]
|
||||
(9) 1996-06-24 21:13-ZONE"
|
||||
;; Get rid of any text properties.
|
||||
(and (stringp date)
|
||||
(or (text-properties-at 0 date)
|
||||
(next-property-change 0 date))
|
||||
(setq date (copy-sequence date))
|
||||
(set-text-properties 0 (length date) nil date))
|
||||
(let ((date (or date ""))
|
||||
(year nil)
|
||||
(month nil)
|
||||
(day nil)
|
||||
(time nil)
|
||||
(zone nil)) ;This may be nil.
|
||||
(cond ((string-match
|
||||
"\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
|
||||
;; Styles: (1) and (2) with timezone and buggy timezone
|
||||
;; This is most common in mail and news,
|
||||
;; so it is worth trying first.
|
||||
(setq year 3 month 2 day 1 time 4 zone 5))
|
||||
((string-match
|
||||
"\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\'" date)
|
||||
;; Styles: (1) and (2) without timezone
|
||||
(setq year 3 month 2 day 1 time 4 zone nil))
|
||||
((string-match
|
||||
"\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\'" date)
|
||||
;; Styles: (6) and (7) without timezone
|
||||
(setq year 6 month 3 day 2 time 4 zone nil))
|
||||
((string-match
|
||||
"\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
|
||||
;; Styles: (6) and (7) with timezone and buggy timezone
|
||||
(setq year 6 month 3 day 2 time 4 zone 7))
|
||||
((string-match
|
||||
"\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([0-9]+\\)" date)
|
||||
;; Styles: (3) without timezone
|
||||
(setq year 4 month 1 day 2 time 3 zone nil))
|
||||
((string-match
|
||||
"\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([-+a-zA-Z0-9]+\\)[ \t]+\\([0-9]+\\)" date)
|
||||
;; Styles: (3) with timezone
|
||||
(setq year 5 month 1 day 2 time 3 zone 4))
|
||||
((string-match
|
||||
"\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
|
||||
;; Styles: (4) with timezone
|
||||
(setq year 3 month 2 day 1 time 4 zone 5))
|
||||
((string-match
|
||||
"\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)?[ \t]+\\([-+a-zA-Z0-9]+\\)" date)
|
||||
;; Styles: (5) with timezone.
|
||||
(setq year 3 month 2 day 1 time 4 zone 6))
|
||||
((string-match
|
||||
"\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\(\\.[0-9]+\\)?" date)
|
||||
;; Styles: (5) without timezone.
|
||||
(setq year 3 month 2 day 1 time 4 zone nil))
|
||||
((string-match
|
||||
"\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
|
||||
;; Styles: (8) with timezone.
|
||||
(setq year 1 month 2 day 3 time 4 zone 5))
|
||||
((string-match
|
||||
"\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+\\)[ \t]*\\([-+a-zA-Z0-9:]+\\)" date)
|
||||
;; Styles: (8) with timezone with a colon in it.
|
||||
(setq year 1 month 2 day 3 time 4 zone 5))
|
||||
((string-match
|
||||
"\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)" date)
|
||||
;; Styles: (8) without timezone.
|
||||
(setq year 1 month 2 day 3 time 4 zone nil))
|
||||
)
|
||||
(when year
|
||||
(setq year (match-string year date))
|
||||
;; Guess ambiguous years. Assume years < 69 don't predate the
|
||||
;; Unix Epoch, so are 2000+. Three-digit years are assumed to
|
||||
;; be relative to 1900.
|
||||
(if (< (length year) 4)
|
||||
(let ((y (string-to-int year)))
|
||||
(if (< y 69)
|
||||
(setq y (+ y 100)))
|
||||
(setq year (int-to-string (+ 1900 y)))))
|
||||
(setq month
|
||||
(if (= (aref date (+ (match-beginning month) 2)) ?-)
|
||||
;; Handle numeric months, spanning exactly two digits.
|
||||
(substring date
|
||||
(match-beginning month)
|
||||
(+ (match-beginning month) 2))
|
||||
(let* ((string (substring date
|
||||
(match-beginning month)
|
||||
(+ (match-beginning month) 3)))
|
||||
(monthnum
|
||||
(cdr (assoc (upcase string) timezone-months-assoc))))
|
||||
(if monthnum
|
||||
(int-to-string monthnum)))))
|
||||
(setq day (match-string day date))
|
||||
(setq time (match-string time date)))
|
||||
(if zone (setq zone (match-string zone date)))
|
||||
;; Return a vector.
|
||||
(if (and year month)
|
||||
(vector year month day time zone)
|
||||
(vector "0" "0" "0" "0" nil))))
|
||||
|
||||
(defun timezone-parse-time (time)
|
||||
"Parse TIME (HH:MM:SS) and return a vector [hour minute second].
|
||||
Recognize HH:MM:SS, HH:MM, HHMMSS, HHMM."
|
||||
(let ((time (or time ""))
|
||||
(hour nil)
|
||||
(minute nil)
|
||||
(second nil))
|
||||
(cond ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)\\'" time)
|
||||
;; HH:MM:SS
|
||||
(setq hour 1 minute 2 second 3))
|
||||
((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\'" time)
|
||||
;; HH:MM
|
||||
(setq hour 1 minute 2 second nil))
|
||||
((string-match "\\`\\([0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)\\'" time)
|
||||
;; HHMMSS
|
||||
(setq hour 1 minute 2 second 3))
|
||||
((string-match "\\`\\([0-9][0-9]\\)\\([0-9][0-9]\\)\\'" time)
|
||||
;; HHMM
|
||||
(setq hour 1 minute 2 second nil))
|
||||
)
|
||||
;; Return [hour minute second]
|
||||
(vector
|
||||
(if hour
|
||||
(substring time (match-beginning hour) (match-end hour)) "0")
|
||||
(if minute
|
||||
(substring time (match-beginning minute) (match-end minute)) "0")
|
||||
(if second
|
||||
(substring time (match-beginning second) (match-end second)) "0"))
|
||||
))
|
||||
|
||||
|
||||
;; Miscellaneous
|
||||
|
||||
(defun timezone-zone-to-minute (timezone)
|
||||
"Translate TIMEZONE to an integer minute offset from GMT.
|
||||
TIMEZONE can be a cons cell containing the output of `current-time-zone',
|
||||
or an integer of the form +-HHMM, or a time zone name."
|
||||
(cond
|
||||
((consp timezone)
|
||||
(/ (car timezone) 60))
|
||||
(timezone
|
||||
(progn
|
||||
(setq timezone
|
||||
(or (and (stringp timezone) (cdr (assoc (upcase timezone) timezone-world-timezones)))
|
||||
;; +900
|
||||
timezone))
|
||||
(if (stringp timezone)
|
||||
(setq timezone (string-to-int timezone)))
|
||||
;; Taking account of minute in timezone.
|
||||
;; HHMM -> MM
|
||||
(let* ((abszone (abs timezone))
|
||||
(minutes (+ (* 60 (/ abszone 100)) (% abszone 100))))
|
||||
(if (< timezone 0) (- minutes) minutes))))
|
||||
(t 0)))
|
||||
|
||||
(defun timezone-floor (arg &optional divisor)
|
||||
"Return the largest integer no grater than ARG.
|
||||
With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR."
|
||||
(if (null divisor)
|
||||
(setq divisor 1))
|
||||
(if (< arg 0)
|
||||
(- (/ (- divisor 1 arg) divisor))
|
||||
(/ arg divisor)))
|
||||
|
||||
(defun timezone-time-from-absolute (date seconds)
|
||||
"Compute the UTC time equivalent to DATE at time SECONDS after midnight.
|
||||
Return a list suitable as an argument to `current-time-zone',
|
||||
or nil if the date cannot be thus represented.
|
||||
DATE is the number of days elapsed since the (imaginary)
|
||||
Gregorian date Sunday, December 31, 1 BC."
|
||||
(let* ((current-time-origin 719163)
|
||||
;; (timezone-absolute-from-gregorian 1 1 1970)
|
||||
(days (- date current-time-origin))
|
||||
(days-1 (/ days 65536))
|
||||
(days-2 (% (/ days 256) 256))
|
||||
(days-3 (% days 256))
|
||||
;; (seconds-per-day (float 86400))
|
||||
(seconds-per-day-1 1)
|
||||
(seconds-per-day-2 81)
|
||||
(seconds-per-day-3 128)
|
||||
;; (seconds (+ seconds (* days seconds-per-day)))
|
||||
;; (current-time-arithmetic-base (float 65536))
|
||||
;; (hi (timezone-floor (/ seconds current-time-arithmetic-base)))
|
||||
;; (hibase (* hi current-time-arithmetic-base))
|
||||
;; (lo (timezone-floor (- seconds hibase)))
|
||||
(seconds-1 (/ seconds 65536))
|
||||
(seconds-2 (% (/ seconds 256) 256))
|
||||
(seconds-3 (% seconds 256))
|
||||
hi lo
|
||||
r
|
||||
seconds-per-day*days-1
|
||||
seconds-per-day*days-2
|
||||
seconds-per-day*days-3)
|
||||
(setq r (* days-3 seconds-per-day-3)
|
||||
seconds-per-day*days-3 (% r 256))
|
||||
(setq r (+ (/ r 256)
|
||||
(* days-2 seconds-per-day-3)
|
||||
(* days-3 seconds-per-day-2))
|
||||
seconds-per-day*days-2 (% r 256))
|
||||
(setq seconds-per-day*days-1 (+ (/ r 256)
|
||||
(* days-1 seconds-per-day-3)
|
||||
(* (/ days 256) seconds-per-day-2)
|
||||
(* days seconds-per-day-1)))
|
||||
(setq r (+ seconds-2 seconds-per-day*days-2)
|
||||
seconds-2 (% r 256)
|
||||
seconds-1 (+ seconds-1 (/ r 256)))
|
||||
(setq lo (+ (* seconds-2 256)
|
||||
seconds-3 seconds-per-day*days-3))
|
||||
(setq hi (+ seconds-1 seconds-per-day*days-1))
|
||||
;; (and (< (abs (- seconds (+ hibase lo))) 2) ; Check for integer overflow.
|
||||
;; (cons hi lo))
|
||||
(cons hi lo)
|
||||
))
|
||||
|
||||
(defun timezone-time-zone-from-absolute (date seconds)
|
||||
"Compute the local time zone for DATE at time SECONDS after midnight.
|
||||
Return a list in the same format as current-time-zone's result,
|
||||
or nil if the local time zone could not be computed.
|
||||
DATE is the number of days elapsed since the (imaginary)
|
||||
Gregorian date Sunday, December 31, 1 BC."
|
||||
(and (fboundp 'current-time-zone)
|
||||
(let ((utc-time (timezone-time-from-absolute date seconds)))
|
||||
(and utc-time
|
||||
(let ((zone (current-time-zone utc-time)))
|
||||
(and (car zone) zone))))))
|
||||
|
||||
(defsubst timezone-fix-time-1 (year month day hour minute second)
|
||||
"Fix date and time.
|
||||
For old `timezone-fix-time' function.
|
||||
Arguments are YEAR, MONTH, DAY, HOUR, MINUTE and SECOND."
|
||||
;; MINUTE may be larger than 60 or smaller than -60.
|
||||
(let ((hour-fix
|
||||
(if (< minute 0)
|
||||
;;(/ (- minute 59) 60) (/ minute 60)
|
||||
;; ANSI C compliance about truncation of integer division
|
||||
;; by eggert@twinsun.com (Paul Eggert)
|
||||
(- (/ (- 59 minute) 60)) (/ minute 60))))
|
||||
(setq hour (+ hour hour-fix))
|
||||
(setq minute (- minute (* 60 hour-fix))))
|
||||
;; HOUR may be larger than 24 or smaller than 0.
|
||||
(cond ((<= 24 hour) ;24 -> 00
|
||||
(setq hour (- hour 24))
|
||||
(setq day (1+ day))
|
||||
(if (< (timezone-last-day-of-month month year) day)
|
||||
(progn
|
||||
(setq month (1+ month))
|
||||
(setq day 1)
|
||||
(if (< 12 month)
|
||||
(progn
|
||||
(setq month 1)
|
||||
(setq year (1+ year))
|
||||
))
|
||||
)))
|
||||
((> 0 hour)
|
||||
(setq hour (+ hour 24))
|
||||
(setq day (1- day))
|
||||
(if (> 1 day)
|
||||
(progn
|
||||
(setq month (1- month))
|
||||
(if (> 1 month)
|
||||
(progn
|
||||
(setq month 12)
|
||||
(setq year (1- year))
|
||||
))
|
||||
(setq day (timezone-last-day-of-month month year))
|
||||
)))
|
||||
)
|
||||
(vector year month day hour minute second))
|
||||
|
||||
(defsubst timezone-fix-time-2 (date local timezone)
|
||||
"Convert DATE (default timezone LOCAL) to YYYY-MM-DD-HH-MM-SS-ZONE vector.
|
||||
If LOCAL is nil, it is assumed to be GMT.
|
||||
If TIMEZONE is nil, use the local time zone."
|
||||
(let* ((date (timezone-parse-date date))
|
||||
(year (string-to-int (aref date 0)))
|
||||
(year (cond ((< year 50)
|
||||
(+ year 2000))
|
||||
((< year 100)
|
||||
(+ year 1900))
|
||||
(t year)))
|
||||
(month (string-to-int (aref date 1)))
|
||||
(day (string-to-int (aref date 2)))
|
||||
(time (timezone-parse-time (aref date 3)))
|
||||
(hour (string-to-int (aref time 0)))
|
||||
(minute (string-to-int (aref time 1)))
|
||||
(second (string-to-int (aref time 2)))
|
||||
(local (or (aref date 4) local)) ;Use original if defined
|
||||
(timezone
|
||||
(or timezone
|
||||
(timezone-time-zone-from-absolute
|
||||
(timezone-absolute-from-gregorian month day year)
|
||||
(+ second (* 60 (+ minute (* 60 hour)))))))
|
||||
(diff (- (timezone-zone-to-minute timezone)
|
||||
(timezone-zone-to-minute local)))
|
||||
(minute (+ minute diff))
|
||||
(hour-fix (timezone-floor minute 60)))
|
||||
(setq hour (+ hour hour-fix))
|
||||
(setq minute (- minute (* 60 hour-fix)))
|
||||
;; HOUR may be larger than 24 or smaller than 0.
|
||||
(cond ((<= 24 hour) ;24 -> 00
|
||||
(setq hour (- hour 24))
|
||||
(setq day (1+ day))
|
||||
(if (< (timezone-last-day-of-month month year) day)
|
||||
(progn
|
||||
(setq month (1+ month))
|
||||
(setq day 1)
|
||||
(if (< 12 month)
|
||||
(progn
|
||||
(setq month 1)
|
||||
(setq year (1+ year))
|
||||
))
|
||||
)))
|
||||
((> 0 hour)
|
||||
(setq hour (+ hour 24))
|
||||
(setq day (1- day))
|
||||
(if (> 1 day)
|
||||
(progn
|
||||
(setq month (1- month))
|
||||
(if (> 1 month)
|
||||
(progn
|
||||
(setq month 12)
|
||||
(setq year (1- year))
|
||||
))
|
||||
(setq day (timezone-last-day-of-month month year))
|
||||
)))
|
||||
)
|
||||
(vector year month day hour minute second timezone)))
|
||||
|
||||
(defun timezone-fix-time (a1 a2 a3 &optional a4 a5 a6)
|
||||
"Fix date and time.
|
||||
(Old API: A1=YEAR A2=MONTH A3=DAY A4=HOUR A5=MINUTE A6=SECOND).
|
||||
Convert DATE (default timezone LOCAL) to YYYY-MM-DD-HH-MM-SS-ZONE vector.
|
||||
If LOCAL is nil, it is assumed to be GMT.
|
||||
If TIMEZONE is nil, use the local time zone.
|
||||
(New API: A1=DATE A2=LOCAL A3=TIMEZONE)"
|
||||
(if a4
|
||||
(timezone-fix-time-1 a1 a2 a3 a4 a5 a6)
|
||||
(timezone-fix-time-2 a1 a2 a3)))
|
||||
|
||||
;; Partly copied from Calendar program by Edward M. Reingold.
|
||||
;; Thanks a lot.
|
||||
|
||||
(defun timezone-last-day-of-month (month year)
|
||||
"The last day in MONTH during YEAR."
|
||||
(if (and (= month 2) (timezone-leap-year-p year))
|
||||
29
|
||||
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
|
||||
|
||||
(defun timezone-leap-year-p (year)
|
||||
"Return t if YEAR is a Gregorian leap year."
|
||||
(or (and (zerop (% year 4))
|
||||
(not (zerop (% year 100))))
|
||||
(zerop (% year 400))))
|
||||
|
||||
(defun timezone-day-number (month day year)
|
||||
"Return the day number within the year of the date MONTH/DAY/YEAR."
|
||||
(let ((day-of-year (+ day (* 31 (1- month)))))
|
||||
(if (> month 2)
|
||||
(progn
|
||||
(setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
|
||||
(if (timezone-leap-year-p year)
|
||||
(setq day-of-year (1+ day-of-year)))))
|
||||
day-of-year))
|
||||
|
||||
(defun timezone-absolute-from-gregorian (month day year)
|
||||
"The number of days between the Gregorian date 12/31/1 BC and MONTH/DAY/YEAR.
|
||||
The Gregorian date Sunday, December 31, 1 BC is imaginary."
|
||||
(+ (timezone-day-number month day year);; Days this year
|
||||
(* 365 (1- year));; + Days in prior years
|
||||
(/ (1- year) 4);; + Julian leap years
|
||||
(- (/ (1- year) 100));; - century years
|
||||
(/ (1- year) 400)));; + Gregorian leap years
|
||||
|
||||
;;; @ End.
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'timezone) (require 'apel-ver))
|
||||
|
||||
;;; timezone.el ends here
|
||||
180
apel-10.7/tinycustom.el
Normal file
180
apel-10.7/tinycustom.el
Normal file
@ -0,0 +1,180 @@
|
||||
;; tinycustom.el -- a tiny custom.el for emulating purpose.
|
||||
|
||||
;; Copyright (C) 1999 Mikio Nakajima <minakaji@osaka.email.ne.jp>
|
||||
|
||||
;; Author: Mikio Nakajima <minakaji@osaka.email.ne.jp>
|
||||
;; Katsumi Yamaoka <yamaoka@jpl.org>
|
||||
;; Keywords: emulating, custom
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Purpose of this program is emulating for who does not have "custom".
|
||||
;; (custom.el bundled with v19 is old; does not have following macros.)
|
||||
;;
|
||||
;; DEFCUSTOM below has the same effect as the original DEFVAR has.
|
||||
;; DEFFACE below interprets almost all arguments.
|
||||
;; DEFGROUP and DEFINE-WIDGET below are just nop macro.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'poe)
|
||||
|
||||
(defmacro-maybe defgroup (symbol members doc &rest args)
|
||||
"Declare SYMBOL as a customization group containing MEMBERS.
|
||||
SYMBOL does not need to be quoted.
|
||||
Third arg DOC is the group documentation.
|
||||
|
||||
This is a nop defgroup only for emulating purpose."
|
||||
nil)
|
||||
|
||||
(defmacro-maybe defcustom (symbol value doc &rest args)
|
||||
"Declare SYMBOL as a customizable variable that defaults to VALUE.
|
||||
DOC is the variable documentation.
|
||||
|
||||
This is a defcustom only for emulating purpose.
|
||||
Its effect is just as same as that of defvar."
|
||||
(` (defvar (, symbol) (, value) (, doc))))
|
||||
|
||||
(defvar-maybe frame-background-mode nil
|
||||
"*The brightness of the background.
|
||||
Set this to the symbol dark if your background color is dark, light if
|
||||
your background is light, or nil (default) if you want Emacs to
|
||||
examine the brightness for you. However, the old Emacsen might not
|
||||
examine the brightness, so you should set this value definitely.")
|
||||
|
||||
(defun-maybe-cond custom-declare-face (face spec doc &rest args)
|
||||
"Like `defface', but FACE is evaluated as a normal argument.
|
||||
Note that this function does not have the full specification; DOC or
|
||||
ARGS are ignored and some keywords are ignored in SPEC except for
|
||||
`:foreground', `:background', `:bold', `:italic' and `:underline'.
|
||||
It does nothing if FACE has been defined."
|
||||
((fboundp 'make-face)
|
||||
(or (find-face face)
|
||||
(let ((colorp (and window-system (x-display-color-p)))
|
||||
display atts req item match done)
|
||||
(make-face face)
|
||||
(while (and spec (not done))
|
||||
(setq display (car (car spec))
|
||||
atts (car (cdr (car spec)))
|
||||
spec (cdr spec))
|
||||
(cond ((consp display)
|
||||
(setq match t)
|
||||
(while (and display match)
|
||||
(setq req (car (car display))
|
||||
item (car (cdr (car display)))
|
||||
display (cdr display))
|
||||
(cond ((eq 'type req)
|
||||
(setq match (or (eq window-system item)
|
||||
(and (not window-system)
|
||||
(eq 'tty item)))))
|
||||
((eq 'class req)
|
||||
(setq match (or (and colorp
|
||||
(eq 'color item))
|
||||
(and (not colorp)
|
||||
(memq item
|
||||
'(grayscale mono))))))
|
||||
((eq 'background req)
|
||||
(setq match (eq (or frame-background-mode 'light)
|
||||
item)))))
|
||||
(setq done match))
|
||||
((eq t display)
|
||||
(setq done t))))
|
||||
(if done
|
||||
(let ((alist
|
||||
'((:foreground . set-face-foreground)
|
||||
(:background . set-face-background)
|
||||
(:bold . set-face-bold-p)
|
||||
(:italic . set-face-italic-p)
|
||||
(:underline . set-face-underline-p)))
|
||||
function)
|
||||
(while atts
|
||||
(if (setq function (cdr (assq (car atts) alist)))
|
||||
(funcall function face (car (cdr atts))))
|
||||
(setq atts (cdr (cdr atts))))))
|
||||
face)))
|
||||
(t
|
||||
nil))
|
||||
|
||||
(defmacro-maybe defface (face spec doc &rest args)
|
||||
"Declare FACE as a customizable face that defaults to SPEC.
|
||||
FACE does not need to be quoted.
|
||||
|
||||
Third argument DOC is the face documentation.
|
||||
|
||||
If FACE has been set with `custom-set-face', set the face attributes
|
||||
as specified by that function, otherwise set the face attributes
|
||||
according to SPEC.
|
||||
|
||||
The remaining arguments should have the form
|
||||
|
||||
[KEYWORD VALUE]...
|
||||
|
||||
The following KEYWORDs are defined:
|
||||
|
||||
:group VALUE should be a customization group.
|
||||
Add FACE to that group.
|
||||
|
||||
SPEC should be an alist of the form ((DISPLAY ATTS)...).
|
||||
|
||||
ATTS is a list of face attributes and their values. The possible
|
||||
attributes are defined in the variable `custom-face-attributes'.
|
||||
|
||||
The ATTS of the first entry in SPEC where the DISPLAY matches the
|
||||
frame should take effect in that frame. DISPLAY can either be the
|
||||
symbol t, which will match all frames, or an alist of the form
|
||||
\((REQ ITEM...)...)
|
||||
|
||||
For the DISPLAY to match a FRAME, the REQ property of the frame must
|
||||
match one of the ITEM. The following REQ are defined:
|
||||
|
||||
`type' (the value of `window-system')
|
||||
Should be one of `x' or `tty'.
|
||||
|
||||
`class' (the frame's color support)
|
||||
Should be one of `color', `grayscale', or `mono'.
|
||||
|
||||
`background' (what color is used for the background text)
|
||||
Should be one of `light' or `dark'.
|
||||
|
||||
Read the section about customization in the Emacs Lisp manual for more
|
||||
information."
|
||||
(nconc (list 'custom-declare-face (list 'quote face) spec doc)
|
||||
;; Quote colon keywords.
|
||||
(let (rest)
|
||||
(while args
|
||||
(setq rest (cons (list 'quote (car args)) rest)
|
||||
args (cdr args)
|
||||
rest (cons (car args) rest)
|
||||
args (cdr args)))
|
||||
(nreverse rest))))
|
||||
|
||||
(defmacro-maybe define-widget (name class doc &rest args)
|
||||
"Define a new widget type named NAME from CLASS.
|
||||
The third argument DOC is a documentation string for the widget.
|
||||
|
||||
This is a nop define-widget only for emulating purpose."
|
||||
nil)
|
||||
|
||||
(provide 'custom)
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'tinycustom) (require 'apel-ver))
|
||||
|
||||
;;; tinycustom.el ends here
|
||||
169
apel-10.7/tinyrich.el
Normal file
169
apel-10.7/tinyrich.el
Normal file
@ -0,0 +1,169 @@
|
||||
;;;
|
||||
;;; $Id: tinyrich.el,v 5.0 1995/09/20 14:45:56 morioka Exp $
|
||||
;;;
|
||||
;;; by MORIOKA Tomohiko <morioka@jaist.ac.jp>
|
||||
;;; modified by YAMATE Keiichirou <ics9118@sem1.info.osaka-cu.ac.jp>
|
||||
;;;
|
||||
|
||||
(defvar mime-viewer/face-list-for-text/enriched
|
||||
(cond ((and (>= emacs-major-version 19) window-system)
|
||||
'(bold italic fixed underline)
|
||||
)
|
||||
((and (boundp 'NEMACS) NEMACS)
|
||||
'("bold" "italic" "underline")
|
||||
)))
|
||||
|
||||
(defun enriched-decode (beg end)
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(goto-char beg)
|
||||
(while (re-search-forward "[ \t]*\\(\n+\\)[ \t]*" nil t)
|
||||
(let ((str (buffer-substring (match-beginning 1)
|
||||
(match-end 1))))
|
||||
(if (string= str "\n")
|
||||
(replace-match " ")
|
||||
(replace-match (substring str 1))
|
||||
)))
|
||||
(goto-char beg)
|
||||
(let (cmd sym str (fb (point)) fe b e)
|
||||
(while (re-search-forward "<\\(<\\|[^<>\n\r \t]+>\\)" nil t)
|
||||
(setq b (match-beginning 0))
|
||||
(setq cmd (buffer-substring b (match-end 0)))
|
||||
(if (string= cmd "<<")
|
||||
(replace-match "<")
|
||||
(replace-match "")
|
||||
(setq cmd (downcase (substring cmd 1 (- (length cmd) 1))))
|
||||
)
|
||||
(setq sym (intern cmd))
|
||||
(cond ((eq sym 'param)
|
||||
(setq b (point))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(if (search-forward "</param>" nil t)
|
||||
(progn
|
||||
(replace-match "")
|
||||
(setq e (point))
|
||||
)
|
||||
(setq e end)
|
||||
)))
|
||||
(delete-region b e)
|
||||
)
|
||||
((memq sym mime-viewer/face-list-for-text/enriched)
|
||||
(setq b (point))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(if (re-search-forward (concat "</" cmd ">") nil t)
|
||||
(progn
|
||||
(replace-match "")
|
||||
(setq e (point))
|
||||
)
|
||||
(setq e end)
|
||||
)))
|
||||
(tm:set-face-region b e sym)
|
||||
)))
|
||||
(goto-char (point-max))
|
||||
(if (not (eq (preceding-char) ?\n))
|
||||
(insert "\n")
|
||||
)
|
||||
))))
|
||||
|
||||
|
||||
;;; @ text/richtext <-> text/enriched converter
|
||||
;;;
|
||||
|
||||
(defun richtext-to-enriched-region (beg end)
|
||||
"Convert the region of text/richtext style to text/enriched style."
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(goto-char (point-min))
|
||||
(let (b e i)
|
||||
(while (re-search-forward "[ \t]*<comment>" nil t)
|
||||
(setq b (match-beginning 0))
|
||||
(delete-region b
|
||||
(if (re-search-forward "</comment>[ \t]*" nil t)
|
||||
(match-end 0)
|
||||
(point-max)
|
||||
))
|
||||
)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\n\n+" nil t)
|
||||
(replace-match "\n")
|
||||
)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t)
|
||||
(setq b (match-beginning 0))
|
||||
(setq e (match-end 0))
|
||||
(setq i 1)
|
||||
(while (looking-at "[ \t\n]*<nl>[ \t\n]*")
|
||||
(setq e (match-end 0))
|
||||
(setq i (1+ i))
|
||||
(goto-char e)
|
||||
)
|
||||
(delete-region b e)
|
||||
(while (>= i 0)
|
||||
(insert "\n")
|
||||
(setq i (1- i))
|
||||
))
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "<lt>" nil t)
|
||||
(replace-match "<<")
|
||||
)
|
||||
))))
|
||||
|
||||
(defun enriched-to-richtext-region (beg end)
|
||||
"Convert the region of text/enriched style to text/richtext style."
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(goto-char beg)
|
||||
(and (search-forward "text/enriched")
|
||||
(replace-match "text/richtext"))
|
||||
(search-forward "\n\n")
|
||||
(narrow-to-region (match-end 0) end)
|
||||
(let (str n)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\n\n+" nil t)
|
||||
(setq str (buffer-substring (match-beginning 0)
|
||||
(match-end 0)))
|
||||
(setq n (1- (length str)))
|
||||
(setq str "")
|
||||
(while (> n 0)
|
||||
(setq str (concat str "<nl>\n"))
|
||||
(setq n (1- n))
|
||||
)
|
||||
(replace-match str)
|
||||
)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "<<" nil t)
|
||||
(replace-match "<lt>")
|
||||
)
|
||||
))))
|
||||
|
||||
|
||||
;;; @ encoder and decoder
|
||||
;;;
|
||||
|
||||
(defun richtext-decode (beg end)
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(richtext-to-enriched-region beg (point-max))
|
||||
(enriched-decode beg (point-max))
|
||||
))
|
||||
|
||||
;; (defun richtext-encode (beg end)
|
||||
;; (save-restriction
|
||||
;; (narrow-to-region beg end)
|
||||
;; (enriched-encode beg (point-max))
|
||||
;; (enriched-to-richtext-region beg (point-max))
|
||||
;; ))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(require 'product)
|
||||
(product-provide (provide 'tinyrich) (require 'apel-ver))
|
||||
|
||||
;; tinyrich.el ends here.
|
||||
4512
flim-1.14.9/ChangeLog
Normal file
4512
flim-1.14.9/ChangeLog
Normal file
File diff suppressed because it is too large
Load Diff
1053
flim-1.14.9/FLIM-API.en
Normal file
1053
flim-1.14.9/FLIM-API.en
Normal file
File diff suppressed because it is too large
Load Diff
68
flim-1.14.9/FLIM-CFG
Normal file
68
flim-1.14.9/FLIM-CFG
Normal file
@ -0,0 +1,68 @@
|
||||
;;; -*-Emacs-Lisp-*-
|
||||
|
||||
;; FLIM-CFG: installation setting about FLIM.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar default-load-path load-path)
|
||||
|
||||
(add-to-list 'load-path
|
||||
(expand-file-name "lisp/apel" user-emacs-directory))
|
||||
(add-to-list 'load-path
|
||||
(expand-file-name "lisp/emu" user-emacs-directory))
|
||||
|
||||
(if (boundp 'LISPDIR)
|
||||
(progn
|
||||
(add-to-list 'default-load-path LISPDIR)
|
||||
(add-to-list 'load-path LISPDIR)
|
||||
(add-to-list 'load-path (expand-file-name "apel" LISPDIR))))
|
||||
|
||||
(if (boundp 'VERSION_SPECIFIC_LISPDIR)
|
||||
(add-to-list 'load-path VERSION_SPECIFIC_LISPDIR))
|
||||
|
||||
(require 'install)
|
||||
|
||||
(add-latest-path "custom")
|
||||
|
||||
(add-path default-directory)
|
||||
|
||||
;; (or (fboundp 'write-region-as-binary)
|
||||
;; (error "Please install latest APEL 7.3 or later."))
|
||||
;; (or (fboundp 'insert-file-contents-as-binary)
|
||||
;; (error "Please install latest APEL 7.3 or later."))
|
||||
|
||||
|
||||
;;; @ Please specify prefix of install directory.
|
||||
;;;
|
||||
|
||||
;; Please specify install path prefix.
|
||||
;; If it is omitted, shared directory (maybe /usr/local is used).
|
||||
(defvar PREFIX install-prefix)
|
||||
;;(setq PREFIX "~/")
|
||||
|
||||
;; Please specify prefix for ``FLIM'' [optional]
|
||||
(setq FLIM_PREFIX "flim")
|
||||
|
||||
|
||||
|
||||
;;; @ optional settings
|
||||
;;;
|
||||
|
||||
;; It is generated by automatically. Please set variable `PREFIX'.
|
||||
;; If you don't like default directory tree, please set it.
|
||||
(defvar LISPDIR (install-detect-elisp-directory PREFIX))
|
||||
;; (setq install-default-elisp-directory "~/lib/emacs/lisp")
|
||||
|
||||
(defvar VERSION_SPECIFIC_LISPDIR
|
||||
(install-detect-elisp-directory PREFIX nil 'version-specific))
|
||||
|
||||
;; (setq FLIM_DIR (expand-file-name FLIM_PREFIX VERSION_SPECIFIC_LISPDIR))
|
||||
(setq FLIM_DIR (expand-file-name FLIM_PREFIX LISPDIR))
|
||||
|
||||
(setq FLIM_VERSION_SPECIFIC_DIR
|
||||
(expand-file-name FLIM_PREFIX VERSION_SPECIFIC_LISPDIR))
|
||||
|
||||
(defvar PACKAGEDIR
|
||||
(install-get-default-package-directory))
|
||||
|
||||
;;; FLIM-CFG ends here
|
||||
48
flim-1.14.9/FLIM-ELS
Normal file
48
flim-1.14.9/FLIM-ELS
Normal file
@ -0,0 +1,48 @@
|
||||
;;; -*-Emacs-Lisp-*-
|
||||
|
||||
;; FLIM-ELS: list of FLIM modules to install
|
||||
|
||||
;;; Code:
|
||||
|
||||
(setq flim-modules '(std11
|
||||
luna lunit mime-def
|
||||
mel mel-q mel-u mel-g
|
||||
eword-decode eword-encode
|
||||
mime mime-parse mmgeneric
|
||||
mmbuffer mmcooked mmexternal
|
||||
mime-conf
|
||||
sasl sasl-cram sasl-digest
|
||||
md4 ntlm sasl-ntlm sasl-scram
|
||||
smtp qmtp))
|
||||
|
||||
(setq flim-version-specific-modules nil)
|
||||
|
||||
(setq hmac-modules '(hex-util
|
||||
hmac-def md5 sha1
|
||||
hmac-md5 hmac-sha1))
|
||||
|
||||
(if (and (fboundp 'base64-encode-string)
|
||||
(subrp (symbol-function 'base64-encode-string)))
|
||||
nil
|
||||
(if (fboundp 'dynamic-link)
|
||||
(setq flim-modules (cons 'mel-b-dl flim-modules))))
|
||||
(setq flim-modules (cons 'mel-b-el flim-modules))
|
||||
|
||||
(require 'pccl)
|
||||
(unless-broken ccl-usable
|
||||
(setq flim-modules (cons 'mel-b-ccl (cons 'mel-q-ccl flim-modules))))
|
||||
|
||||
(if (and (fboundp 'md5)
|
||||
(subrp (symbol-function 'md5)))
|
||||
nil
|
||||
(if (fboundp 'dynamic-link)
|
||||
(setq hmac-modules (cons 'md5-dl hmac-modules))
|
||||
(setq hmac-modules (cons 'md5-el hmac-modules))))
|
||||
|
||||
(if (fboundp 'dynamic-link)
|
||||
(setq hmac-modules (cons 'sha1-dl hmac-modules))
|
||||
(setq hmac-modules (cons 'sha1-el hmac-modules)))
|
||||
|
||||
(setq flim-modules (nconc hmac-modules flim-modules))
|
||||
|
||||
;;; FLIM-ELS ends here
|
||||
99
flim-1.14.9/FLIM-MK
Normal file
99
flim-1.14.9/FLIM-MK
Normal file
@ -0,0 +1,99 @@
|
||||
;;; -*-Emacs-Lisp-*-
|
||||
|
||||
;; FLIM-MK: installer for FLIM.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defun config-flim ()
|
||||
(let (prefix lisp-dir version-specific-lisp-dir)
|
||||
(and (setq prefix (car command-line-args-left))
|
||||
(or (string-equal "NONE" prefix)
|
||||
(defvar PREFIX prefix)))
|
||||
(setq command-line-args-left (cdr command-line-args-left))
|
||||
(and (setq lisp-dir (car command-line-args-left))
|
||||
(or (string-equal "NONE" lisp-dir)
|
||||
(defvar LISPDIR lisp-dir)))
|
||||
(setq command-line-args-left (cdr command-line-args-left))
|
||||
(and (setq version-specific-lisp-dir (car command-line-args-left))
|
||||
(or (string-equal "NONE" version-specific-lisp-dir)
|
||||
(progn
|
||||
(defvar VERSION_SPECIFIC_LISPDIR version-specific-lisp-dir)
|
||||
(princ (format "VERSION_SPECIFIC_LISPDIR=%s\n"
|
||||
VERSION_SPECIFIC_LISPDIR)))))
|
||||
(setq command-line-args-left (cdr command-line-args-left))
|
||||
(load-file "FLIM-CFG")
|
||||
(load-file "FLIM-ELS")
|
||||
(princ (format "PREFIX=%s
|
||||
LISPDIR=%s\n" PREFIX LISPDIR))))
|
||||
|
||||
(defun compile-flim ()
|
||||
(config-flim)
|
||||
(compile-elisp-modules flim-version-specific-modules ".")
|
||||
(compile-elisp-modules flim-modules "."))
|
||||
|
||||
(defun install-flim ()
|
||||
(config-flim)
|
||||
(if flim-version-specific-modules
|
||||
(install-elisp-modules flim-version-specific-modules "./"
|
||||
FLIM_VERSION_SPECIFIC_DIR))
|
||||
(install-elisp-modules flim-modules "./" FLIM_DIR))
|
||||
|
||||
(defun check-flim ()
|
||||
(config-flim)
|
||||
(require 'lunit)
|
||||
(let ((files (directory-files "tests" t "^test-.*\\.el$"))
|
||||
(suite (lunit-make-test-suite)))
|
||||
(while files
|
||||
(if (file-regular-p (car files))
|
||||
(progn
|
||||
(load-file (car files))
|
||||
(lunit-test-suite-add-test
|
||||
suite (lunit-make-test-suite-from-class
|
||||
(intern (file-name-sans-extension
|
||||
(file-name-nondirectory (car files))))))))
|
||||
(setq files (cdr files)))
|
||||
(lunit suite)))
|
||||
|
||||
(defun config-flim-package ()
|
||||
(let (package-dir)
|
||||
(and (setq package-dir (car command-line-args-left))
|
||||
(or (string= "NONE" package-dir)
|
||||
(defvar PACKAGEDIR package-dir)))
|
||||
(setq command-line-args-left (cdr command-line-args-left))
|
||||
(load-file "FLIM-CFG")
|
||||
(load-file "FLIM-ELS")
|
||||
(setq flim-modules (append flim-modules
|
||||
'(auto-autoloads custom-load)))
|
||||
(princ (format "PACKAGEDIR=%s\n" PACKAGEDIR))))
|
||||
|
||||
(defun compile-flim-package ()
|
||||
(config-flim-package)
|
||||
|
||||
(if (fboundp 'batch-update-directory-autoloads)
|
||||
;; XEmacs 21.5.19 and newer.
|
||||
(progn
|
||||
(add-to-list 'command-line-args-left ".")
|
||||
(add-to-list 'command-line-args-left "flim")
|
||||
(batch-update-directory-autoloads))
|
||||
(setq autoload-package-name "flim")
|
||||
(add-to-list 'command-line-args-left ".")
|
||||
(batch-update-directory))
|
||||
|
||||
(add-to-list 'command-line-args-left ".")
|
||||
(Custom-make-dependencies)
|
||||
|
||||
(compile-elisp-modules flim-version-specific-modules ".")
|
||||
(compile-elisp-modules flim-modules "."))
|
||||
|
||||
(defun install-flim-package ()
|
||||
(config-flim-package)
|
||||
(install-elisp-modules (append flim-version-specific-modules
|
||||
flim-modules)
|
||||
"./"
|
||||
(expand-file-name FLIM_PREFIX
|
||||
(expand-file-name "lisp"
|
||||
PACKAGEDIR)))
|
||||
(delete-file "./auto-autoloads.el")
|
||||
(delete-file "./custom-load.el"))
|
||||
|
||||
;;; FLIM-MK ends here
|
||||
75
flim-1.14.9/Makefile
Normal file
75
flim-1.14.9/Makefile
Normal file
@ -0,0 +1,75 @@
|
||||
#
|
||||
# Makefile for FLIM.
|
||||
#
|
||||
|
||||
PACKAGE = flim
|
||||
API = 1.14
|
||||
RELEASE = 9
|
||||
|
||||
TAR = tar
|
||||
RM = /bin/rm -f
|
||||
CP = /bin/cp -p
|
||||
|
||||
EMACS = emacs
|
||||
XEMACS = xemacs
|
||||
FLAGS = -batch -q -no-site-file -l FLIM-MK
|
||||
|
||||
PREFIX = NONE
|
||||
LISPDIR = NONE
|
||||
PACKAGEDIR = NONE
|
||||
VERSION_SPECIFIC_LISPDIR = NONE
|
||||
|
||||
GOMI = *.elc \
|
||||
*.cp *.cps *.ky *.kys *.fn *.fns *.vr *.vrs \
|
||||
*.pg *.pgs *.tp *.tps *.toc *.aux *.log
|
||||
FILES = README.?? Makefile FLIM-MK FLIM-CFG FLIM-ELS *.el ChangeLog
|
||||
|
||||
VERSION = $(API).$(RELEASE)
|
||||
ARC_DIR_PREFIX = /home/kanji/tomo/public_html/lemi/dist
|
||||
ARC_DIR = $(ARC_DIR_PREFIX)/flim/flim-$(API)
|
||||
SEMI_ARC_DIR = $(ARC_DIR_PREFIX)/semi/semi-1.14-for-flim-$(API)
|
||||
|
||||
CVS_HOST = cvs.m17n.org
|
||||
|
||||
elc:
|
||||
$(EMACS) $(FLAGS) -f compile-flim $(PREFIX) $(LISPDIR) \
|
||||
$(VERSION_SPECIFIC_LISPDIR)
|
||||
|
||||
check:
|
||||
$(EMACS) $(FLAGS) -f check-flim $(PREFIX) $(LISPDIR) \
|
||||
$(VERSION_SPECIFIC_LISPDIR)
|
||||
|
||||
install: elc
|
||||
$(EMACS) $(FLAGS) -f install-flim $(PREFIX) $(LISPDIR) \
|
||||
$(VERSION_SPECIFIC_LISPDIR)
|
||||
|
||||
|
||||
package:
|
||||
$(XEMACS) $(FLAGS) -f compile-flim-package $(PACKAGEDIR)
|
||||
|
||||
install-package: package
|
||||
$(XEMACS) $(FLAGS) -f install-flim-package $(PACKAGEDIR)
|
||||
|
||||
clean:
|
||||
-$(RM) $(GOMI)
|
||||
|
||||
|
||||
tar:
|
||||
cvs commit
|
||||
sh -c 'cvs tag -R $(PACKAGE)-`echo $(VERSION) | tr . _`; \
|
||||
cd /tmp; \
|
||||
cvs -d :pserver:anonymous@$(CVS_HOST):/cvs/root \
|
||||
export -d $(PACKAGE)-$(VERSION) \
|
||||
-r $(PACKAGE)-`echo $(VERSION) | tr . _` \
|
||||
flim'
|
||||
cd /tmp; $(RM) $(PACKAGE)-$(VERSION)/ftp.in ; \
|
||||
$(TAR) cvzf $(PACKAGE)-$(VERSION).tar.gz $(PACKAGE)-$(VERSION)
|
||||
cd /tmp; $(RM) -r $(PACKAGE)-$(VERSION)
|
||||
sed "s/VERSION/$(VERSION)/" < ftp.in | sed "s/API/$(API)/" \
|
||||
| sed "s/PACKAGE/$(PACKAGE)/" > ftp
|
||||
|
||||
release:
|
||||
-$(RM) $(ARC_DIR)/$(PACKAGE)-$(VERSION).tar.gz
|
||||
mv /tmp/$(PACKAGE)-$(VERSION).tar.gz $(ARC_DIR)
|
||||
cd $(SEMI_ARC_DIR) ; \
|
||||
ln -s ../../flim/flim-$(API)/$(PACKAGE)-$(VERSION).tar.gz .
|
||||
164
flim-1.14.9/NEWS
Normal file
164
flim-1.14.9/NEWS
Normal file
@ -0,0 +1,164 @@
|
||||
FLIM NEWS --- history of major-changes.
|
||||
Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
* Changes in FLIM 1.12
|
||||
|
||||
** Restructure of field decoding features
|
||||
|
||||
Introduce backend mechanism of field-decoder and
|
||||
field-presentation-method to restructure field decoding features.
|
||||
|
||||
Field-decoder is registered into variable `mime-field-decoder-alist'.
|
||||
Each decoding function uses decoding method found from variable
|
||||
`mime-field-decoder-alist'.
|
||||
|
||||
New function `mime-set-field-decoder' is added to register field
|
||||
decoding method.
|
||||
|
||||
New function `mime-find-field-presentation-method' is added to get
|
||||
`field-presentation-method' object corresponding with specified
|
||||
field-presentation-mode. Field-presentation-mode must be `plain',
|
||||
`wide', `summary' or `nov'.
|
||||
|
||||
New function `mime-find-field-decoder' is added to find field decoding
|
||||
method corresponding with field-name and field-presentation-mode.
|
||||
|
||||
New function `mime-decode-field-body' is added. It is general field
|
||||
decoder.
|
||||
|
||||
|
||||
** Function `mime-decode-header-in-buffer'
|
||||
|
||||
Renamed from `eword-decode-header'. `eword-decode-header' is defined
|
||||
as obsolete alias.
|
||||
|
||||
|
||||
** New function `mime-decode-header-in-region'
|
||||
|
||||
|
||||
** Changes about lexical-analyzers
|
||||
|
||||
*** New user option `std11-lexical-analyzer'
|
||||
|
||||
Now function `std11-lexical-analyze' refers user option
|
||||
`std11-lexical-analyzer'.
|
||||
|
||||
|
||||
*** User option `eword-lexical-analyzers' -> `eword-lexical-analyzer'
|
||||
|
||||
User option `eword-lexical-analyzers' was renamed to
|
||||
`eword-lexical-analyzer'.
|
||||
|
||||
|
||||
*** Change interface of lexical-analyzers
|
||||
|
||||
Interface of function `eword-lexical-analyze' was changed from
|
||||
`(string &optional must-unfold)' to `(string &optional start
|
||||
must-unfold)'. Interface of lexical analyzer specified by user option
|
||||
`eword-lexical-analyzer' was changed likewise.
|
||||
|
||||
Function `eword-extract-address-components' was added new optional
|
||||
argument `START' to specify start position of `STRING' to parse.
|
||||
|
||||
Function `std11-lexical-analyze' was added new optional arguments
|
||||
`ANALYZER' to specify lexical-analyzer and `START' to specify start
|
||||
position of `STRING' to analyze.
|
||||
|
||||
Interface of lexical analyzers for STD 11 was changed from `(string)'
|
||||
to `(string &optional start)'.
|
||||
|
||||
|
||||
** Function `std11-parse-in-reply-to' -> `std11-parse-msg-ids'
|
||||
|
||||
Rename function `std11-parse-in-reply-to' to `std11-parse-msg-ids'.
|
||||
Function `std11-parse-in-reply-to' was defined as obsolete alias.
|
||||
|
||||
|
||||
** New function `std11-parse-msg-id-string'
|
||||
|
||||
|
||||
** New function `std11-parse-msg-ids-string'
|
||||
|
||||
|
||||
** New function `mime-find-entity-from-content-id'
|
||||
|
||||
|
||||
** New function `mime-parse-msg-id'
|
||||
|
||||
|
||||
** New function `mime-uri-parse-cid'
|
||||
|
||||
|
||||
** New generic function `mime-insert-entity'
|
||||
|
||||
Add new generic function `mime-insert-entity' to insert header and
|
||||
body of ENTITY at point.
|
||||
|
||||
Each mm-backend must have new method `insert-entity'.
|
||||
|
||||
|
||||
** New optional argument of `std11-field-end'
|
||||
|
||||
Now `std11-field-end' can accept new optional argument BOUND. Thus
|
||||
current interface is:
|
||||
|
||||
std11-field-end (&optional BOUND)
|
||||
|
||||
If the optional argument BOUND is specified, it bounds the search; it
|
||||
is a buffer position.
|
||||
|
||||
|
||||
* Changes in FLIM 1.11
|
||||
|
||||
** New function `mime-insert-text-content'
|
||||
|
||||
Add new generic function `mime-insert-text-content' and new mm-service
|
||||
`insert-text-content'.
|
||||
|
||||
|
||||
** `insert-decoded-header' -> `insert-header'
|
||||
|
||||
mm-service `insert-decoded-header' was renamed to `insert-header'.
|
||||
Similarly generic function `mime-insert-decoded-header' was renamed to
|
||||
`mime-insert-header'. However `mime-insert-decoded-header' was left
|
||||
as an obsolete alias.
|
||||
|
||||
|
||||
** Behavior change of `mime-insert-header'
|
||||
|
||||
Each field-name of second and third argument of function
|
||||
`mime-insert-header' can include `:'.
|
||||
|
||||
|
||||
** Abolish variable `mime-temp-directory'
|
||||
|
||||
Now FLIM uses `temporary-file-directory' instead of
|
||||
`mime-temp-directory'. So environment variable "MIME_TMP_DIR" and
|
||||
"TM_TMP_DIR" are not effective to specify temporary directory of FLIM.
|
||||
|
||||
|
||||
** Add new function `eword-decode-and-unfold-unstructured-field'
|
||||
|
||||
|
||||
** Add new mm-backend `generic'
|
||||
|
||||
Add new mm-backend `generic'. mm-backend `buffer' inherits the
|
||||
mm-backend `generic'.
|
||||
|
||||
|
||||
** Change internal representation of `mime-entity' structure
|
||||
|
||||
Internal representation of `mime-entity' structure was changed to add
|
||||
NOV entries.
|
||||
|
||||
|
||||
** `mime-entity-*-internal' and `mime-entity-set-*-internal'
|
||||
|
||||
Change `mime-entity-*-internal' and `mime-entity-set-*-internal' to
|
||||
macro.
|
||||
|
||||
|
||||
Local variables:
|
||||
mode: outline
|
||||
paragraph-separate: "[ ]*$"
|
||||
end:
|
||||
149
flim-1.14.9/README.en
Normal file
149
flim-1.14.9/README.en
Normal file
@ -0,0 +1,149 @@
|
||||
[README for FLIM (English Version)]
|
||||
by MORIOKA Tomohiko
|
||||
|
||||
What's FLIM
|
||||
===========
|
||||
|
||||
FLIM is a library to provide basic features about message
|
||||
representation or encoding. It consists of following
|
||||
modules:
|
||||
|
||||
std11.el --- STD 11 (RFC 822) parser and utility
|
||||
|
||||
mime.el --- to provide various services about MIME-entities
|
||||
|
||||
mime-def.el --- Definitions about MIME format
|
||||
|
||||
mime-parse.el --- MIME parser
|
||||
|
||||
mel.el --- MIME encoder/decoder
|
||||
mel-b-dl.el --- base64 (B-encoding) encoder/decoder
|
||||
(for Emacs 20 with dynamic loading support)
|
||||
mel-b-ccl.el --- base64 (B-encoding) encoder/decoder
|
||||
(using CCL)
|
||||
mel-b-en.el --- base64 (B-encoding) encoder/decoder
|
||||
(for other emacsen)
|
||||
mel-q-ccl.el --- quoted-printable and Q-encoding
|
||||
encoder/decoder (using CCL)
|
||||
mel-q.el --- quoted-printable and Q-encoding
|
||||
encoder/decoder
|
||||
mel-u.el --- unofficial backend for uuencode
|
||||
mel-g.el --- unofficial backend for gzip64
|
||||
|
||||
eword-decode.el --- encoded-word decoder
|
||||
eword-encode.el --- encoded-word encoder
|
||||
|
||||
mailcap.el --- mailcap parser and utility
|
||||
|
||||
This library should work on:
|
||||
|
||||
Emacs 20.4 and up
|
||||
XEmacs 21.1 and up
|
||||
|
||||
|
||||
Installation
|
||||
============
|
||||
|
||||
(0) before installing it, please install APEL (10.7 or later) package.
|
||||
APEL package is available at:
|
||||
|
||||
ftp://ftp.m17n.org/pub/mule/apel/
|
||||
|
||||
(1-a) run in expanded place
|
||||
|
||||
If you don't want to install other directories, please do only
|
||||
following:
|
||||
|
||||
% make
|
||||
|
||||
You can specify the emacs command name, for example
|
||||
|
||||
% make EMACS=xemacs
|
||||
|
||||
If `EMACS=...' is omitted, EMACS=emacs is used.
|
||||
|
||||
(1-b) make install
|
||||
|
||||
If you want to install other directories, please do following:
|
||||
|
||||
% make install
|
||||
|
||||
You can specify the emacs command name, for example
|
||||
|
||||
% make install EMACS=xemacs
|
||||
|
||||
If `EMACS=...' is omitted, EMACS=emacs is used.
|
||||
|
||||
You can specify the prefix of the directory tree for Emacs Lisp
|
||||
programs, for example:
|
||||
|
||||
% make install PREFIX=~/
|
||||
|
||||
If `PREFIX=...' is omitted, the prefix of the directory tree of the
|
||||
specified emacs command is used (perhaps /usr/local).
|
||||
|
||||
For example, if PREFIX=/usr/local and EMACS 19.34 is specified, it
|
||||
will create the following directory tree:
|
||||
|
||||
/usr/local/share/emacs/site-lisp/flim/ --- FLIM
|
||||
|
||||
You can specify site-lisp directory, for example
|
||||
|
||||
% make install LISPDIR=~/share/emacs/lisp
|
||||
|
||||
If `LISPDIR=...' is omitted, site-lisp directory of the specified
|
||||
emacs command is used (perhaps /usr/local/share/emacs/site-lisp or
|
||||
/usr/local/lib/xemacs/site-lisp).
|
||||
|
||||
If the emu modules (included in APEL package) have been installed in
|
||||
the non-standard directory, you should specify where they will be
|
||||
found, for example:
|
||||
|
||||
% make install VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
Following make target is available to find what files are parts of
|
||||
emu / APEL package, and where are directories to install them:
|
||||
|
||||
% make what-where LISPDIR=~/elisp VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
You can specify other optional settings by editing the file
|
||||
FLIM-CFG. Please read comments in it.
|
||||
|
||||
(1-c) install as a XEmacs package
|
||||
|
||||
If you want to install to XEmacs package directory, please do
|
||||
following:
|
||||
|
||||
% make install-package
|
||||
|
||||
You can specify the XEmacs command name, for example
|
||||
|
||||
% make install-package XEMACS=xemacs-21
|
||||
|
||||
If `XEMACS=...' is omitted, XEMACS=xemacs is used.
|
||||
|
||||
You can specify the package directory, for example:
|
||||
|
||||
% make install PACKAGEDIR=~/.xemacs
|
||||
|
||||
If `PACKAGEDIR=...' is omitted, the first existing package
|
||||
directory is used.
|
||||
|
||||
Notice that XEmacs package system requires XEmacs 21.0 or later.
|
||||
|
||||
|
||||
Bug reports
|
||||
===========
|
||||
|
||||
If you write bug-reports and/or suggestions for improvement, please
|
||||
send them to the EMACS-MIME Mailing List:
|
||||
|
||||
emacs-mime-en@m17n.org (English)
|
||||
emacs-mime-ja@m17n.org (Japanese)
|
||||
|
||||
Via the EMACS-MIME ML, you can report FLIM bugs, obtain the latest
|
||||
release of FLIM, and discuss future enhancements to FLIM. To join
|
||||
the EMACS-MIME ML, send an empty e-mail to
|
||||
|
||||
emacs-mime-en-ctl@m17n.org (English)
|
||||
emacs-mime-ja-ctl@m17n.org (Japanese)
|
||||
159
flim-1.14.9/README.ja
Normal file
159
flim-1.14.9/README.ja
Normal file
@ -0,0 +1,159 @@
|
||||
[FLIM $B$N(B README ($BF|K\8lHG(B)]
|
||||
|
||||
FLIM $B$H$O!)(B
|
||||
===========
|
||||
|
||||
FLIM $B$O(B Internet message $B$K4X$9$kMM!9$JI=8=7A<0$dId9f2=$K4X$9$k4pAC(B
|
||||
$BE*$J5!G=$rDs6!$9$k$?$a$NHFMQItIJ$G$9!#(BFLIM $B$O0J2<$N%b%8%e!<%k$+$i9=(B
|
||||
$B@.$5$l$F$$$^$9(B:
|
||||
|
||||
std11.el --- STD 11 (RFC 822) $B7A<0$K4p$E$/2r@O=hM}Ey(B
|
||||
|
||||
mime.el --- MIME-entity $B$K4X$9$k=t5!G=$NDs6!(B
|
||||
|
||||
mime-def.el --- MIME $B7A<0$K4X$9$kDj5A(B
|
||||
|
||||
mime-parse.el --- MIME $B2r@O4o(B
|
||||
|
||||
mel.el --- MIME $BId9f4o(B/$BI|9f4o(B
|
||||
mel-b-dl.el --- base64 (B-encoding) $BId9f4o(B/$BI|9f4o(B
|
||||
(dynamic loading $B5!G=IU$-(B Emacs 20 $BMQ(B)
|
||||
mel-b-ccl.el --- base64 (B-encoding) encoder/decoder (using CCL)
|
||||
mel-b-el.el --- base64 (B-encoding) $BId9f4o(B/$BI|9f4o(B
|
||||
($BB>$N(B emacsen $BMQ(B)
|
||||
mel-q-ccl.el --- quoted-printable and Q-encoding
|
||||
encoder/decoder (using CCL)
|
||||
mel-q.el --- quoted-printable $B$H(B Q-encoding
|
||||
$BId9f4o(B/$BI|9f4o(B
|
||||
mel-u.el --- uuencode $B$N$?$a$NHs8x<0(B backend
|
||||
mel-g.el --- gzip64 $B$N$?$a$NHs8x<0(B backend
|
||||
|
||||
eword-decode.el --- encoded-word $BI|9f4o(B
|
||||
eword-encode.el --- encoded-word $BId9f4o(B
|
||||
|
||||
mailcap.el --- mailcap $B$N2r@O=hM}Ey(B
|
||||
|
||||
$B0J2<$N4D6-$GF0:n$7$^$9!'(B
|
||||
|
||||
Emacs 20.4 $B0J9_(B
|
||||
XEmacs 21.1 $B0J9_(B
|
||||
|
||||
|
||||
$BF3F~(B (Installation)
|
||||
===================
|
||||
|
||||
(0) $BF3F~(B (install) $B$9$kA0$K!"(BAPEL (10.7 $B0J9_(B) $B$rF3F~$7$F$/$@$5$$!#(BAPEL
|
||||
$B$O0J2<$N$H$3$m$G<hF@$G$-$^$9(B:
|
||||
|
||||
ftp://ftp.m17n.org/pub/mule/apel/
|
||||
|
||||
(1-a) $BE83+$7$?>l=j$X$NF3F~(B
|
||||
|
||||
$BE83+$7$?>l=j$H$O0[$J$k>l=j$KF3F~$7$?$/$J$$$J$i!"(B
|
||||
|
||||
% make
|
||||
|
||||
$B$@$1$r<B9T$7$F$/$@$5$$!#(B
|
||||
|
||||
emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make EMACS=xemacs
|
||||
|
||||
`EMACS=...' $B$,>JN,$5$l$k$H!"(BEmacs=emacs $B$,;H$o$l$^$9!#(B
|
||||
|
||||
(b) make install
|
||||
|
||||
$BE83+$7$?>l=j$H$O0[$J$k>l=j$KF3F~$7$?$$$J$i!"(B
|
||||
|
||||
% make install
|
||||
|
||||
$B$r<B9T$7$F$/$@$5$$!#(B
|
||||
|
||||
emacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make install EMACS=xemacs
|
||||
|
||||
`EMACS=...' $B$,>JN,$5$l$k$H!"(BEmacs=emacs $B$,;H$o$l$^$9!#(B
|
||||
|
||||
Emacs Lisp $B%W%m%0%i%`$N$?$a$N%G%#%l%/%H%j!<LZ$N@\F,<-(B (prefix) $B$r;X(B
|
||||
$BDj$9$k$3$H$,$G$-$^$9!#Nc$($P!"(B
|
||||
|
||||
% make install PREFIX=~/
|
||||
|
||||
`PREFIX=...' $B$,>JN,$5$l$k$H!";XDj$5$l$?(B emacs $B%3%^%s%I$N%G%#%l%/%H%j!<(B
|
||||
$BLZ$N@\F,<-$,;HMQ$5$l$^$9(B ($B$*$=$i$/(B /usr/local $B$G$9(B)$B!#(B
|
||||
|
||||
$BNc$($P!"(BPREFIX=/usr/local $B$H(B Emacs 20.7 $B$,;XDj$5$l$l$P!"0J2<$N%G%#%l(B
|
||||
$B%/%H%j!<LZ$,:n@.$5$l$^$9!#(B
|
||||
|
||||
/usr/local/share/emacs/site-lisp/flim/ --- FLIM
|
||||
/usr/local/share/emacs/20.7/site-lisp/flim/ --- FLIM
|
||||
|
||||
Emacs Lisp $B%W%m%0%i%`$N$?$a$N(B lisp $B%G%#%l%/%H%j!<$r;XDj$9$k$3$H$,$G(B
|
||||
$B$-$^$9!#Nc$($P!"(B:
|
||||
|
||||
% make install LISPDIR=~/share/emacs/elisp
|
||||
|
||||
`LISPDIR=...' $B$,>JN,$5$l$k$H!";XDj$5$l$?(B emacs $B$N%3%^%s%I$N(B
|
||||
site-lisp $B%G%#%l%/%H%j!<$,;H$o$l$^$9(B ($B$*$=$i$/(B
|
||||
/usr/local/share/emacs/site-lisp $B$+(B /usr/local/lib/xemacs/site-lisp)
|
||||
$B$G$9!#(B
|
||||
|
||||
emu $B%b%8%e!<%k(B (APEL $B%Q%C%1!<%8$KF~$C$F$$$^$9(B) $B$,I8=`$G$J$$%G%#%l%/(B
|
||||
$B%H%j!<$KF3F~$5$l$F$$$k>l9g$O!"$=$l$i$N$"$k>l=j$r;XDj$9$kI,MW(B
|
||||
$B$,$"$j$^$9!#Nc$($P!'(B
|
||||
|
||||
% make install VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
$B$I$N%U%!%$%k$,(B emu $B%b%8%e!<%k$+(B APEL $B%b%8%e!<%k$N0lIt$J$N$+!"$=$l$i(B
|
||||
$B$,$I$3$KF3F~$5$l$k$+$rCN$j$?$$$H$-$O!"<!$N$h$&$J%3%^%s%I$rF~(B
|
||||
$BNO$9$k$3$H$,$G$-$^$9!#(B
|
||||
|
||||
% make what-where LISPDIR=~/elisp VERSION_SPECIFIC_LISPDIR=~/elisp
|
||||
|
||||
$B$^$?!"(BFLIM-CFG $B%U%!%$%k$rJT=8$9$k$3$H$GB>$NA*Br2DG=$J@_Dj$r;XDj$9$k(B
|
||||
$B$3$H$,$G$-$^$9!#$=$N>\:Y$K4X$7$F$O(B FLIM-CFG $B%U%!%$%k$NCm<a(B (comment)
|
||||
$B$rFI$s$G$/$@$5$$!#(B
|
||||
|
||||
(1-c) XEmacs $B$N%Q%C%1!<%8$H$7$FF3F~$9$k(B
|
||||
|
||||
XEmacs $B$N%Q%C%1!<%8!&%G%#%l%/%H%j!<$KF3F~$9$k>l9g$O!"(B
|
||||
|
||||
% make install-package
|
||||
|
||||
$B$r<B9T$7$F$/$@$5$$!#(B
|
||||
|
||||
XEmacs $B$N%3%^%s%IL>$r;XDj$9$k$3$H$,$G$-$^$9!#Nc!'(B
|
||||
|
||||
% make install-package XEMACS=xemacs-21
|
||||
|
||||
`XEMACS=...' $B$,>JN,$5$l$k$H!"(BXEMACS=xemacs $B$,;HMQ$5$l$^$9!#(B
|
||||
|
||||
$B%Q%C%1!<%8!&%G%#%l%/%H%j!<$r;XDj$9$k$3$H$,$G$-$^$9!#Nc!'(B
|
||||
|
||||
% make install PACKAGEDIR=~/.xemacs
|
||||
|
||||
`PACKAGEDIR=...' $B$,>JN,$5$l$k$H!"B8:_$9$k%Q%C%1!<%8!&%G%#%l%/%H%j!<(B
|
||||
$B$N:G=i$N$b$N$,;H$o$l$^$9!#(B
|
||||
|
||||
$B!NCm0U!O(BXEmacs $B$N%Q%C%1!<%8!&%7%9%F%`$O(B XEmacs 21.0 $B$+$=$l0J9_$,I,MW(B
|
||||
$B$G$9!#(B
|
||||
|
||||
|
||||
$B%P%0Js9p(B
|
||||
========
|
||||
|
||||
$B%P%0Js9p$d2~A1$NDs0F$r=q$$$?$H$-$O!"@'Hs(B EMACS-MIME $B%a!<%j%s%0%j%9%H(B
|
||||
$B$KAw$C$F$/$@$5$$(B:
|
||||
|
||||
emacs-mime-en@m17n.org ($B1Q8l(B)
|
||||
emacs-mime-ja@m17n.org ($BF|K\8l(B)
|
||||
|
||||
EMACS-MIME ML $B$rDL$7$F!"(BFLIM $B$N%P%0$rJs9p$7$?$j!"(BFLIM $B$N:G?7$N%j%j!<(B
|
||||
$B%9$r<hF@$7$?$j!"(BFLIM $B$N>-Mh$N3HD%$N5DO@$r$7$?$j$9$k$3$H$,$G$-$^$9!#(B
|
||||
EMACS-MIME ML $B$K;22C$9$k$K$O!"6u$NEE;R%a!<%k$r(B
|
||||
|
||||
emacs-mime-en-ctl@m17n.org ($B1Q8l(B)
|
||||
emacs-mime-ja-ctl@m17n.org ($BF|K\8l(B)
|
||||
|
||||
$B$KAw$C$F$/$@$5$$!#(B
|
||||
108
flim-1.14.9/VERSION
Normal file
108
flim-1.14.9/VERSION
Normal file
@ -0,0 +1,108 @@
|
||||
[FLIM Version names]
|
||||
|
||||
1.0.0 -----
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; Kinki Nippon Railway $(B6a5&F|K\E4F;(B http://www.kintetsu.co.jp/
|
||||
;; Ky-Dòto Line $(B5~ET@~(B-A
|
||||
;;-------------------------------------------------------------------------
|
||||
1.0.1 Ky-Dòto $(B5~ET(B ; <=> JR, $(B5~ET;T8rDL6I(B-A
|
||||
1.1.0 T-Dòji $(BEl;{(B-A
|
||||
1.2.0 J-Dşjò $(B==>r(B-A
|
||||
1.2.1 Kamitobaguchi $(B>eD;1)8}(B
|
||||
1.2.2 Takeda $(BC]ED(B ; = $(B5~ET;T8rDL6I(B $(B1(4]@~(B
|
||||
1.3.0 Fushimi $(BIz8+(B
|
||||
1.4.0 Kintetsu-Tambabashi $(B6aE4C0GH66(B ; <=> $(B5~:e(B $(BC0GH66(B
|
||||
1.4.1 Momoyama-Gory-Dòmae $(BEm;38fNMA0(B-A
|
||||
1.5.0 Mukaijima $(B8~Eg(B
|
||||
1.6.0 Ogura $(B>.AR(B
|
||||
1.7.0 Iseda $(B0K@*ED(B
|
||||
1.8.0 -DÒkubo $(BBg5WJ](B-A
|
||||
1.8.1 Kutsukawa $(B5WDE@n(B
|
||||
1.9.0 Terada $(B;{ED(B
|
||||
1.9.1 Tonosh-Dò $(BIYLnAq(B-A
|
||||
1.9.2 Shin-Tanabe $(B?7EDJU(B
|
||||
1.10.0 K-Dòdo $(B6=8M(B-A
|
||||
1.10.1 Miyamaki $(B;0;3LZ(B
|
||||
1.10.2 Kintetsu-Miyazu $(B6aE45\DE(B
|
||||
1.10.3 Komada $(B9}ED(B
|
||||
1.10.4 Shin-H-Dòsono $(B?7=K1`(B ; <=> JR $(BJRD.@~(B $(B=K1`(B-A
|
||||
1.10.5 Kizugawadai $(BLZDE@nBf(B
|
||||
1.11.0 Yamadagawa $(B;3ED@n(B
|
||||
1.11.1 Takanohara $(B9b$N86(B
|
||||
1.11.2 Heij-Dò $(BJ?>k(B-A
|
||||
1.11.3 Saidaiji $(B@>Bg;{(B ; = $(B6aE4(B $(BF`NI@~(B
|
||||
;;-------------------------------------------------------------------------
|
||||
;; Kinki Nippon Railway $(B6a5&F|K\E4F;(B http://www.kintetsu.co.jp/
|
||||
;; Ky-Dòto Line $(B3`86@~(B-A
|
||||
;;-------------------------------------------------------------------------
|
||||
(Saidaiji) ($(B@>Bg;{(B)
|
||||
1.12.0 Amagatsuji $(BFt%vDT(B
|
||||
1.12.1 Nishinoky-Dò $(B@>$N5~(B-A
|
||||
1.12.2 Kuj-Dò $(B6e>r(B-A
|
||||
1.12.3 Kintetsu-K-Dòriyama $(B6aE474;3(B-A
|
||||
1.12.4 Tsutsui $(BE{0f(B
|
||||
1.12.5 Hirahata $(BJ?C<(B ; = $(B6aE4(B $(BE7M}@~(B
|
||||
1.12.6 Family-K-Dòenmae $(B%U%!%_%j!<8x1`A0(B-A
|
||||
1.12.7 Y-Dşzaki $(B7k:j(B-A
|
||||
1.13.0 Iwami $(B@P8+(B
|
||||
1.13.1 Tawaramoto $(BED86K\(B ; <=> $(B6aE4(B $(B@>ED86K\(B
|
||||
1.13.2 Kasanui $(B3^K%(B
|
||||
1.14.0 Ninokuchi $(B?7%N8}(B
|
||||
1.14.1 Yagi $(BH,LZ(B ; = $(B6aE4(B $(BBg:e@~(B
|
||||
1.14.2 Yagi-Nishiguchi $(BH,LZ@>8}(B
|
||||
1.14.3 Unebigory-Dòmae $(B@&K58fNMA0(B-A
|
||||
1.14.4 Kashiharajing-Dş-mae $(B3`86?@5\A0(B ; = $(B6aE4(B $(BFnBg:e@~!"5HLn@~(B-A
|
||||
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; Keihan Electric Railway $(B5~:eEE5$E4F;(B http://www.keihan.co.jp/
|
||||
;; -DÒtò Line $(B3{El@~(B-A
|
||||
;;-------------------------------------------------------------------------
|
||||
1.14.5 Demachiyanagi $(B=PD.Lx(B ; <=> $(B1CEE(B
|
||||
1.14.6 Marutamachi $(B4]B@D.(B
|
||||
1.14.7 Sanj-Dò $(B;0>r(B ; = $(B5~ET;T8rDL6I(B $(BEl@>@~(B-A
|
||||
;;-------------------------------------------------------------------------
|
||||
;; Keihan Electric Railway $(B5~:eEE5$E4F;(B http://www.keihan.co.jp/
|
||||
;; Main Line $(BK\@~(B
|
||||
;;-------------------------------------------------------------------------
|
||||
(Sanj-Dò) ($(B;0>r(B)-A
|
||||
1.14.8 Shij-Dò $(B;M>r(B-A
|
||||
1.14.9 Goj-Dò $(B8^>r(B-A
|
||||
|
||||
|
||||
[Chao Version names]
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; Kyoto Municipal Transfer Bureau
|
||||
;; $(B5~ET;T8rDL6I(B
|
||||
;; http://www.city.kyoto.jp/kotsu/main.htm
|
||||
;; Karasuma Line $(B1(4]@~(B
|
||||
;;-------------------------------------------------------------------------
|
||||
1.2.0 Takeda $(BC]ED(B ; = $(B6aE4(B $(B5~ET@~(B
|
||||
1.3.0 Kuinabashi $(B$/$$$J66(B
|
||||
1.4.0 J-Dşjò $(B==>r(B-A
|
||||
1.6.0 Kuj-Dò $(B6e>r(B-A
|
||||
1.6.1 Ky-Dòto $(B5~ET(B ; <=> JR, $(B6aE4(B-A
|
||||
1.7.0 Goj-Dò $(B8^>r(B-A
|
||||
1.8.0 Shij-Dò $(B;M>r(B ; <=> $(B:e5^(B $(B5~ET@~(B-A
|
||||
1.9.0 Karasuma Oike $(B1(4]8fCS(B ; = $(B5~ET;T8rDL6I(B $(BEl@>@~(B
|
||||
1.10.0 Marutamach $(B4]B@D.(B
|
||||
1.11.0 Imadegawa $(B:#=P@n(B
|
||||
1.11.1 Kuramaguchi $(B0HGO8}(B
|
||||
1.11.2 Kita-Dòji $(BKLBgO)(B-A
|
||||
1.11.3 Kitayama $(BKL;3(B
|
||||
1.11.4 Matugasaki $(B>>%v:j(B
|
||||
1.11.5 Kokusaikaikan $(B9q:]2q4[(B
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; West Japan Railway $(B@>F|K\N95RE4F;(B http://www.westjr.co.jp/
|
||||
;; Nara Line $(BF`NI@~(B
|
||||
;;-------------------------------------------------------------------------
|
||||
1.12.0 [JR] Ky-Dòto $(B5~ET(B ; <=> $(B6aE4(B, $(B5~ET;T8rDL6I(B-A
|
||||
1.12.1 T-Dòfukuji $(BElJ!;{(B ; <=> $(B5~:e(B-A
|
||||
1.12.2 Inari $(B0p2Y(B
|
||||
1.13.0 JR Fujinomori JR $(BF#?9(B
|
||||
1.14.0 Momoyama $(BEm;3(B
|
||||
1.14.1 Rokujiz-Dò $(BO;COB"(B-A
|
||||
------ Kohata $(BLZH((B
|
||||
823
flim-1.14.9/eword-decode.el
Normal file
823
flim-1.14.9/eword-decode.el
Normal file
@ -0,0 +1,823 @@
|
||||
;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs
|
||||
|
||||
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
|
||||
;; 2005 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
|
||||
;; MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; TANAKA Akira <akr@m17n.org>
|
||||
;; Created: 1995/10/03
|
||||
;; Original: 1992/07/20 ENAMI Tsugutomo's `mime.el'.
|
||||
;; Renamed: 1993/06/03 to tiny-mime.el by MORIOKA Tomohiko
|
||||
;; Renamed: 1995/10/03 to tm-ew-d.el (split off encoder)
|
||||
;; by MORIOKA Tomohiko
|
||||
;; Renamed: 1997/02/22 from tm-ew-d.el by MORIOKA Tomohiko
|
||||
;; Keywords: encoded-word, MIME, multilingual, header, mail, news
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(require 'mel)
|
||||
(require 'std11)
|
||||
|
||||
(eval-when-compile (require 'cl)) ; list*, pop
|
||||
|
||||
|
||||
;;; @ Variables
|
||||
;;;
|
||||
|
||||
;; User options are defined in mime-def.el.
|
||||
|
||||
|
||||
;;; @ MIME encoded-word definition
|
||||
;;;
|
||||
|
||||
(eval-and-compile
|
||||
(defconst eword-encoded-text-regexp "[!->@-~]+")
|
||||
|
||||
(defconst eword-encoded-word-regexp
|
||||
(eval-when-compile
|
||||
(concat (regexp-quote "=?")
|
||||
"\\("
|
||||
mime-charset-regexp ; 1
|
||||
"\\)"
|
||||
"\\("
|
||||
(regexp-quote "*")
|
||||
mime-language-regexp ; 2
|
||||
"\\)?"
|
||||
(regexp-quote "?")
|
||||
"\\("
|
||||
mime-encoding-regexp ; 3
|
||||
"\\)"
|
||||
(regexp-quote "?")
|
||||
"\\("
|
||||
eword-encoded-text-regexp ; 4
|
||||
"\\)"
|
||||
(regexp-quote "?="))))
|
||||
)
|
||||
|
||||
|
||||
;;; @ for string
|
||||
;;;
|
||||
|
||||
(defun eword-decode-string (string &optional must-unfold)
|
||||
"Decode MIME encoded-words in STRING.
|
||||
|
||||
STRING is unfolded before decoding.
|
||||
|
||||
If an encoded-word is broken or your emacs implementation can not
|
||||
decode the charset included in it, it is not decoded.
|
||||
|
||||
If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
|
||||
if there are in decoded encoded-words (generated by bad manner MUA
|
||||
such as a version of Net$cape)."
|
||||
(setq string (std11-unfold-string string))
|
||||
(let ((regexp (concat "[\n\t ]*\\(" eword-encoded-word-regexp "\\)"))
|
||||
(next 0)
|
||||
match start words)
|
||||
(while (setq match (string-match regexp string next))
|
||||
(setq start (match-beginning 1)
|
||||
words nil)
|
||||
(while match
|
||||
(setq next (match-end 0))
|
||||
(push (list (match-string 2 string) ;; charset
|
||||
(match-string 3 string) ;; language
|
||||
(match-string 4 string) ;; encoding
|
||||
(match-string 5 string) ;; encoded-text
|
||||
(match-string 1 string)) ;; encoded-word
|
||||
words)
|
||||
(setq match (and (string-match regexp string next)
|
||||
(= next (match-beginning 0)))))
|
||||
(setq words (eword-decode-encoded-words (nreverse words) must-unfold)
|
||||
string (concat (substring string 0 start)
|
||||
words
|
||||
(substring string next))
|
||||
next (+ start (length words)))))
|
||||
string)
|
||||
|
||||
(defun eword-decode-structured-field-body (string
|
||||
&optional start-column max-column
|
||||
start)
|
||||
(let ((tokens (eword-lexical-analyze string start 'must-unfold))
|
||||
(result "")
|
||||
token)
|
||||
(while tokens
|
||||
(setq token (car tokens))
|
||||
(setq result (concat result (eword-decode-token token)))
|
||||
(setq tokens (cdr tokens)))
|
||||
result))
|
||||
|
||||
(defun eword-decode-and-unfold-structured-field-body (string
|
||||
&optional
|
||||
start-column
|
||||
max-column
|
||||
start)
|
||||
"Decode and unfold STRING as structured field body.
|
||||
It decodes non us-ascii characters in FULL-NAME encoded as
|
||||
encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
|
||||
characters are regarded as variable `default-mime-charset'.
|
||||
|
||||
If an encoded-word is broken or your emacs implementation can not
|
||||
decode the charset included in it, it is not decoded."
|
||||
(let ((tokens (eword-lexical-analyze string start 'must-unfold))
|
||||
(result ""))
|
||||
(while tokens
|
||||
(let* ((token (car tokens))
|
||||
(type (car token)))
|
||||
(setq tokens (cdr tokens))
|
||||
(setq result
|
||||
(if (eq type 'spaces)
|
||||
(concat result " ")
|
||||
(concat result (eword-decode-token token))
|
||||
))))
|
||||
result))
|
||||
|
||||
(defun eword-decode-and-fold-structured-field-body (string
|
||||
start-column
|
||||
&optional max-column
|
||||
start)
|
||||
(if (and mime-field-decoding-max-size
|
||||
(> (length string) mime-field-decoding-max-size))
|
||||
string
|
||||
(or max-column
|
||||
(setq max-column fill-column))
|
||||
(let ((c start-column)
|
||||
(tokens (eword-lexical-analyze string start 'must-unfold))
|
||||
(result "")
|
||||
token)
|
||||
(while (and (setq token (car tokens))
|
||||
(setq tokens (cdr tokens)))
|
||||
(let* ((type (car token)))
|
||||
(if (eq type 'spaces)
|
||||
(let* ((next-token (car tokens))
|
||||
(next-str (eword-decode-token next-token))
|
||||
(next-len (string-width next-str))
|
||||
(next-c (+ c next-len 1)))
|
||||
(if (< next-c max-column)
|
||||
(setq result (concat result " " next-str)
|
||||
c next-c)
|
||||
(setq result (concat result "\n " next-str)
|
||||
c (1+ next-len)))
|
||||
(setq tokens (cdr tokens))
|
||||
)
|
||||
(let* ((str (eword-decode-token token)))
|
||||
(setq result (concat result str)
|
||||
c (+ c (string-width str)))
|
||||
))))
|
||||
(if token
|
||||
(concat result (eword-decode-token token))
|
||||
result))))
|
||||
|
||||
(defun eword-decode-unstructured-field-body (string &optional start-column
|
||||
max-column)
|
||||
(eword-decode-string
|
||||
(decode-mime-charset-string string default-mime-charset)))
|
||||
|
||||
(defun eword-decode-and-unfold-unstructured-field-body (string
|
||||
&optional start-column
|
||||
max-column)
|
||||
(eword-decode-string
|
||||
(decode-mime-charset-string (std11-unfold-string string)
|
||||
default-mime-charset)
|
||||
'must-unfold))
|
||||
|
||||
(defun eword-decode-unfolded-unstructured-field-body (string
|
||||
&optional start-column
|
||||
max-column)
|
||||
(eword-decode-string
|
||||
(decode-mime-charset-string string default-mime-charset)
|
||||
'must-unfold))
|
||||
|
||||
|
||||
;;; @ for region
|
||||
;;;
|
||||
|
||||
(defun eword-decode-region (start end &optional unfolding must-unfold)
|
||||
"Decode MIME encoded-words in region between START and END.
|
||||
|
||||
If UNFOLDING is not nil, it unfolds before decoding.
|
||||
|
||||
If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
|
||||
if there are in decoded encoded-words (generated by bad manner MUA
|
||||
such as a version of Net$cape)."
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(if unfolding
|
||||
(eword-decode-unfold))
|
||||
(goto-char (point-min))
|
||||
(let ((regexp (concat "[\n\t ]*\\(" eword-encoded-word-regexp "\\)"))
|
||||
match words)
|
||||
(while (setq match (re-search-forward regexp nil t))
|
||||
(setq start (match-beginning 1)
|
||||
words nil)
|
||||
(while match
|
||||
(goto-char (setq end (match-end 0)))
|
||||
(push (list (match-string 2) ;; charset
|
||||
(match-string 3) ;; language
|
||||
(match-string 4) ;; encoding
|
||||
(match-string 5) ;; encoded-text
|
||||
(match-string 1)) ;; encoded-word
|
||||
words)
|
||||
(setq match (looking-at regexp)))
|
||||
(delete-region start end)
|
||||
(insert
|
||||
(eword-decode-encoded-words (nreverse words) must-unfold)))))))
|
||||
|
||||
(defun eword-decode-unfold ()
|
||||
(goto-char (point-min))
|
||||
(let (field beg end)
|
||||
(while (re-search-forward std11-field-head-regexp nil t)
|
||||
(setq beg (match-beginning 0)
|
||||
end (std11-field-end))
|
||||
(setq field (buffer-substring beg end))
|
||||
(if (string-match eword-encoded-word-regexp field)
|
||||
(save-restriction
|
||||
(narrow-to-region (goto-char beg) end)
|
||||
(while (re-search-forward "\n\\([ \t]\\)" nil t)
|
||||
(replace-match (match-string 1))
|
||||
)
|
||||
(goto-char (point-max))
|
||||
))
|
||||
)))
|
||||
|
||||
|
||||
;;; @ for message header
|
||||
;;;
|
||||
|
||||
(defvar mime-field-decoder-alist nil)
|
||||
|
||||
(defvar mime-field-decoder-cache nil)
|
||||
|
||||
(defvar mime-update-field-decoder-cache 'mime-update-field-decoder-cache
|
||||
"*Field decoder cache update function.")
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-set-field-decoder (field &rest specs)
|
||||
"Set decoder of FIELD.
|
||||
SPECS must be like `MODE1 DECODER1 MODE2 DECODER2 ...'.
|
||||
Each mode must be `nil', `plain', `wide', `summary' or `nov'.
|
||||
If mode is `nil', corresponding decoder is set up for every modes."
|
||||
(when specs
|
||||
(let ((mode (pop specs))
|
||||
(function (pop specs)))
|
||||
(if mode
|
||||
(progn
|
||||
(let ((cell (assq mode mime-field-decoder-alist)))
|
||||
(if cell
|
||||
(setcdr cell (put-alist field function (cdr cell)))
|
||||
(setq mime-field-decoder-alist
|
||||
(cons (cons mode (list (cons field function)))
|
||||
mime-field-decoder-alist))
|
||||
))
|
||||
(apply (function mime-set-field-decoder) field specs)
|
||||
)
|
||||
(mime-set-field-decoder field
|
||||
'plain function
|
||||
'wide function
|
||||
'summary function
|
||||
'nov function)
|
||||
))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro mime-find-field-presentation-method (name)
|
||||
"Return field-presentation-method from NAME.
|
||||
NAME must be `plain', `wide', `summary' or `nov'."
|
||||
(cond ((eq name nil)
|
||||
`(or (assq 'summary mime-field-decoder-cache)
|
||||
'(summary))
|
||||
)
|
||||
((and (consp name)
|
||||
(car name)
|
||||
(consp (cdr name))
|
||||
(symbolp (car (cdr name)))
|
||||
(null (cdr (cdr name))))
|
||||
`(or (assq ,name mime-field-decoder-cache)
|
||||
(cons ,name nil))
|
||||
)
|
||||
(t
|
||||
`(or (assq (or ,name 'summary) mime-field-decoder-cache)
|
||||
(cons (or ,name 'summary) nil))
|
||||
)))
|
||||
|
||||
(defun mime-find-field-decoder-internal (field &optional mode)
|
||||
"Return function to decode field-body of FIELD in MODE.
|
||||
Optional argument MODE must be object of field-presentation-method."
|
||||
(cdr (or (assq field (cdr mode))
|
||||
(prog1
|
||||
(funcall mime-update-field-decoder-cache
|
||||
field (car mode))
|
||||
(setcdr mode
|
||||
(cdr (assq (car mode) mime-field-decoder-cache)))
|
||||
))))
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-find-field-decoder (field &optional mode)
|
||||
"Return function to decode field-body of FIELD in MODE.
|
||||
Optional argument MODE must be object or name of
|
||||
field-presentation-method. Name of field-presentation-method must be
|
||||
`plain', `wide', `summary' or `nov'.
|
||||
Default value of MODE is `summary'."
|
||||
(if (symbolp mode)
|
||||
(let ((p (cdr (mime-find-field-presentation-method mode))))
|
||||
(if (and p (setq p (assq field p)))
|
||||
(cdr p)
|
||||
(cdr (funcall mime-update-field-decoder-cache
|
||||
field (or mode 'summary)))))
|
||||
(inline (mime-find-field-decoder-internal field mode))
|
||||
))
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-update-field-decoder-cache (field mode &optional function)
|
||||
"Update field decoder cache `mime-field-decoder-cache'."
|
||||
(cond ((eq function 'identity)
|
||||
(setq function nil)
|
||||
)
|
||||
((null function)
|
||||
(let ((decoder-alist
|
||||
(cdr (assq (or mode 'summary) mime-field-decoder-alist))))
|
||||
(setq function (cdr (or (assq field decoder-alist)
|
||||
(assq t decoder-alist)))))
|
||||
))
|
||||
(let ((cell (assq mode mime-field-decoder-cache))
|
||||
ret)
|
||||
(if cell
|
||||
(if (setq ret (assq field (cdr cell)))
|
||||
(setcdr ret function)
|
||||
(setcdr cell (cons (setq ret (cons field function)) (cdr cell))))
|
||||
(setq mime-field-decoder-cache
|
||||
(cons (cons mode (list (setq ret (cons field function))))
|
||||
mime-field-decoder-cache)))
|
||||
ret))
|
||||
|
||||
;; ignored fields
|
||||
(mime-set-field-decoder 'Archive nil nil)
|
||||
(mime-set-field-decoder 'Content-Md5 nil nil)
|
||||
(mime-set-field-decoder 'Control nil nil)
|
||||
(mime-set-field-decoder 'Date nil nil)
|
||||
(mime-set-field-decoder 'Distribution nil nil)
|
||||
(mime-set-field-decoder 'Followup-Host nil nil)
|
||||
(mime-set-field-decoder 'Followup-To nil nil)
|
||||
(mime-set-field-decoder 'Lines nil nil)
|
||||
(mime-set-field-decoder 'Message-Id nil nil)
|
||||
(mime-set-field-decoder 'Newsgroups nil nil)
|
||||
(mime-set-field-decoder 'Nntp-Posting-Host nil nil)
|
||||
(mime-set-field-decoder 'Path nil nil)
|
||||
(mime-set-field-decoder 'Posted-And-Mailed nil nil)
|
||||
(mime-set-field-decoder 'Received nil nil)
|
||||
(mime-set-field-decoder 'Status nil nil)
|
||||
(mime-set-field-decoder 'X-Face nil nil)
|
||||
(mime-set-field-decoder 'X-Face-Version nil nil)
|
||||
(mime-set-field-decoder 'X-Info nil nil)
|
||||
(mime-set-field-decoder 'X-Pgp-Key-Info nil nil)
|
||||
(mime-set-field-decoder 'X-Pgp-Sig nil nil)
|
||||
(mime-set-field-decoder 'X-Pgp-Sig-Version nil nil)
|
||||
(mime-set-field-decoder 'Xref nil nil)
|
||||
|
||||
;; structured fields
|
||||
(let ((fields
|
||||
'(Reply-To Resent-Reply-To From Resent-From Sender Resent-Sender
|
||||
To Resent-To Cc Resent-Cc Bcc Resent-Bcc Dcc
|
||||
Mail-Followup-To
|
||||
Mime-Version Content-Type Content-Transfer-Encoding
|
||||
Content-Disposition User-Agent))
|
||||
field)
|
||||
(while fields
|
||||
(setq field (pop fields))
|
||||
(mime-set-field-decoder
|
||||
field
|
||||
'plain #'eword-decode-structured-field-body
|
||||
'wide #'eword-decode-and-fold-structured-field-body
|
||||
'summary #'eword-decode-and-unfold-structured-field-body
|
||||
'nov #'eword-decode-and-unfold-structured-field-body)
|
||||
))
|
||||
|
||||
;; unstructured fields (default)
|
||||
(mime-set-field-decoder
|
||||
t
|
||||
'plain #'eword-decode-unstructured-field-body
|
||||
'wide #'eword-decode-unstructured-field-body
|
||||
'summary #'eword-decode-and-unfold-unstructured-field-body
|
||||
'nov #'eword-decode-unfolded-unstructured-field-body)
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-decode-field-body (field-body field-name
|
||||
&optional mode max-column)
|
||||
"Decode FIELD-BODY as FIELD-NAME in MODE, and return the result.
|
||||
Optional argument MODE must be `plain', `wide', `summary' or `nov'.
|
||||
Default mode is `summary'.
|
||||
|
||||
If MODE is `wide' and MAX-COLUMN is non-nil, the result is folded with
|
||||
MAX-COLUMN.
|
||||
|
||||
Non MIME encoded-word part in FILED-BODY is decoded with
|
||||
`default-mime-charset'."
|
||||
(let (field-name-symbol len decoder)
|
||||
(if (symbolp field-name)
|
||||
(setq field-name-symbol field-name
|
||||
len (1+ (string-width (symbol-name field-name))))
|
||||
(setq field-name-symbol (intern (capitalize field-name))
|
||||
len (1+ (string-width field-name))))
|
||||
(setq decoder (mime-find-field-decoder field-name-symbol mode))
|
||||
(if decoder
|
||||
(funcall decoder field-body len max-column)
|
||||
;; Don't decode
|
||||
(if (eq mode 'summary)
|
||||
(std11-unfold-string field-body)
|
||||
field-body)
|
||||
)))
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-decode-header-in-region (start end
|
||||
&optional code-conversion)
|
||||
"Decode MIME encoded-words in region between START and END.
|
||||
If CODE-CONVERSION is nil, it decodes only encoded-words. If it is
|
||||
mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
|
||||
Otherwise it decodes non-ASCII bit patterns as the
|
||||
default-mime-charset."
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(let ((default-charset
|
||||
(if code-conversion
|
||||
(if (mime-charset-to-coding-system code-conversion)
|
||||
code-conversion
|
||||
default-mime-charset))))
|
||||
(if default-charset
|
||||
(let ((mode-obj (mime-find-field-presentation-method 'wide))
|
||||
beg p end field-name len field-decoder)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward std11-field-head-regexp nil t)
|
||||
(setq beg (match-beginning 0)
|
||||
p (match-end 0)
|
||||
field-name (buffer-substring beg (1- p))
|
||||
len (string-width field-name)
|
||||
field-name (intern (capitalize field-name))
|
||||
field-decoder (inline
|
||||
(mime-find-field-decoder-internal
|
||||
field-name mode-obj)))
|
||||
(when field-decoder
|
||||
(setq end (std11-field-end))
|
||||
(let ((body (buffer-substring p end))
|
||||
(default-mime-charset default-charset))
|
||||
(delete-region p end)
|
||||
(insert (funcall field-decoder body (1+ len)))
|
||||
))
|
||||
))
|
||||
(eword-decode-region (point-min) (point-max) t)
|
||||
)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-decode-header-in-buffer (&optional code-conversion separator)
|
||||
"Decode MIME encoded-words in header fields.
|
||||
If CODE-CONVERSION is nil, it decodes only encoded-words. If it is
|
||||
mime-charset, it decodes non-ASCII bit patterns as the mime-charset.
|
||||
Otherwise it decodes non-ASCII bit patterns as the
|
||||
default-mime-charset.
|
||||
If SEPARATOR is not nil, it is used as header separator."
|
||||
(interactive "*")
|
||||
(mime-decode-header-in-region
|
||||
(point-min)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(if (re-search-forward
|
||||
(concat "^\\(" (regexp-quote (or separator "")) "\\)?$")
|
||||
nil t)
|
||||
(match-beginning 0)
|
||||
(point-max)
|
||||
))
|
||||
code-conversion))
|
||||
|
||||
(defalias 'eword-decode-header 'mime-decode-header-in-buffer)
|
||||
(make-obsolete 'eword-decode-header 'mime-decode-header-in-buffer)
|
||||
|
||||
|
||||
;;; @ encoded-words decoder
|
||||
;;;
|
||||
|
||||
(defvar eword-decode-allow-incomplete-encoded-text t
|
||||
"*Non-nil means allow incomplete encoded-text in successive encoded-words.
|
||||
Dividing of encoded-text in the place other than character boundaries
|
||||
violates RFC2047 section 5, while we have a capability to decode it.
|
||||
If it is non-nil, the decoder will decode B- or Q-encoding in each
|
||||
encoded-word, concatenate them, and decode it by charset. Otherwise,
|
||||
the decoder will fully decode each encoded-word before concatenating
|
||||
them.")
|
||||
|
||||
(defun eword-decode-encoded-words (words must-unfold)
|
||||
"Decode successive encoded-words in WORDS and return a decoded string.
|
||||
Each element of WORDS looks like (CHARSET LANGUAGE ENCODING ENCODED-TEXT
|
||||
ENCODED-WORD).
|
||||
|
||||
If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even
|
||||
if there are in decoded encoded-words (generated by bad manner MUA
|
||||
such as a version of Net$cape)."
|
||||
(let (word language charset encoding text rest)
|
||||
(while words
|
||||
(setq word (pop words)
|
||||
language (nth 1 word))
|
||||
(if (and (or (mime-charset-to-coding-system (setq charset (car word)))
|
||||
(progn
|
||||
(message "Unknown charset: %s" charset)
|
||||
nil))
|
||||
(cond ((member (setq encoding (nth 2 word)) '("B" "Q"))
|
||||
t)
|
||||
((member encoding '("b" "q"))
|
||||
(setq encoding (upcase encoding)))
|
||||
(t
|
||||
(message "Invalid encoding: %s" encoding)
|
||||
nil))
|
||||
(condition-case err
|
||||
(setq text
|
||||
(encoded-text-decode-string (nth 3 word) encoding))
|
||||
(error
|
||||
(message "%s" (error-message-string err))
|
||||
nil)))
|
||||
(if (and eword-decode-allow-incomplete-encoded-text
|
||||
rest
|
||||
(caaar rest)
|
||||
(string-equal (downcase charset) (downcase (caaar rest)))
|
||||
(equal language (cdaar rest)))
|
||||
;; Concatenate text of which the charset is the same.
|
||||
(setcdr (car rest) (concat (cdar rest) text))
|
||||
(push (cons (cons charset language) text) rest))
|
||||
;; Don't decode encoded-word.
|
||||
(push (cons (cons nil language) (nth 4 word)) rest)))
|
||||
(while rest
|
||||
(setq word (or (and (setq charset (caaar rest))
|
||||
(condition-case err
|
||||
(decode-mime-charset-string (cdar rest) charset)
|
||||
(error
|
||||
(message "%s" (error-message-string err))
|
||||
nil)))
|
||||
(concat (when (cdr rest) " ")
|
||||
(cdar rest)
|
||||
(when (and words
|
||||
(not (eq (string-to-char words) ? )))
|
||||
" "))))
|
||||
(when must-unfold
|
||||
(setq word (mapconcat (lambda (chr)
|
||||
(cond ((eq chr ?\n) "")
|
||||
((eq chr ?\r) "")
|
||||
((eq chr ?\t) " ")
|
||||
(t (char-to-string chr))))
|
||||
(std11-unfold-string word)
|
||||
"")))
|
||||
(when (setq language (cdaar rest))
|
||||
(put-text-property 0 (length word) 'mime-language language word))
|
||||
(setq words (concat word words)
|
||||
rest (cdr rest)))
|
||||
words))
|
||||
|
||||
;;; @ lexical analyze
|
||||
;;;
|
||||
|
||||
(defvar eword-lexical-analyze-cache nil)
|
||||
(defvar eword-lexical-analyze-cache-max 299
|
||||
"*Max position of eword-lexical-analyze-cache.
|
||||
It is max size of eword-lexical-analyze-cache - 1.")
|
||||
|
||||
(defvar mime-header-lexical-analyzer
|
||||
'(eword-analyze-quoted-string
|
||||
eword-analyze-domain-literal
|
||||
eword-analyze-comment
|
||||
eword-analyze-spaces
|
||||
eword-analyze-special
|
||||
eword-analyze-encoded-word
|
||||
eword-analyze-atom)
|
||||
"*List of functions to return result of lexical analyze.
|
||||
Each function must have three arguments: STRING, START and MUST-UNFOLD.
|
||||
STRING is the target string to be analyzed.
|
||||
START is start position of STRING to analyze.
|
||||
If MUST-UNFOLD is not nil, each function must unfold and eliminate
|
||||
bare-CR and bare-LF from the result even if they are included in
|
||||
content of the encoded-word.
|
||||
Each function must return nil if it can not analyze STRING as its
|
||||
format.
|
||||
|
||||
Previous function is preferred to next function. If a function
|
||||
returns nil, next function is used. Otherwise the return value will
|
||||
be the result.")
|
||||
|
||||
(defun eword-analyze-quoted-string (string start &optional must-unfold)
|
||||
(let ((p (std11-check-enclosure string ?\" ?\" nil start))
|
||||
ret)
|
||||
(when p
|
||||
(setq ret (decode-mime-charset-string
|
||||
(std11-strip-quoted-pair
|
||||
(substring string (1+ start) (1- p)))
|
||||
default-mime-charset))
|
||||
(if mime-header-accept-quoted-encoded-words
|
||||
(setq ret (eword-decode-string ret)))
|
||||
(cons (cons 'quoted-string ret)
|
||||
p))))
|
||||
|
||||
(defun eword-analyze-domain-literal (string start &optional must-unfold)
|
||||
(std11-analyze-domain-literal string start))
|
||||
|
||||
(defun eword-analyze-comment (string from &optional must-unfold)
|
||||
(let ((len (length string))
|
||||
(i (or from 0))
|
||||
dest last-str
|
||||
chr ret)
|
||||
(when (and (> len i)
|
||||
(eq (aref string i) ?\())
|
||||
(setq i (1+ i)
|
||||
from i)
|
||||
(catch 'tag
|
||||
(while (< i len)
|
||||
(setq chr (aref string i))
|
||||
(cond ((eq chr ?\\)
|
||||
(setq i (1+ i))
|
||||
(if (>= i len)
|
||||
(throw 'tag nil)
|
||||
)
|
||||
(setq last-str (concat last-str
|
||||
(substring string from (1- i))
|
||||
(char-to-string (aref string i)))
|
||||
i (1+ i)
|
||||
from i)
|
||||
)
|
||||
((eq chr ?\))
|
||||
(setq ret (concat last-str
|
||||
(substring string from i)))
|
||||
(throw 'tag (cons
|
||||
(cons 'comment
|
||||
(nreverse
|
||||
(if (string= ret "")
|
||||
dest
|
||||
(cons
|
||||
(eword-decode-string
|
||||
(decode-mime-charset-string
|
||||
ret default-mime-charset)
|
||||
must-unfold)
|
||||
dest)
|
||||
)))
|
||||
(1+ i)))
|
||||
)
|
||||
((eq chr ?\()
|
||||
(if (setq ret (eword-analyze-comment string i must-unfold))
|
||||
(setq last-str
|
||||
(concat last-str
|
||||
(substring string from i))
|
||||
dest
|
||||
(if (string= last-str "")
|
||||
(cons (car ret) dest)
|
||||
(list* (car ret)
|
||||
(eword-decode-string
|
||||
(decode-mime-charset-string
|
||||
last-str default-mime-charset)
|
||||
must-unfold)
|
||||
dest)
|
||||
)
|
||||
i (cdr ret)
|
||||
from i
|
||||
last-str "")
|
||||
(throw 'tag nil)
|
||||
))
|
||||
(t
|
||||
(setq i (1+ i))
|
||||
))
|
||||
)))))
|
||||
|
||||
(defun eword-analyze-spaces (string start &optional must-unfold)
|
||||
(std11-analyze-spaces string start))
|
||||
|
||||
(defun eword-analyze-special (string start &optional must-unfold)
|
||||
(std11-analyze-special string start))
|
||||
|
||||
(defun eword-analyze-encoded-word (string start &optional must-unfold)
|
||||
(let* ((regexp (concat "[\n\t ]*\\(" eword-encoded-word-regexp "\\)"))
|
||||
(match (and (string-match regexp string start)
|
||||
(= start (match-beginning 0))))
|
||||
next words)
|
||||
(while match
|
||||
(setq next (match-end 0))
|
||||
(push (list (match-string 2 string) ;; charset
|
||||
(match-string 3 string) ;; language
|
||||
(match-string 4 string) ;; encoding
|
||||
(match-string 5 string) ;; encoded-text
|
||||
(match-string 1 string)) ;; encoded-word
|
||||
words)
|
||||
(setq match (and (string-match regexp string next)
|
||||
(= next (match-beginning 0)))))
|
||||
(when words
|
||||
(cons (cons 'atom (eword-decode-encoded-words (nreverse words)
|
||||
must-unfold))
|
||||
next))))
|
||||
|
||||
(defun eword-analyze-atom (string start &optional must-unfold)
|
||||
(if (and (string-match std11-atom-regexp string start)
|
||||
(= (match-beginning 0) start))
|
||||
(let ((end (match-end 0)))
|
||||
(cons (cons 'atom (decode-mime-charset-string
|
||||
(substring string start end)
|
||||
default-mime-charset))
|
||||
;;(substring string end)
|
||||
end)
|
||||
)))
|
||||
|
||||
(defun eword-lexical-analyze-internal (string start must-unfold)
|
||||
(let ((len (length string))
|
||||
dest ret)
|
||||
(while (< start len)
|
||||
(setq ret
|
||||
(let ((rest mime-header-lexical-analyzer)
|
||||
func r)
|
||||
(while (and (setq func (car rest))
|
||||
(null
|
||||
(setq r (funcall func string start must-unfold)))
|
||||
)
|
||||
(setq rest (cdr rest)))
|
||||
(or r
|
||||
(cons (cons 'error (substring string start)) (1+ len)))
|
||||
))
|
||||
(setq dest (cons (car ret) dest)
|
||||
start (cdr ret))
|
||||
)
|
||||
(nreverse dest)
|
||||
))
|
||||
|
||||
(defun eword-lexical-analyze (string &optional start must-unfold)
|
||||
"Return lexical analyzed list corresponding STRING.
|
||||
It is like std11-lexical-analyze, but it decodes non us-ascii
|
||||
characters encoded as encoded-words or invalid \"raw\" format.
|
||||
\"Raw\" non us-ascii characters are regarded as variable
|
||||
`default-mime-charset'."
|
||||
(let ((key (substring string (or start 0)))
|
||||
ret cell)
|
||||
(set-text-properties 0 (length key) nil key)
|
||||
(if (setq ret (assoc key eword-lexical-analyze-cache))
|
||||
(cdr ret)
|
||||
(setq ret (eword-lexical-analyze-internal key 0 must-unfold))
|
||||
(setq eword-lexical-analyze-cache
|
||||
(cons (cons key ret)
|
||||
eword-lexical-analyze-cache))
|
||||
(if (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max
|
||||
eword-lexical-analyze-cache)))
|
||||
(setcdr cell nil))
|
||||
ret)))
|
||||
|
||||
(defun eword-decode-token (token)
|
||||
(let ((type (car token))
|
||||
(value (cdr token)))
|
||||
(cond ((eq type 'quoted-string)
|
||||
(std11-wrap-as-quoted-string value))
|
||||
((eq type 'comment)
|
||||
(let ((dest ""))
|
||||
(while value
|
||||
(setq dest (concat dest
|
||||
(if (stringp (car value))
|
||||
(std11-wrap-as-quoted-pairs
|
||||
(car value) '(?( ?)))
|
||||
(eword-decode-token (car value))
|
||||
))
|
||||
value (cdr value))
|
||||
)
|
||||
(concat "(" dest ")")
|
||||
))
|
||||
(t value))))
|
||||
|
||||
(defun eword-extract-address-components (string &optional start)
|
||||
"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.
|
||||
It decodes non us-ascii characters in FULL-NAME encoded as
|
||||
encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii
|
||||
characters are regarded as variable `default-mime-charset'."
|
||||
(let* ((structure (car (std11-parse-address
|
||||
(eword-lexical-analyze
|
||||
(std11-unfold-string string) start
|
||||
'must-unfold))))
|
||||
(phrase (std11-full-name-string structure))
|
||||
(address (std11-address-string structure))
|
||||
)
|
||||
(list phrase address)
|
||||
))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'eword-decode)
|
||||
|
||||
;;; eword-decode.el ends here
|
||||
726
flim-1.14.9/eword-encode.el
Normal file
726
flim-1.14.9/eword-encode.el
Normal file
@ -0,0 +1,726 @@
|
||||
;;; eword-encode.el --- RFC 2047 based encoded-word encoder for GNU Emacs
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999,2000,2002,2003,2004 Free
|
||||
;; Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: encoded-word, MIME, multilingual, header, mail, news
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(require 'mel)
|
||||
(require 'std11)
|
||||
(require 'eword-decode)
|
||||
|
||||
|
||||
;;; @ variables
|
||||
;;;
|
||||
|
||||
;; User options are defined in mime-def.el.
|
||||
|
||||
(defvar mime-header-charset-encoding-alist
|
||||
'((us-ascii . nil)
|
||||
(iso-8859-1 . "Q")
|
||||
(iso-8859-2 . "Q")
|
||||
(iso-8859-3 . "Q")
|
||||
(iso-8859-4 . "Q")
|
||||
(iso-8859-5 . "Q")
|
||||
(koi8-r . "Q")
|
||||
(iso-8859-7 . "Q")
|
||||
(iso-8859-8 . "Q")
|
||||
(iso-8859-9 . "Q")
|
||||
(iso-8859-14 . "Q")
|
||||
(iso-8859-15 . "Q")
|
||||
(iso-2022-jp . "B")
|
||||
(iso-2022-jp-3 . "B")
|
||||
(iso-2022-kr . "B")
|
||||
(gb2312 . "B")
|
||||
(cn-gb . "B")
|
||||
(cn-gb-2312 . "B")
|
||||
(euc-kr . "B")
|
||||
(tis-620 . "B")
|
||||
(iso-2022-jp-2 . "B")
|
||||
(iso-2022-int-1 . "B")
|
||||
(utf-8 . "B")
|
||||
))
|
||||
|
||||
(defvar mime-header-default-charset-encoding "Q")
|
||||
|
||||
(defvar mime-header-encode-method-alist
|
||||
'((eword-encode-address-list
|
||||
. (Reply-To
|
||||
From Sender
|
||||
Resent-Reply-To Resent-From
|
||||
Resent-Sender To Resent-To
|
||||
Cc Resent-Cc Bcc Resent-Bcc
|
||||
Dcc))
|
||||
(eword-encode-in-reply-to . (In-Reply-To))
|
||||
(eword-encode-structured-field-body . (Mime-Version User-Agent))
|
||||
(eword-encode-unstructured-field-body)))
|
||||
|
||||
;;; @ encoded-text encoder
|
||||
;;;
|
||||
|
||||
(defun eword-encode-text (charset encoding string &optional mode)
|
||||
"Encode STRING as an encoded-word, and return the result.
|
||||
CHARSET is a symbol to indicate MIME charset of the encoded-word.
|
||||
ENCODING allows \"B\" or \"Q\".
|
||||
MODE is allows `text', `comment', `phrase' or nil. Default value is
|
||||
`phrase'."
|
||||
(let ((text (encoded-text-encode-string string encoding mode)))
|
||||
(if text
|
||||
(concat "=?" (upcase (symbol-name charset)) "?"
|
||||
encoding "?" text "?=")
|
||||
)))
|
||||
|
||||
|
||||
;;; @ charset word
|
||||
;;;
|
||||
|
||||
(defsubst eword-encode-char-type (character)
|
||||
(if (memq character '(? ?\t ?\n))
|
||||
nil
|
||||
(char-charset character)
|
||||
))
|
||||
|
||||
(defun eword-encode-divide-into-charset-words (string)
|
||||
(let ((len (length string))
|
||||
dest)
|
||||
(while (> len 0)
|
||||
(let* ((chr (aref string 0))
|
||||
;; (chr (sref string 0))
|
||||
(charset (eword-encode-char-type chr))
|
||||
(i 1)
|
||||
;; (i (char-length chr))
|
||||
)
|
||||
(while (and (< i len)
|
||||
(setq chr (aref string i))
|
||||
;; (setq chr (sref string i))
|
||||
(eq charset (eword-encode-char-type chr)))
|
||||
(setq i (1+ i))
|
||||
;; (setq i (char-next-index chr i))
|
||||
)
|
||||
(setq dest (cons (cons charset (substring string 0 i)) dest)
|
||||
string (substring string i)
|
||||
len (- len i))))
|
||||
(nreverse dest)))
|
||||
|
||||
|
||||
;;; @ word
|
||||
;;;
|
||||
|
||||
(defun eword-encode-charset-words-to-words (charset-words)
|
||||
(let (dest)
|
||||
(while charset-words
|
||||
(let* ((charset-word (car charset-words))
|
||||
(charset (car charset-word))
|
||||
)
|
||||
(if charset
|
||||
(let ((charsets (list charset))
|
||||
(str (cdr charset-word))
|
||||
)
|
||||
(catch 'tag
|
||||
(while (setq charset-words (cdr charset-words))
|
||||
(setq charset-word (car charset-words)
|
||||
charset (car charset-word))
|
||||
(if (null charset)
|
||||
(throw 'tag nil)
|
||||
)
|
||||
(or (memq charset charsets)
|
||||
(setq charsets (cons charset charsets))
|
||||
)
|
||||
(setq str (concat str (cdr charset-word)))
|
||||
))
|
||||
(setq dest (cons (cons charsets str) dest))
|
||||
)
|
||||
(setq dest (cons charset-word dest)
|
||||
charset-words (cdr charset-words)
|
||||
))))
|
||||
(nreverse dest)
|
||||
))
|
||||
|
||||
|
||||
;;; @ rule
|
||||
;;;
|
||||
|
||||
(defmacro make-ew-rword (text charset encoding type)
|
||||
(` (list (, text)(, charset)(, encoding)(, type))))
|
||||
(defmacro ew-rword-text (rword)
|
||||
(` (car (, rword))))
|
||||
(defmacro ew-rword-charset (rword)
|
||||
(` (car (cdr (, rword)))))
|
||||
(defmacro ew-rword-encoding (rword)
|
||||
(` (car (cdr (cdr (, rword))))))
|
||||
(defmacro ew-rword-type (rword)
|
||||
(` (car (cdr (cdr (cdr (, rword)))))))
|
||||
|
||||
(defun ew-find-charset-rule (charsets)
|
||||
(if charsets
|
||||
(let* ((charset (find-mime-charset-by-charsets charsets))
|
||||
(encoding
|
||||
(cdr (or (assq charset mime-header-charset-encoding-alist)
|
||||
(cons charset mime-header-default-charset-encoding)))))
|
||||
(list charset encoding))))
|
||||
|
||||
;; [tomo:2002-11-05] The following code is a quick-fix for emacsen
|
||||
;; which is not depended on the Mule model. We should redesign
|
||||
;; `eword-encode-split-string' to avoid to depend on the Mule model.
|
||||
(if (featurep 'utf-2000)
|
||||
;; for CHISE Architecture
|
||||
(defun tm-eword::words-to-ruled-words (wl &optional mode)
|
||||
(let (mcs)
|
||||
(mapcar (function
|
||||
(lambda (word)
|
||||
(setq mcs (detect-mime-charset-string (cdr word)))
|
||||
(make-ew-rword
|
||||
(cdr word)
|
||||
mcs
|
||||
(cdr (or (assq mcs mime-header-charset-encoding-alist)
|
||||
(cons mcs mime-header-default-charset-encoding)))
|
||||
mode)
|
||||
))
|
||||
wl)))
|
||||
|
||||
;; for legacy Mule
|
||||
(defun tm-eword::words-to-ruled-words (wl &optional mode)
|
||||
(mapcar (function
|
||||
(lambda (word)
|
||||
(let ((ret (ew-find-charset-rule (car word))))
|
||||
(make-ew-rword (cdr word) (car ret)(nth 1 ret) mode)
|
||||
)))
|
||||
wl))
|
||||
)
|
||||
|
||||
(defun ew-space-process (seq)
|
||||
(let (prev a ac b c cc)
|
||||
(while seq
|
||||
(setq b (car seq))
|
||||
(setq seq (cdr seq))
|
||||
(setq c (car seq))
|
||||
(setq cc (ew-rword-charset c))
|
||||
(if (and (null (ew-rword-charset b))
|
||||
(not (eq (ew-rword-type b) 'special)))
|
||||
(progn
|
||||
(setq a (car prev))
|
||||
(setq ac (ew-rword-charset a))
|
||||
(if (and (ew-rword-encoding a)
|
||||
(ew-rword-encoding c))
|
||||
(cond ((eq ac cc)
|
||||
(setq prev (cons
|
||||
(cons (concat (car a)(car b)(car c))
|
||||
(cdr a))
|
||||
(cdr prev)
|
||||
))
|
||||
(setq seq (cdr seq))
|
||||
)
|
||||
(t
|
||||
(setq prev (cons
|
||||
(cons (concat (car a)(car b))
|
||||
(cdr a))
|
||||
(cdr prev)
|
||||
))
|
||||
))
|
||||
(setq prev (cons b prev))
|
||||
))
|
||||
(setq prev (cons b prev))
|
||||
))
|
||||
(reverse prev)
|
||||
))
|
||||
|
||||
(defun eword-encode-split-string (str &optional mode)
|
||||
(ew-space-process
|
||||
(tm-eword::words-to-ruled-words
|
||||
(eword-encode-charset-words-to-words
|
||||
(eword-encode-divide-into-charset-words str))
|
||||
mode)))
|
||||
|
||||
|
||||
;;; @ length
|
||||
;;;
|
||||
|
||||
(defun tm-eword::encoded-word-length (rword)
|
||||
(let ((string (ew-rword-text rword))
|
||||
(charset (ew-rword-charset rword))
|
||||
(encoding (ew-rword-encoding rword))
|
||||
ret)
|
||||
(setq ret
|
||||
(cond ((string-equal encoding "B")
|
||||
(setq string (encode-mime-charset-string string charset))
|
||||
(base64-encoded-length string)
|
||||
)
|
||||
((string-equal encoding "Q")
|
||||
(setq string (encode-mime-charset-string string charset))
|
||||
(Q-encoded-text-length string (ew-rword-type rword))
|
||||
)))
|
||||
(if ret
|
||||
(cons (+ 7 (length (symbol-name charset)) ret) string)
|
||||
)))
|
||||
|
||||
|
||||
;;; @ encode-string
|
||||
;;;
|
||||
|
||||
(defun ew-encode-rword-1 (column rwl &optional must-output)
|
||||
(catch 'can-not-output
|
||||
(let* ((rword (car rwl))
|
||||
(ret (tm-eword::encoded-word-length rword))
|
||||
string len)
|
||||
(if (null ret)
|
||||
(cond ((and (setq string (car rword))
|
||||
(or (<= (setq len (+ (length string) column)) 76)
|
||||
(<= column 1))
|
||||
)
|
||||
(setq rwl (cdr rwl))
|
||||
)
|
||||
((memq (aref string 0) '(? ?\t))
|
||||
(setq string (concat "\n" string)
|
||||
len (length string)
|
||||
rwl (cdr rwl))
|
||||
)
|
||||
(must-output
|
||||
(setq string "\n "
|
||||
len 1)
|
||||
)
|
||||
(t
|
||||
(throw 'can-not-output nil)
|
||||
))
|
||||
(cond ((and (setq len (car ret))
|
||||
(<= (+ column len) 76)
|
||||
)
|
||||
(setq string
|
||||
(eword-encode-text
|
||||
(ew-rword-charset rword)
|
||||
(ew-rword-encoding rword)
|
||||
(cdr ret)
|
||||
(ew-rword-type rword)
|
||||
))
|
||||
(setq len (+ (length string) column))
|
||||
(setq rwl (cdr rwl))
|
||||
)
|
||||
(t
|
||||
(setq string (car rword))
|
||||
(let* ((p 0) np
|
||||
(str "") nstr)
|
||||
(while (and (< p len)
|
||||
(progn
|
||||
(setq np (1+ p))
|
||||
;;(setq np (char-next-index (sref string p) p))
|
||||
(setq nstr (substring string 0 np))
|
||||
(setq ret (tm-eword::encoded-word-length
|
||||
(cons nstr (cdr rword))
|
||||
))
|
||||
(setq nstr (cdr ret))
|
||||
(setq len (+ (car ret) column))
|
||||
(<= len 76)
|
||||
))
|
||||
(setq str nstr
|
||||
p np))
|
||||
(if (string-equal str "")
|
||||
(if must-output
|
||||
(setq string "\n "
|
||||
len 1)
|
||||
(throw 'can-not-output nil))
|
||||
(setq rwl (cons (cons (substring string p) (cdr rword))
|
||||
(cdr rwl)))
|
||||
(setq string
|
||||
(eword-encode-text
|
||||
(ew-rword-charset rword)
|
||||
(ew-rword-encoding rword)
|
||||
str
|
||||
(ew-rword-type rword)))
|
||||
(setq len (+ (length string) column))
|
||||
)
|
||||
)))
|
||||
)
|
||||
(list string len rwl)
|
||||
)))
|
||||
|
||||
(defun eword-encode-rword-list (column rwl)
|
||||
(let (ret dest str ew-f pew-f folded-points)
|
||||
(while rwl
|
||||
(setq ew-f (nth 2 (car rwl)))
|
||||
(if (and pew-f ew-f)
|
||||
(setq rwl (cons '(" ") rwl)
|
||||
pew-f nil)
|
||||
(setq pew-f ew-f)
|
||||
)
|
||||
(if (null (setq ret (ew-encode-rword-1 column rwl)))
|
||||
(let ((i (1- (length dest)))
|
||||
c s r-dest r-column)
|
||||
(catch 'success
|
||||
(while (catch 'found
|
||||
(while (>= i 0)
|
||||
(cond ((memq (setq c (aref dest i)) '(? ?\t))
|
||||
(if (memq i folded-points)
|
||||
(throw 'found nil)
|
||||
(setq folded-points (cons i folded-points))
|
||||
(throw 'found i))
|
||||
)
|
||||
((eq c ?\n)
|
||||
(throw 'found nil)
|
||||
))
|
||||
(setq i (1- i))))
|
||||
(setq s (substring dest i)
|
||||
r-column (length s)
|
||||
r-dest (concat (substring dest 0 i) "\n" s))
|
||||
(when (setq ret (ew-encode-rword-1 r-column rwl))
|
||||
(setq dest r-dest
|
||||
column r-column)
|
||||
(throw 'success t)
|
||||
))
|
||||
(setq ret (ew-encode-rword-1 column rwl 'must-output))
|
||||
)))
|
||||
(setq str (car ret))
|
||||
(setq dest (concat dest str))
|
||||
(setq column (nth 1 ret)
|
||||
rwl (nth 2 ret))
|
||||
)
|
||||
(list dest column)
|
||||
))
|
||||
|
||||
|
||||
;;; @ converter
|
||||
;;;
|
||||
|
||||
(defun eword-encode-phrase-to-rword-list (phrase)
|
||||
(let (token type dest str)
|
||||
(while phrase
|
||||
(setq token (car phrase))
|
||||
(setq type (car token))
|
||||
(cond ((eq type 'quoted-string)
|
||||
(setq str (concat "\"" (cdr token) "\""))
|
||||
(setq dest
|
||||
(append dest
|
||||
(list
|
||||
(let ((ret (ew-find-charset-rule
|
||||
(find-charset-string str))))
|
||||
(make-ew-rword
|
||||
str (car ret)(nth 1 ret) 'phrase)
|
||||
)
|
||||
)))
|
||||
)
|
||||
((eq type 'comment)
|
||||
(setq dest
|
||||
(append dest
|
||||
'(("(" nil nil special))
|
||||
(tm-eword::words-to-ruled-words
|
||||
(eword-encode-charset-words-to-words
|
||||
(eword-encode-divide-into-charset-words
|
||||
(cdr token)))
|
||||
'comment)
|
||||
'((")" nil nil special))
|
||||
))
|
||||
)
|
||||
(t
|
||||
(setq dest
|
||||
(append dest
|
||||
(tm-eword::words-to-ruled-words
|
||||
(eword-encode-charset-words-to-words
|
||||
(eword-encode-divide-into-charset-words
|
||||
(cdr token))
|
||||
) 'phrase)))
|
||||
))
|
||||
(setq phrase (cdr phrase))
|
||||
)
|
||||
(ew-space-process dest)
|
||||
))
|
||||
|
||||
(defun eword-encode-addr-seq-to-rword-list (seq)
|
||||
(let (dest pname)
|
||||
(while seq
|
||||
(let* ((token (car seq))
|
||||
(name (car token))
|
||||
)
|
||||
(cond ((eq name 'spaces)
|
||||
(setq dest (nconc dest (list (list (cdr token) nil nil))))
|
||||
)
|
||||
((eq name 'comment)
|
||||
(setq dest
|
||||
(nconc
|
||||
dest
|
||||
(list (list "(" nil nil))
|
||||
(eword-encode-split-string (cdr token) 'comment)
|
||||
(list (list ")" nil nil))
|
||||
))
|
||||
)
|
||||
((eq name 'quoted-string)
|
||||
(setq dest
|
||||
(nconc
|
||||
dest
|
||||
(list
|
||||
(list (concat "\"" (cdr token) "\"") nil nil)
|
||||
)))
|
||||
)
|
||||
(t
|
||||
(setq dest
|
||||
(if (or (eq pname 'spaces)
|
||||
(eq pname 'comment))
|
||||
(nconc dest (list (list (cdr token) nil nil)))
|
||||
(nconc (nreverse (cdr (reverse dest)))
|
||||
;; (butlast dest)
|
||||
(list
|
||||
(list (concat (car (car (last dest)))
|
||||
(cdr token))
|
||||
nil nil)))))
|
||||
))
|
||||
(setq seq (cdr seq)
|
||||
pname name))
|
||||
)
|
||||
dest))
|
||||
|
||||
(defun eword-encode-phrase-route-addr-to-rword-list (phrase-route-addr)
|
||||
(if (eq (car phrase-route-addr) 'phrase-route-addr)
|
||||
(let ((phrase (nth 1 phrase-route-addr))
|
||||
(route (nth 2 phrase-route-addr))
|
||||
dest)
|
||||
;; (if (eq (car (car phrase)) 'spaces)
|
||||
;; (setq phrase (cdr phrase))
|
||||
;; )
|
||||
(setq dest (eword-encode-phrase-to-rword-list phrase))
|
||||
(if dest
|
||||
(setq dest (append dest '((" " nil nil))))
|
||||
)
|
||||
(append
|
||||
dest
|
||||
(eword-encode-addr-seq-to-rword-list
|
||||
(append '((specials . "<"))
|
||||
route
|
||||
'((specials . ">"))))
|
||||
))))
|
||||
|
||||
(defun eword-encode-addr-spec-to-rword-list (addr-spec)
|
||||
(if (eq (car addr-spec) 'addr-spec)
|
||||
(eword-encode-addr-seq-to-rword-list (cdr addr-spec))
|
||||
))
|
||||
|
||||
(defun eword-encode-mailbox-to-rword-list (mbox)
|
||||
(let ((addr (nth 1 mbox))
|
||||
(comment (nth 2 mbox))
|
||||
dest)
|
||||
(setq dest (or (eword-encode-phrase-route-addr-to-rword-list addr)
|
||||
(eword-encode-addr-spec-to-rword-list addr)
|
||||
))
|
||||
(if comment
|
||||
(setq dest
|
||||
(append dest
|
||||
'((" " nil nil)
|
||||
("(" nil nil))
|
||||
(eword-encode-split-string comment 'comment)
|
||||
(list '(")" nil nil))
|
||||
)))
|
||||
dest))
|
||||
|
||||
(defsubst eword-encode-mailboxes-to-rword-list (mboxes)
|
||||
(let ((dest (eword-encode-mailbox-to-rword-list (car mboxes))))
|
||||
(if dest
|
||||
(while (setq mboxes (cdr mboxes))
|
||||
(setq dest
|
||||
(nconc dest
|
||||
(list '("," nil nil))
|
||||
(eword-encode-mailbox-to-rword-list
|
||||
(car mboxes))))))
|
||||
dest))
|
||||
|
||||
(defsubst eword-encode-address-to-rword-list (address)
|
||||
(cond
|
||||
((eq (car address) 'mailbox)
|
||||
(eword-encode-mailbox-to-rword-list address))
|
||||
((eq (car address) 'group)
|
||||
(nconc
|
||||
(eword-encode-phrase-to-rword-list (nth 1 address))
|
||||
(list (list ":" nil nil))
|
||||
(eword-encode-mailboxes-to-rword-list (nth 2 address))
|
||||
(list (list ";" nil nil))))))
|
||||
|
||||
(defsubst eword-encode-addresses-to-rword-list (addresses)
|
||||
(let ((dest (eword-encode-address-to-rword-list (car addresses))))
|
||||
(if dest
|
||||
(while (setq addresses (cdr addresses))
|
||||
(setq dest
|
||||
(nconc dest
|
||||
(list '("," nil nil))
|
||||
;; (list '(" " nil nil))
|
||||
(eword-encode-address-to-rword-list (car addresses))))))
|
||||
dest))
|
||||
|
||||
(defsubst eword-encode-msg-id-to-rword-list (msg-id)
|
||||
(list
|
||||
(list
|
||||
(concat "<"
|
||||
(caar (eword-encode-addr-seq-to-rword-list (cdr msg-id)))
|
||||
">")
|
||||
nil nil)))
|
||||
|
||||
(defsubst eword-encode-in-reply-to-to-rword-list (in-reply-to)
|
||||
(let (dest)
|
||||
(while in-reply-to
|
||||
(setq dest
|
||||
(append dest
|
||||
(let ((elt (car in-reply-to)))
|
||||
(if (eq (car elt) 'phrase)
|
||||
(eword-encode-phrase-to-rword-list (cdr elt))
|
||||
(eword-encode-msg-id-to-rword-list elt)
|
||||
))))
|
||||
(setq in-reply-to (cdr in-reply-to)))
|
||||
dest))
|
||||
|
||||
|
||||
;;; @ application interfaces
|
||||
;;;
|
||||
|
||||
(defvar eword-encode-default-start-column 10
|
||||
"Default start column if it is omitted.")
|
||||
|
||||
(defun eword-encode-string (string &optional column mode)
|
||||
"Encode STRING as encoded-words, and return the result.
|
||||
Optional argument COLUMN is start-position of the field.
|
||||
Optional argument MODE allows `text', `comment', `phrase' or nil.
|
||||
Default value is `phrase'."
|
||||
(car (eword-encode-rword-list
|
||||
(or column eword-encode-default-start-column)
|
||||
(eword-encode-split-string string mode))))
|
||||
|
||||
(defun eword-encode-address-list (string &optional column)
|
||||
"Encode header field STRING as list of address, and return the result.
|
||||
Optional argument COLUMN is start-position of the field."
|
||||
(car (eword-encode-rword-list
|
||||
(or column eword-encode-default-start-column)
|
||||
(eword-encode-addresses-to-rword-list
|
||||
(std11-parse-addresses-string string))
|
||||
)))
|
||||
|
||||
(defun eword-encode-in-reply-to (string &optional column)
|
||||
"Encode header field STRING as In-Reply-To field, and return the result.
|
||||
Optional argument COLUMN is start-position of the field."
|
||||
(car (eword-encode-rword-list
|
||||
(or column 13)
|
||||
(eword-encode-in-reply-to-to-rword-list
|
||||
(std11-parse-msg-ids-string string)))))
|
||||
|
||||
(defun eword-encode-structured-field-body (string &optional column)
|
||||
"Encode header field STRING as structured field, and return the result.
|
||||
Optional argument COLUMN is start-position of the field."
|
||||
(car (eword-encode-rword-list
|
||||
(or column eword-encode-default-start-column)
|
||||
(eword-encode-addr-seq-to-rword-list (std11-lexical-analyze string))
|
||||
)))
|
||||
|
||||
(defun eword-encode-unstructured-field-body (string &optional column)
|
||||
"Encode header field STRING as unstructured field, and return the result.
|
||||
Optional argument COLUMN is start-position of the field."
|
||||
(car (eword-encode-rword-list
|
||||
(or column eword-encode-default-start-column)
|
||||
(eword-encode-split-string string 'text))))
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-encode-field-body (field-body field-name)
|
||||
"Encode FIELD-BODY as FIELD-NAME, and return the result.
|
||||
A lexical token includes non-ASCII character is encoded as MIME
|
||||
encoded-word. ASCII token is not encoded."
|
||||
(setq field-body (std11-unfold-string field-body))
|
||||
(if (string= field-body "")
|
||||
""
|
||||
(let ((method-alist mime-header-encode-method-alist)
|
||||
start ret)
|
||||
(if (symbolp field-name)
|
||||
(setq start (1+ (length (symbol-name field-name))))
|
||||
(setq start (1+ (length field-name))
|
||||
field-name (intern (capitalize field-name))))
|
||||
(while (car method-alist)
|
||||
(if (or (not (cdr (car method-alist)))
|
||||
(memq field-name
|
||||
(cdr (car method-alist))))
|
||||
(progn
|
||||
(setq ret
|
||||
(apply (caar method-alist) (list field-body start)))
|
||||
(setq method-alist nil)))
|
||||
(setq method-alist (cdr method-alist)))
|
||||
ret)))
|
||||
(defalias 'eword-encode-field-body 'mime-encode-field-body)
|
||||
(make-obsolete 'eword-encode-field-body 'mime-encode-field-body)
|
||||
|
||||
(defun eword-in-subject-p ()
|
||||
(let ((str (std11-field-body "Subject")))
|
||||
(if (and str (string-match eword-encoded-word-regexp str))
|
||||
str)))
|
||||
(make-obsolete 'eword-in-subject-p "Don't use it.")
|
||||
|
||||
(defsubst eword-find-field-encoding-method (field-name)
|
||||
(setq field-name (downcase field-name))
|
||||
(let ((alist mime-field-encoding-method-alist))
|
||||
(catch 'found
|
||||
(while alist
|
||||
(let* ((pair (car alist))
|
||||
(str (car pair)))
|
||||
(if (and (stringp str)
|
||||
(string= field-name (downcase str)))
|
||||
(throw 'found (cdr pair))
|
||||
))
|
||||
(setq alist (cdr alist)))
|
||||
(cdr (assq t mime-field-encoding-method-alist))
|
||||
)))
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-encode-header-in-buffer (&optional code-conversion)
|
||||
"Encode header fields to network representation, such as MIME encoded-word.
|
||||
It refers the `mime-field-encoding-method-alist' variable."
|
||||
(interactive "*")
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(std11-narrow-to-header mail-header-separator)
|
||||
(goto-char (point-min))
|
||||
(let ((default-cs (mime-charset-to-coding-system default-mime-charset))
|
||||
bbeg end field-name)
|
||||
(while (re-search-forward std11-field-head-regexp nil t)
|
||||
(setq bbeg (match-end 0)
|
||||
field-name (buffer-substring-no-properties (match-beginning 0)
|
||||
(1- bbeg))
|
||||
end (std11-field-end))
|
||||
(and (delq 'ascii (find-charset-region bbeg end))
|
||||
(let ((method (eword-find-field-encoding-method
|
||||
(downcase field-name))))
|
||||
(cond ((eq method 'mime)
|
||||
(let* ((field-body
|
||||
(buffer-substring-no-properties bbeg end))
|
||||
(encoded-body
|
||||
(mime-encode-field-body
|
||||
field-body field-name)))
|
||||
(if (not encoded-body)
|
||||
(error "Cannot encode %s:%s"
|
||||
field-name field-body)
|
||||
(delete-region bbeg end)
|
||||
(insert encoded-body))))
|
||||
(code-conversion
|
||||
(let ((cs
|
||||
(or (mime-charset-to-coding-system
|
||||
method)
|
||||
default-cs)))
|
||||
(encode-coding-region bbeg end cs)))))))))))
|
||||
(defalias 'eword-encode-header 'mime-encode-header-in-buffer)
|
||||
(make-obsolete 'eword-encode-header 'mime-encode-header-in-buffer)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'eword-encode)
|
||||
|
||||
;;; eword-encode.el ends here
|
||||
73
flim-1.14.9/hex-util.el
Normal file
73
flim-1.14.9/hex-util.el
Normal file
@ -0,0 +1,73 @@
|
||||
;;; hex-util.el --- Functions to encode/decode hexadecimal string.
|
||||
|
||||
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: data
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile
|
||||
(defmacro hex-char-to-num (chr)
|
||||
(` (let ((chr (, chr)))
|
||||
(cond
|
||||
((and (<= ?a chr)(<= chr ?f)) (+ (- chr ?a) 10))
|
||||
((and (<= ?A chr)(<= chr ?F)) (+ (- chr ?A) 10))
|
||||
((and (<= ?0 chr)(<= chr ?9)) (- chr ?0))
|
||||
(t (error "Invalid hexadecimal digit `%c'" chr))))))
|
||||
(defmacro num-to-hex-char (num)
|
||||
(` (aref "0123456789abcdef" (, num)))))
|
||||
|
||||
(defun decode-hex-string (string)
|
||||
"Decode hexadecimal STRING to octet string."
|
||||
(let* ((len (length string))
|
||||
(dst (make-string (/ len 2) 0))
|
||||
(idx 0)(pos 0))
|
||||
(while (< pos len)
|
||||
;;; logior and lsh are not byte-coded.
|
||||
;;; (aset dst idx (logior (lsh (hex-char-to-num (aref string pos)) 4)
|
||||
;;; (hex-char-to-num (aref string (1+ pos)))))
|
||||
(aset dst idx (+ (* (hex-char-to-num (aref string pos)) 16)
|
||||
(hex-char-to-num (aref string (1+ pos)))))
|
||||
(setq idx (1+ idx)
|
||||
pos (+ 2 pos)))
|
||||
dst))
|
||||
|
||||
(defun encode-hex-string (string)
|
||||
"Encode octet STRING to hexadecimal string."
|
||||
(let* ((len (length string))
|
||||
(dst (make-string (* len 2) 0))
|
||||
(idx 0)(pos 0))
|
||||
(while (< pos len)
|
||||
;;; logand and lsh are not byte-coded.
|
||||
;;; (aset dst idx (num-to-hex-char (logand (lsh (aref string pos) -4) 15)))
|
||||
(aset dst idx (num-to-hex-char (/ (aref string pos) 16)))
|
||||
(setq idx (1+ idx))
|
||||
;;; (aset dst idx (num-to-hex-char (logand (aref string pos) 15)))
|
||||
(aset dst idx (num-to-hex-char (% (aref string pos) 16)))
|
||||
(setq idx (1+ idx)
|
||||
pos (1+ pos)))
|
||||
dst))
|
||||
|
||||
(provide 'hex-util)
|
||||
|
||||
;;; hex-util.el ends here
|
||||
85
flim-1.14.9/hmac-def.el
Normal file
85
flim-1.14.9/hmac-def.el
Normal file
@ -0,0 +1,85 @@
|
||||
;;; hmac-def.el --- A macro for defining HMAC functions.
|
||||
|
||||
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: HMAC, RFC 2104
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This program is implemented from RFC 2104,
|
||||
;; "HMAC: Keyed-Hashing for Message Authentication".
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defmacro define-hmac-function (name H B L &optional bit)
|
||||
"Define a function NAME(TEXT KEY) which computes HMAC with function H.
|
||||
|
||||
HMAC function is H(KEY XOR opad, H(KEY XOR ipad, TEXT)):
|
||||
|
||||
H is a cryptographic hash function, such as SHA1 and MD5, which takes
|
||||
a string and return a digest of it (in binary form).
|
||||
B is a byte-length of a block size of H. (B=64 for both SHA1 and MD5.)
|
||||
L is a byte-length of hash outputs. (L=16 for MD5, L=20 for SHA1.)
|
||||
If BIT is non-nil, truncate output to specified bits."
|
||||
(` (defun (, name) (text key)
|
||||
(, (concat "Compute "
|
||||
(upcase (symbol-name name))
|
||||
" over TEXT with KEY."))
|
||||
(let ((key-xor-ipad (make-string (, B) ?\x36))
|
||||
(key-xor-opad (make-string (, B) ?\x5C))
|
||||
(len (length key))
|
||||
(pos 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
;; if `key' is longer than the block size, apply hash function
|
||||
;; to `key' and use the result as a real `key'.
|
||||
(if (> len (, B))
|
||||
(setq key ((, H) key)
|
||||
len (, L)))
|
||||
(while (< pos len)
|
||||
(aset key-xor-ipad pos (logxor (aref key pos) ?\x36))
|
||||
(aset key-xor-opad pos (logxor (aref key pos) ?\x5C))
|
||||
(setq pos (1+ pos)))
|
||||
(setq key-xor-ipad (unwind-protect
|
||||
(concat key-xor-ipad text)
|
||||
(fillarray key-xor-ipad 0))
|
||||
key-xor-ipad (unwind-protect
|
||||
((, H) key-xor-ipad)
|
||||
(fillarray key-xor-ipad 0))
|
||||
key-xor-opad (unwind-protect
|
||||
(concat key-xor-opad key-xor-ipad)
|
||||
(fillarray key-xor-opad 0))
|
||||
key-xor-opad (unwind-protect
|
||||
((, H) key-xor-opad)
|
||||
(fillarray key-xor-opad 0)))
|
||||
;; now `key-xor-opad' contains
|
||||
;; H(KEY XOR opad, H(KEY XOR ipad, TEXT)).
|
||||
(, (if (and bit (< (/ bit 8) L))
|
||||
(` (substring key-xor-opad 0 (, (/ bit 8))))
|
||||
;; return a copy of `key-xor-opad'.
|
||||
(` (concat key-xor-opad)))))
|
||||
;; cleanup.
|
||||
(fillarray key-xor-ipad 0)
|
||||
(fillarray key-xor-opad 0))))))
|
||||
|
||||
(provide 'hmac-def)
|
||||
|
||||
;;; hmac-def.el ends here
|
||||
93
flim-1.14.9/hmac-md5.el
Normal file
93
flim-1.14.9/hmac-md5.el
Normal file
@ -0,0 +1,93 @@
|
||||
;;; hmac-md5.el --- Compute HMAC-MD5.
|
||||
|
||||
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
|
||||
;;
|
||||
;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b)))
|
||||
;; => "9294727a3638bb1c13f48ef8158bfc9d"
|
||||
;;
|
||||
;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe"))
|
||||
;; => "750c783e6ab0b503eaa86e310a5db738"
|
||||
;;
|
||||
;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa)))
|
||||
;; => "56be34521d144c88dbb8c733f0e8b3f6"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-md5
|
||||
;; (make-string 50 ?\xcd)
|
||||
;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
|
||||
;; => "697eaf0aca3a3aea3a75164746ffaa79"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c)))
|
||||
;; => "56461ef2342edc00f9bab995690efd4c"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c)))
|
||||
;; => "56461ef2342edc00f9bab995"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-md5
|
||||
;; "Test Using Larger Than Block-Size Key - Hash Key First"
|
||||
;; (make-string 80 ?\xaa)))
|
||||
;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-md5
|
||||
;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
|
||||
;; (make-string 80 ?\xaa)))
|
||||
;; => "6f630fad67cda0ee1fb1f562db3aa53e"
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'hmac-def))
|
||||
(require 'hex-util) ; (decode-hex-string STRING)
|
||||
(require 'md5) ; expects (md5 STRING)
|
||||
|
||||
;; To share *.elc files between Emacs w/ and w/o DL patch,
|
||||
;; this check must be done at load-time.
|
||||
(cond
|
||||
((fboundp 'md5-binary)
|
||||
;; do nothing.
|
||||
)
|
||||
((condition-case nil
|
||||
;; `md5' of v21 takes 4th arg CODING (and 5th arg NOERROR).
|
||||
(md5 "" nil nil 'binary) ; => "d41d8cd98f00b204e9800998ecf8427e"
|
||||
(wrong-number-of-arguments nil))
|
||||
(defun md5-binary (string)
|
||||
"Return the MD5 of STRING in binary form."
|
||||
(decode-hex-string (md5 string nil nil 'binary))))
|
||||
(t
|
||||
(defun md5-binary (string)
|
||||
"Return the MD5 of STRING in binary form."
|
||||
(decode-hex-string (md5 string)))))
|
||||
|
||||
(define-hmac-function hmac-md5 md5-binary 64 16) ; => (hmac-md5 TEXT KEY)
|
||||
(define-hmac-function hmac-md5-96 md5-binary 64 16 96)
|
||||
|
||||
(provide 'hmac-md5)
|
||||
|
||||
;;; hmac-md5.el ends here
|
||||
86
flim-1.14.9/hmac-sha1.el
Normal file
86
flim-1.14.9/hmac-sha1.el
Normal file
@ -0,0 +1,86 @@
|
||||
;;; hmac-sha1.el --- Compute HMAC-SHA1.
|
||||
|
||||
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: HMAC, RFC 2104, HMAC-SHA1, SHA1, Cancel-Lock
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1".
|
||||
;;
|
||||
;; (encode-hex-string (hmac-sha1 "Hi There" (make-string 20 ?\x0b)))
|
||||
;; => "b617318655057264e28bc0b6fb378c8ef146be00"
|
||||
;;
|
||||
;; (encode-hex-string (hmac-sha1 "what do ya want for nothing?" "Jefe"))
|
||||
;; => "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79"
|
||||
;;
|
||||
;; (encode-hex-string (hmac-sha1 (make-string 50 ?\xdd) (make-string 20 ?\xaa)))
|
||||
;; => "125d7342b9ac11cd91a39af48aa17b4f63f175d3"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-sha1
|
||||
;; (make-string 50 ?\xcd)
|
||||
;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819")))
|
||||
;; => "4c9007f4026250c6bc8414f9bf50c86c2d7235da"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-sha1 "Test With Truncation" (make-string 20 ?\x0c)))
|
||||
;; => "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-sha1-96 "Test With Truncation" (make-string 20 ?\x0c)))
|
||||
;; => "4c1a03424b55e07fe7f27be1"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-sha1
|
||||
;; "Test Using Larger Than Block-Size Key - Hash Key First"
|
||||
;; (make-string 80 ?\xaa)))
|
||||
;; => "aa4ae5e15272d00e95705637ce8a3b55ed402112"
|
||||
;;
|
||||
;; (encode-hex-string
|
||||
;; (hmac-sha1
|
||||
;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data"
|
||||
;; (make-string 80 ?\xaa)))
|
||||
;; => "e8e99d0f45237d786d6bbaa7965c7808bbff1a91"
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'hmac-def))
|
||||
(require 'hex-util) ; (decode-hex-string STRING)
|
||||
(require 'sha1) ; expects (sha1 STRING)
|
||||
|
||||
;; To share *.elc files between Emacs w/ and w/o DL patch,
|
||||
;; this check must be done at load-time.
|
||||
(cond
|
||||
((fboundp 'sha1-binary)
|
||||
;; do nothing.
|
||||
)
|
||||
(t
|
||||
(defun sha1-binary (string)
|
||||
"Return the SHA1 of STRING in binary form."
|
||||
(decode-hex-string (sha1 string)))))
|
||||
|
||||
(define-hmac-function hmac-sha1 sha1-binary 64 20) ; => (hmac-sha1 TEXT KEY)
|
||||
(define-hmac-function hmac-sha1-96 sha1-binary 64 20 96)
|
||||
|
||||
(provide 'hmac-sha1)
|
||||
|
||||
;;; hmac-sha1.el ends here
|
||||
434
flim-1.14.9/luna.el
Normal file
434
flim-1.14.9/luna.el
Normal file
@ -0,0 +1,434 @@
|
||||
;;; luna.el --- tiny OOP system kernel
|
||||
|
||||
;; Copyright (C) 1999,2000,2002 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: OOP
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
|
||||
;;; @ class
|
||||
;;;
|
||||
|
||||
(defmacro luna-find-class (name)
|
||||
"Return a luna-class that has NAME."
|
||||
`(get ,name 'luna-class))
|
||||
|
||||
;; Give NAME (symbol) the luna-class CLASS.
|
||||
(defmacro luna-set-class (name class)
|
||||
`(put ,name 'luna-class ,class))
|
||||
|
||||
;; Return the obarray of luna-class CLASS.
|
||||
(defmacro luna-class-obarray (class)
|
||||
`(aref ,class 1))
|
||||
|
||||
;; Return the parents of luna-class CLASS.
|
||||
(defmacro luna-class-parents (class)
|
||||
`(aref ,class 2))
|
||||
|
||||
;; Return the number of slots of luna-class CLASS.
|
||||
(defmacro luna-class-number-of-slots (class)
|
||||
`(aref ,class 3))
|
||||
|
||||
(defmacro luna-define-class (class &optional parents slots)
|
||||
"Define CLASS as a luna-class.
|
||||
CLASS always inherits the luna-class `standard-object'.
|
||||
|
||||
The optional 1st arg PARENTS is a list luna-class names. These
|
||||
luna-classes are also inheritted by CLASS.
|
||||
|
||||
The optional 2nd arg SLOTS is a list of slots CLASS will have."
|
||||
`(luna-define-class-function ',class ',(append parents '(standard-object))
|
||||
',slots))
|
||||
|
||||
|
||||
;; Define CLASS as a luna-class. PARENTS, if non-nil, is a list of
|
||||
;; luna-class names inherited by CLASS. SLOTS, if non-nil, is a list
|
||||
;; of slots belonging to CLASS.
|
||||
|
||||
(defun luna-define-class-function (class &optional parents slots)
|
||||
(let ((oa (make-vector 31 0))
|
||||
(rest parents)
|
||||
parent name
|
||||
(i 2)
|
||||
b j)
|
||||
(while rest
|
||||
(setq parent (pop rest)
|
||||
b (- i 2))
|
||||
(mapatoms (lambda (sym)
|
||||
(when (setq j (get sym 'luna-slot-index))
|
||||
(setq name (symbol-name sym))
|
||||
(unless (intern-soft name oa)
|
||||
(put (intern name oa) 'luna-slot-index (+ j b))
|
||||
(setq i (1+ i)))))
|
||||
(luna-class-obarray (luna-find-class parent))))
|
||||
(setq rest slots)
|
||||
(while rest
|
||||
(setq name (symbol-name (pop rest)))
|
||||
(unless (intern-soft name oa)
|
||||
(put (intern name oa) 'luna-slot-index i)
|
||||
(setq i (1+ i))))
|
||||
(luna-set-class class (vector 'class oa parents i))))
|
||||
|
||||
|
||||
;; Return a member (slot or method) of CLASS that has name
|
||||
;; MEMBER-NAME.
|
||||
|
||||
(defun luna-class-find-member (class member-name)
|
||||
(or (stringp member-name)
|
||||
(setq member-name (symbol-name member-name)))
|
||||
(intern-soft member-name (luna-class-obarray class)))
|
||||
|
||||
|
||||
;; Return a member (slot or method) of CLASS that has name
|
||||
;; MEMBER-NAME. If CLASS doesnt' have such a member, make it in
|
||||
;; CLASS.
|
||||
|
||||
(defsubst luna-class-find-or-make-member (class member-name)
|
||||
(or (stringp member-name)
|
||||
(setq member-name (symbol-name member-name)))
|
||||
(intern member-name (luna-class-obarray class)))
|
||||
|
||||
|
||||
;; Return the index number of SLOT-NAME in CLASS.
|
||||
|
||||
(defmacro luna-class-slot-index (class slot-name)
|
||||
`(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
|
||||
|
||||
(defmacro luna-define-method (name &rest definition)
|
||||
"Define NAME as a method of a luna class.
|
||||
|
||||
Usage of this macro follows:
|
||||
|
||||
(luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
|
||||
|
||||
The optional 1st argument METHOD-QUALIFIER specifies when and how the
|
||||
method is called.
|
||||
|
||||
If it is :before, call the method before calling the parents' methods.
|
||||
|
||||
If it is :after, call the method after calling the parents' methods.
|
||||
|
||||
If it is :around, call the method only. The parents' methods can be
|
||||
executed by calling the function `luna-call-next-method' in BODY.
|
||||
|
||||
Otherwize, call the method only, and the parents' methods are never
|
||||
executed. In this case, METHOD-QUALIFIER is treated as ARGLIST.
|
||||
|
||||
ARGLIST has the form ((VAR CLASS) METHOD-ARG ...), where VAR is a
|
||||
variable name that should be bound to an entity that receives the
|
||||
message NAME, CLASS is a class name. The first argument to the method
|
||||
is VAR, and the remaining arguments are METHOD-ARGs.
|
||||
|
||||
If VAR is nil, arguments to the method are METHOD-ARGs. This kind of
|
||||
methods can't be called from generic-function (see
|
||||
`luna-define-generic').
|
||||
|
||||
The optional 4th argument DOCSTRING is the documentation of the
|
||||
method. If it is not string, it is treated as BODY.
|
||||
|
||||
The optional 5th BODY is the body of the method."
|
||||
(let ((method-qualifier (pop definition))
|
||||
args specializer class self)
|
||||
(if (memq method-qualifier '(:before :after :around))
|
||||
(setq args (pop definition))
|
||||
(setq args method-qualifier
|
||||
method-qualifier nil))
|
||||
(setq specializer (car args)
|
||||
class (nth 1 specializer)
|
||||
self (car specializer))
|
||||
`(let ((func (lambda ,(if self
|
||||
(cons self (cdr args))
|
||||
(cdr args))
|
||||
,@definition))
|
||||
(sym (luna-class-find-or-make-member
|
||||
(luna-find-class ',class) ',name))
|
||||
(cache (get ',name 'luna-method-cache)))
|
||||
(and cache
|
||||
(fboundp sym)
|
||||
(mapatoms
|
||||
(lambda (s)
|
||||
(if (memq (symbol-function sym) (symbol-value s))
|
||||
(unintern s cache)))
|
||||
cache))
|
||||
(fset sym func)
|
||||
(put sym 'luna-method-qualifier ,method-qualifier))))
|
||||
|
||||
(put 'luna-define-method 'lisp-indent-function 'defun)
|
||||
|
||||
(def-edebug-spec luna-define-method
|
||||
(&define name [&optional &or ":before" ":after" ":around"]
|
||||
((arg symbolp)
|
||||
[&rest arg]
|
||||
[&optional ["&optional" arg &rest arg]]
|
||||
&optional ["&rest" arg])
|
||||
def-body))
|
||||
|
||||
|
||||
;; Return a list of method functions named SERVICE registered in the
|
||||
;; parents of CLASS.
|
||||
|
||||
(defun luna-class-find-parents-functions (class service)
|
||||
(let ((parents (luna-class-parents class))
|
||||
ret)
|
||||
(while (and parents
|
||||
(null
|
||||
(setq ret (luna-class-find-functions
|
||||
(luna-find-class (pop parents))
|
||||
service)))))
|
||||
ret))
|
||||
|
||||
;; Return a list of method functions named SERVICE registered in CLASS
|
||||
;; and the parents..
|
||||
|
||||
(defun luna-class-find-functions (class service)
|
||||
(let ((sym (luna-class-find-member class service)))
|
||||
(if (fboundp sym)
|
||||
(cond ((eq (get sym 'luna-method-qualifier) :before)
|
||||
(cons (symbol-function sym)
|
||||
(luna-class-find-parents-functions class service)))
|
||||
((eq (get sym 'luna-method-qualifier) :after)
|
||||
(nconc (luna-class-find-parents-functions class service)
|
||||
(list (symbol-function sym))))
|
||||
((eq (get sym 'luna-method-qualifier) :around)
|
||||
(cons sym (luna-class-find-parents-functions class service)))
|
||||
(t
|
||||
(list (symbol-function sym))))
|
||||
(luna-class-find-parents-functions class service))))
|
||||
|
||||
|
||||
;;; @ instance (entity)
|
||||
;;;
|
||||
|
||||
(defmacro luna-class-name (entity)
|
||||
"Return class-name of the ENTITY."
|
||||
`(aref ,entity 0))
|
||||
|
||||
(defmacro luna-set-class-name (entity name)
|
||||
`(aset ,entity 0 ,name))
|
||||
|
||||
(defmacro luna-get-obarray (entity)
|
||||
`(aref ,entity 1))
|
||||
|
||||
(defmacro luna-set-obarray (entity obarray)
|
||||
`(aset ,entity 1 ,obarray))
|
||||
|
||||
(defmacro luna-slot-index (entity slot-name)
|
||||
`(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
|
||||
,slot-name))
|
||||
|
||||
(defsubst luna-slot-value (entity slot)
|
||||
"Return the value of SLOT of ENTITY."
|
||||
(aref entity (luna-slot-index entity slot)))
|
||||
|
||||
(defsubst luna-set-slot-value (entity slot value)
|
||||
"Store VALUE into SLOT of ENTITY."
|
||||
(aset entity (luna-slot-index entity slot) value))
|
||||
|
||||
(defmacro luna-find-functions (entity service)
|
||||
`(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
|
||||
,service))
|
||||
|
||||
(defsubst luna-send (entity message &rest luna-current-method-arguments)
|
||||
"Send MESSAGE to ENTITY, and return the result.
|
||||
ENTITY is an instance of a luna class, and MESSAGE is a method name of
|
||||
the luna class.
|
||||
LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
|
||||
(let ((luna-next-methods (luna-find-functions entity message))
|
||||
luna-current-method
|
||||
luna-previous-return-value)
|
||||
(while (and luna-next-methods
|
||||
(progn
|
||||
(setq luna-current-method (pop luna-next-methods)
|
||||
luna-previous-return-value
|
||||
(apply luna-current-method
|
||||
luna-current-method-arguments))
|
||||
(if (symbolp luna-current-method)
|
||||
(not (eq (get luna-current-method
|
||||
'luna-method-qualifier) :around))
|
||||
t))))
|
||||
luna-previous-return-value))
|
||||
|
||||
(eval-when-compile
|
||||
(defvar luna-next-methods nil)
|
||||
(defvar luna-current-method-arguments nil))
|
||||
|
||||
(defun luna-call-next-method ()
|
||||
"Call the next method in the current method function.
|
||||
A method function that has :around qualifier should call this function
|
||||
to execute the parents' methods."
|
||||
(let (luna-current-method
|
||||
luna-previous-return-value)
|
||||
(while (and luna-next-methods
|
||||
(progn
|
||||
(setq luna-current-method (pop luna-next-methods)
|
||||
luna-previous-return-value
|
||||
(apply luna-current-method
|
||||
luna-current-method-arguments))
|
||||
(if (symbolp luna-current-method)
|
||||
(not (eq (get luna-current-method
|
||||
'luna-method-qualifier) :around))
|
||||
t))))
|
||||
luna-previous-return-value))
|
||||
|
||||
(defun luna-make-entity (class &rest init-args)
|
||||
"Make an entity (instance) of luna-class CLASS and return it.
|
||||
INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...),
|
||||
where SLOTs are slots of CLASS and the VALs are initial values of
|
||||
the corresponding SLOTs."
|
||||
(let* ((c (get class 'luna-class))
|
||||
(v (make-vector (luna-class-number-of-slots c) nil)))
|
||||
(luna-set-class-name v class)
|
||||
(luna-set-obarray v (make-vector 7 0))
|
||||
(apply #'luna-send v 'initialize-instance v init-args)))
|
||||
|
||||
|
||||
;;; @ interface (generic function)
|
||||
;;;
|
||||
|
||||
;; Find a method of ENTITY that handles MESSAGE, and call it with
|
||||
;; arguments LUNA-CURRENT-METHOD-ARGUMENTS.
|
||||
|
||||
(defun luna-apply-generic (entity message &rest luna-current-method-arguments)
|
||||
(let* ((class (luna-class-name entity))
|
||||
(cache (get message 'luna-method-cache))
|
||||
(sym (intern-soft (symbol-name class) cache))
|
||||
luna-next-methods)
|
||||
(if sym
|
||||
(setq luna-next-methods (symbol-value sym))
|
||||
(setq luna-next-methods
|
||||
(luna-find-functions entity message))
|
||||
(set (intern (symbol-name class) cache)
|
||||
luna-next-methods))
|
||||
(luna-call-next-method)))
|
||||
|
||||
|
||||
;; Convert ARGLIST (argument list spec for a method function) to the
|
||||
;; actual list of arguments.
|
||||
|
||||
(defsubst luna-arglist-to-arguments (arglist)
|
||||
(let (dest)
|
||||
(while arglist
|
||||
(let ((arg (car arglist)))
|
||||
(or (memq arg '(&optional &rest))
|
||||
(setq dest (cons arg dest))))
|
||||
(setq arglist (cdr arglist)))
|
||||
(nreverse dest)))
|
||||
|
||||
|
||||
(defmacro luna-define-generic (name args &optional doc)
|
||||
"Define a function NAME that provides a generic interface to the method NAME.
|
||||
ARGS is the argument list for NAME. The first element of ARGS is an
|
||||
entity.
|
||||
|
||||
The function handles a message sent to the entity by calling the
|
||||
method with proper arguments.
|
||||
|
||||
The optional 3rd argument DOC is the documentation string for NAME."
|
||||
(if doc
|
||||
`(progn
|
||||
(defun ,(intern (symbol-name name)) ,args
|
||||
,doc
|
||||
(luna-apply-generic ,(car args) ',name
|
||||
,@(luna-arglist-to-arguments args)))
|
||||
(put ',name 'luna-method-cache (make-vector 31 0)))
|
||||
`(progn
|
||||
(defun ,(intern (symbol-name name)) ,args
|
||||
(luna-apply-generic ,(car args) ',name
|
||||
,@(luna-arglist-to-arguments args)))
|
||||
(put ',name 'luna-method-cache (make-vector 31 0)))))
|
||||
|
||||
(put 'luna-define-generic 'lisp-indent-function 'defun)
|
||||
|
||||
|
||||
;;; @ accessor
|
||||
;;;
|
||||
|
||||
(defun luna-define-internal-accessors (class-name)
|
||||
"Define internal accessors for instances of the luna class CLASS-NAME.
|
||||
|
||||
Internal accessors are macros to refer and set a slot value of the
|
||||
instances. For instance, if the class has SLOT, macros
|
||||
CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined.
|
||||
|
||||
CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns
|
||||
the value of SLOT.
|
||||
|
||||
CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE,
|
||||
and sets SLOT to VALUE."
|
||||
(let ((entity-class (luna-find-class class-name))
|
||||
parents parent-class)
|
||||
(mapatoms
|
||||
(lambda (slot)
|
||||
(if (luna-class-slot-index entity-class slot)
|
||||
(catch 'derived
|
||||
(setq parents (luna-class-parents entity-class))
|
||||
(while parents
|
||||
(setq parent-class (luna-find-class (car parents)))
|
||||
(if (luna-class-slot-index parent-class slot)
|
||||
(throw 'derived nil))
|
||||
(setq parents (cdr parents)))
|
||||
(eval
|
||||
`(progn
|
||||
(defmacro ,(intern (format "%s-%s-internal"
|
||||
class-name slot))
|
||||
(entity)
|
||||
(list 'aref entity
|
||||
,(luna-class-slot-index entity-class
|
||||
(intern (symbol-name slot)))))
|
||||
(defmacro ,(intern (format "%s-set-%s-internal"
|
||||
class-name slot))
|
||||
(entity value)
|
||||
(list 'aset entity
|
||||
,(luna-class-slot-index
|
||||
entity-class (intern (symbol-name slot)))
|
||||
value)))))))
|
||||
(luna-class-obarray entity-class))))
|
||||
|
||||
|
||||
;;; @ standard object
|
||||
;;;
|
||||
|
||||
;; Define super class of all luna classes.
|
||||
(luna-define-class-function 'standard-object)
|
||||
|
||||
(luna-define-method initialize-instance ((entity standard-object)
|
||||
&rest init-args)
|
||||
"Initialize slots of ENTITY by INIT-ARGS."
|
||||
(let* ((c (luna-find-class (luna-class-name entity)))
|
||||
(oa (luna-class-obarray c))
|
||||
s i)
|
||||
(while init-args
|
||||
(setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
|
||||
i (pop init-args))
|
||||
(if s
|
||||
(aset entity (get s 'luna-slot-index) i)))
|
||||
entity))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'luna)
|
||||
|
||||
;; luna.el ends here
|
||||
331
flim-1.14.9/lunit.el
Normal file
331
flim-1.14.9/lunit.el
Normal file
@ -0,0 +1,331 @@
|
||||
;;; lunit.el --- simple testing framework for luna
|
||||
|
||||
;; Copyright (C) 2000 Daiki Ueno.
|
||||
|
||||
;; Author: Daiki Ueno <ueno@unixuser.org>
|
||||
;; Keywords: OOP, XP
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module is inspired by "JUnit A Cook's Tour".
|
||||
;; <URL:http://www.junit.org/junit/doc/cookstour/cookstour.htm>
|
||||
|
||||
;; (require 'lunit)
|
||||
;;
|
||||
;; (luna-define-class silly-test-case (lunit-test-case))
|
||||
;;
|
||||
;; (luna-define-method test-1 ((case silly-test-case))
|
||||
;; (lunit-assert (integerp "a")))
|
||||
;;
|
||||
;; (luna-define-method test-2 ((case silly-test-case))
|
||||
;; (lunit-assert (stringp "b")))
|
||||
;;
|
||||
;; (with-output-to-temp-buffer "*Lunit Results*"
|
||||
;; (lunit (lunit-make-test-suite-from-class 'silly-test-case)))
|
||||
;; ______________________________________________________________________
|
||||
;; Starting test `silly-test-case#test-1'
|
||||
;; failure: (integerp "a")
|
||||
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
;; ______________________________________________________________________
|
||||
;; Starting test `silly-test-case#test-2'
|
||||
;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
;; 2 runs, 1 failures, 0 errors
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'luna)
|
||||
|
||||
(eval-when-compile (require 'cl))
|
||||
|
||||
;;; @ test
|
||||
;;;
|
||||
|
||||
(eval-and-compile
|
||||
(luna-define-class lunit-test ()
|
||||
(name))
|
||||
|
||||
(luna-define-internal-accessors 'lunit-test))
|
||||
|
||||
(luna-define-generic lunit-test-number-of-tests (test)
|
||||
"Count the number of test cases that will be run by the test.")
|
||||
|
||||
(luna-define-generic lunit-test-run (test result)
|
||||
"Run the test and collects its result in result.")
|
||||
|
||||
(luna-define-generic lunit-test-suite-add-test (suite test)
|
||||
"Add the test to the suite.")
|
||||
|
||||
;;; @ test listener
|
||||
;;;
|
||||
|
||||
(luna-define-class lunit-test-listener)
|
||||
|
||||
;;; @ test result
|
||||
;;;
|
||||
|
||||
(put 'lunit-error 'error-message "test error")
|
||||
(put 'lunit-error 'error-conditions '(lunit-error error))
|
||||
|
||||
(put 'lunit-failure 'error-message "test failure")
|
||||
(put 'lunit-failure 'error-conditions '(lunit-failure lunit-error error))
|
||||
|
||||
(eval-and-compile
|
||||
(luna-define-class lunit-test-result ()
|
||||
(errors
|
||||
failures
|
||||
listeners))
|
||||
|
||||
(luna-define-internal-accessors 'lunit-test-result))
|
||||
|
||||
(luna-define-generic lunit-test-result-run (result case)
|
||||
"Run the test case.")
|
||||
|
||||
(luna-define-generic lunit-test-result-notify (result message &rest args)
|
||||
"Report the current state of execution.")
|
||||
|
||||
(luna-define-generic lunit-test-result-error (result case error)
|
||||
"Add error to the list of errors.
|
||||
The passed in exception caused the error.")
|
||||
|
||||
(luna-define-generic lunit-test-result-failure (result case failure)
|
||||
"Add failure to the list of failures.
|
||||
The passed in exception caused the failure.")
|
||||
|
||||
(luna-define-generic lunit-test-result-add-listener (result listener)
|
||||
"Add listener to the list of listeners.")
|
||||
|
||||
(defun lunit-make-test-result (&rest listeners)
|
||||
"Return a newly allocated `lunit-test-result' instance with LISTENERS."
|
||||
(luna-make-entity 'lunit-test-result :listeners listeners))
|
||||
|
||||
(luna-define-method lunit-test-result-notify ((result lunit-test-result)
|
||||
message args)
|
||||
(let ((listeners
|
||||
(lunit-test-result-listeners-internal result)))
|
||||
(dolist (listener listeners)
|
||||
(apply #'luna-send listener message listener args))))
|
||||
|
||||
(luna-define-method lunit-test-result-run ((result lunit-test-result) case)
|
||||
(lunit-test-result-notify result 'lunit-test-listener-start case)
|
||||
(condition-case error
|
||||
(lunit-test-case-run case)
|
||||
(lunit-failure
|
||||
(lunit-test-result-failure result case (nth 1 error)))
|
||||
(lunit-error
|
||||
(lunit-test-result-error result case (cdr error))))
|
||||
(lunit-test-result-notify result 'lunit-test-listener-end case))
|
||||
|
||||
(luna-define-method lunit-test-result-error ((result lunit-test-result)
|
||||
case error)
|
||||
(let ((errors
|
||||
(lunit-test-result-errors-internal result)))
|
||||
(setq errors (nconc errors (list (cons case error))))
|
||||
(lunit-test-result-set-errors-internal result errors))
|
||||
(lunit-test-result-notify result 'lunit-test-listener-error case error))
|
||||
|
||||
(luna-define-method lunit-test-result-failure ((result lunit-test-result)
|
||||
case failure)
|
||||
(let ((failures
|
||||
(lunit-test-result-failures-internal result)))
|
||||
(setq failures (nconc failures (list (cons case failure))))
|
||||
(lunit-test-result-set-failures-internal result failures))
|
||||
(lunit-test-result-notify result 'lunit-test-listener-failure case failure))
|
||||
|
||||
(luna-define-method lunit-test-result-add-listener ((result lunit-test-result)
|
||||
listener)
|
||||
(let ((listeners
|
||||
(lunit-test-result-listeners-internal result)))
|
||||
(setq listeners (nconc listeners (list listener)))
|
||||
(lunit-test-result-set-listeners-internal result listeners)))
|
||||
|
||||
;;; @ test case
|
||||
;;;
|
||||
|
||||
(luna-define-class lunit-test-case (lunit-test))
|
||||
|
||||
(luna-define-generic lunit-test-case-run (case)
|
||||
"Run the test case.")
|
||||
|
||||
(luna-define-generic lunit-test-case-setup (case)
|
||||
"Setup the test case.")
|
||||
|
||||
(luna-define-generic lunit-test-case-teardown (case)
|
||||
"Clear the test case.")
|
||||
|
||||
(defun lunit-make-test-case (class name)
|
||||
"Return a newly allocated `lunit-test-case'.
|
||||
CLASS is a symbol for class derived from `lunit-test-case'.
|
||||
NAME is name of the method to be tested."
|
||||
(luna-make-entity class :name name))
|
||||
|
||||
(luna-define-method lunit-test-number-of-tests ((case lunit-test-case))
|
||||
1)
|
||||
|
||||
(luna-define-method lunit-test-run ((case lunit-test-case) result)
|
||||
(lunit-test-result-run result case))
|
||||
|
||||
(luna-define-method lunit-test-case-setup ((case lunit-test-case)))
|
||||
(luna-define-method lunit-test-case-teardown ((case lunit-test-case)))
|
||||
|
||||
(luna-define-method lunit-test-case-run ((case lunit-test-case))
|
||||
(lunit-test-case-setup case)
|
||||
(unwind-protect
|
||||
(let* ((name
|
||||
(lunit-test-name-internal case))
|
||||
(functions
|
||||
(luna-find-functions case name)))
|
||||
(unless functions
|
||||
(error "Method \"%S\" not found" name))
|
||||
(condition-case error
|
||||
(funcall (car functions) case)
|
||||
(lunit-failure
|
||||
(signal (car error)(cdr error)))
|
||||
(error
|
||||
(signal 'lunit-error error))))
|
||||
(lunit-test-case-teardown case)))
|
||||
|
||||
;;; @ test suite
|
||||
;;;
|
||||
|
||||
(eval-and-compile
|
||||
(luna-define-class lunit-test-suite (lunit-test)
|
||||
(tests))
|
||||
|
||||
(luna-define-internal-accessors 'lunit-test-suite))
|
||||
|
||||
(defun lunit-make-test-suite (&rest tests)
|
||||
"Return a newly allocated `lunit-test-suite' instance.
|
||||
TESTS holds a number of instances of `lunit-test'."
|
||||
(luna-make-entity 'lunit-test-suite :tests tests))
|
||||
|
||||
(luna-define-method lunit-test-suite-add-test ((suite lunit-test-suite) test)
|
||||
(let ((tests (lunit-test-suite-tests-internal suite)))
|
||||
(lunit-test-suite-set-tests-internal suite (nconc tests (list test)))))
|
||||
|
||||
(luna-define-method lunit-test-number-of-tests ((suite lunit-test-suite))
|
||||
(let ((tests (lunit-test-suite-tests-internal suite))
|
||||
(accu 0))
|
||||
(dolist (test tests)
|
||||
(setq accu (+ accu (lunit-test-number-of-tests test))))
|
||||
accu))
|
||||
|
||||
(luna-define-method lunit-test-run ((suite lunit-test-suite) result)
|
||||
(let ((tests (lunit-test-suite-tests-internal suite)))
|
||||
(dolist (test tests)
|
||||
(lunit-test-run test result))))
|
||||
|
||||
;;; @ test runner
|
||||
;;;
|
||||
|
||||
(defmacro lunit-assert (condition-expr)
|
||||
"Verify that CONDITION-EXPR returns non-nil; signal an error if not."
|
||||
(let ((condition (eval condition-expr)))
|
||||
`(when ,(not condition)
|
||||
(signal 'lunit-failure (list ',condition-expr)))))
|
||||
|
||||
(luna-define-class lunit-test-printer (lunit-test-listener))
|
||||
|
||||
(luna-define-method lunit-test-listener-error ((printer lunit-test-printer)
|
||||
case error)
|
||||
(princ (format " error: %S" error)))
|
||||
|
||||
(luna-define-method lunit-test-listener-failure ((printer lunit-test-printer)
|
||||
case failure)
|
||||
(princ (format " failure: %S" failure)))
|
||||
|
||||
(luna-define-method lunit-test-listener-start ((printer lunit-test-printer)
|
||||
case)
|
||||
(princ (format "Running `%S#%S'..."
|
||||
(luna-class-name case)
|
||||
(lunit-test-name-internal case))))
|
||||
|
||||
(luna-define-method lunit-test-listener-end ((printer lunit-test-printer) case)
|
||||
(princ "\n"))
|
||||
|
||||
(defun lunit-make-test-suite-from-class (class)
|
||||
"Make a test suite from all test methods of the CLASS."
|
||||
(let (tests)
|
||||
(mapatoms
|
||||
(lambda (symbol)
|
||||
(if (and (fboundp symbol)
|
||||
(string-match "^test" (symbol-name symbol))
|
||||
(null (get symbol 'luna-method-qualifier)))
|
||||
(push (lunit-make-test-case class symbol) tests)))
|
||||
(luna-class-obarray (luna-find-class class)))
|
||||
(apply #'lunit-make-test-suite tests)))
|
||||
|
||||
(defun lunit (test)
|
||||
"Run TEST and display the result."
|
||||
(let* ((printer
|
||||
(luna-make-entity 'lunit-test-printer))
|
||||
(result
|
||||
(lunit-make-test-result printer)))
|
||||
(lunit-test-run test result)
|
||||
(let ((failures
|
||||
(lunit-test-result-failures-internal result))
|
||||
(errors
|
||||
(lunit-test-result-errors-internal result)))
|
||||
(princ (format "%d runs, %d failures, %d errors\n"
|
||||
(lunit-test-number-of-tests test)
|
||||
(length failures)
|
||||
(length errors))))))
|
||||
|
||||
(defvar imenu-create-index-function)
|
||||
(defun lunit-create-index-function ()
|
||||
(require 'imenu)
|
||||
(save-excursion
|
||||
(unwind-protect
|
||||
(progn
|
||||
(goto-char (point-min))
|
||||
(setq imenu-generic-expression
|
||||
'((nil "^\\s-*(def\\(un\\|subst\\|macro\\)\\s-+\\([-A-Za-z0-9+*|:]+\\)" 2)))
|
||||
(funcall imenu-create-index-function))
|
||||
(setq imenu-create-index-function lisp-imenu-generic-expression))))
|
||||
|
||||
(defun lunit-generate-template (file)
|
||||
(interactive "fGenerate lunit template for: ")
|
||||
(save-excursion
|
||||
(set-buffer (find-file-noselect file))
|
||||
(let ((index-alist
|
||||
(lunit-create-index-function)))
|
||||
(with-output-to-temp-buffer "*Lunit template*"
|
||||
(let* ((feature
|
||||
(file-name-sans-extension
|
||||
(file-name-nondirectory file)))
|
||||
(class
|
||||
(concat "test-" feature)))
|
||||
(set-buffer standard-output)
|
||||
(insert "\
|
||||
\(require 'lunit)
|
||||
\(require '" feature ")
|
||||
|
||||
\(luna-define-class " class " (lunit-test-case))
|
||||
|
||||
")
|
||||
(dolist (index index-alist)
|
||||
(insert "\
|
||||
\(luna-define-method " class "-" (car index) " ((case " class "))
|
||||
(lunit-assert nil))
|
||||
|
||||
")))))))
|
||||
|
||||
(provide 'lunit)
|
||||
|
||||
;;; lunit.el ends here
|
||||
67
flim-1.14.9/mailcap.el
Normal file
67
flim-1.14.9/mailcap.el
Normal file
@ -0,0 +1,67 @@
|
||||
;;; mailcap.el --- mailcap parser
|
||||
|
||||
;; Copyright (C) 1997,1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Created: 1997-06-27
|
||||
;; 2000-11-24 Rewrote to use mime-conf.el.
|
||||
;; Keywords: mailcap, setting, configuration, MIME, multimedia
|
||||
;; Status: obsolete
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-conf)
|
||||
(require 'poe) ; define-obsolete-function-alias
|
||||
|
||||
(define-obsolete-function-alias
|
||||
'mailcap-parse-buffer 'mime-parse-mailcap-buffer)
|
||||
|
||||
(define-obsolete-function-alias
|
||||
'mailcap-format-command 'mime-format-mailcap-command)
|
||||
|
||||
(cond
|
||||
((featurep 'xemacs)
|
||||
(define-obsolete-variable-alias
|
||||
'mailcap-file 'mime-mailcap-file)
|
||||
(define-obsolete-function-alias
|
||||
'mailcap-parse-file 'mime-parse-mailcap-file)
|
||||
)
|
||||
(t
|
||||
(defvar mailcap-file mime-mailcap-file)
|
||||
(defun mailcap-parse-file (&optional filename order)
|
||||
"Parse FILENAME as a mailcap, and return the result.
|
||||
If optional argument ORDER is a function, result is sorted by it.
|
||||
If optional argument ORDER is not specified, result is sorted original
|
||||
order. Otherwise result is not sorted.
|
||||
This function is obsolete. Please use mime-parse-mailcap-file instead."
|
||||
(if filename
|
||||
(mime-parse-mailcap-file filename order)
|
||||
(let ((mime-mailcap-file mailcap-file))
|
||||
(mime-parse-mailcap-file nil order))))
|
||||
(make-obsolete 'mailcap-parse-file 'mime-parse-mailcap-file)
|
||||
))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mailcap)
|
||||
|
||||
;;; mailcap.el ends here
|
||||
228
flim-1.14.9/md4.el
Normal file
228
flim-1.14.9/md4.el
Normal file
@ -0,0 +1,228 @@
|
||||
;;; md4.el --- MD4 Message Digest Algorithm.
|
||||
|
||||
;; Copyright (C) 2004 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001 Taro Kawagishi
|
||||
;; Author: Taro Kawagishi <tarok@transpulse.org>
|
||||
;; Keywords: MD4
|
||||
;; Version: 1.00
|
||||
;; Created: February 2001
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;;
|
||||
;;; MD4 hash calculation
|
||||
|
||||
(defvar md4-buffer (make-vector 4 '(0 . 0))
|
||||
"work buffer of four 32-bit integers")
|
||||
|
||||
(defun md4 (in n)
|
||||
"Returns the MD4 hash string of 16 bytes long for a string IN of N
|
||||
bytes long. N is required to handle strings containing character 0."
|
||||
(let (m
|
||||
(b (cons 0 (* n 8)))
|
||||
(i 0)
|
||||
(buf (make-string 128 0)) c4)
|
||||
;; initial values
|
||||
(aset md4-buffer 0 '(26437 . 8961)) ;0x67452301
|
||||
(aset md4-buffer 1 '(61389 . 43913)) ;0xefcdab89
|
||||
(aset md4-buffer 2 '(39098 . 56574)) ;0x98badcfe
|
||||
(aset md4-buffer 3 '(4146 . 21622)) ;0x10325476
|
||||
|
||||
;; process the string in 64 bits chunks
|
||||
(while (> n 64)
|
||||
(setq m (md4-copy64 (substring in 0 64)))
|
||||
(md4-64 m)
|
||||
(setq in (substring in 64))
|
||||
(setq n (- n 64)))
|
||||
|
||||
;; process the rest of the string (length is now n <= 64)
|
||||
(setq i 0)
|
||||
(while (< i n)
|
||||
(aset buf i (aref in i))
|
||||
(setq i (1+ i)))
|
||||
(aset buf n 128) ;0x80
|
||||
(if (<= n 55)
|
||||
(progn
|
||||
(setq c4 (md4-pack-int32 b))
|
||||
(aset buf 56 (aref c4 0))
|
||||
(aset buf 57 (aref c4 1))
|
||||
(aset buf 58 (aref c4 2))
|
||||
(aset buf 59 (aref c4 3))
|
||||
(setq m (md4-copy64 buf))
|
||||
(md4-64 m))
|
||||
;; else
|
||||
(setq c4 (md4-pack-int32 b))
|
||||
(aset buf 120 (aref c4 0))
|
||||
(aset buf 121 (aref c4 1))
|
||||
(aset buf 122 (aref c4 2))
|
||||
(aset buf 123 (aref c4 3))
|
||||
(setq m (md4-copy64 buf))
|
||||
(md4-64 m)
|
||||
(setq m (md4-copy64 (substring buf 64)))
|
||||
(md4-64 m)))
|
||||
|
||||
(concat (md4-pack-int32 (aref md4-buffer 0))
|
||||
(md4-pack-int32 (aref md4-buffer 1))
|
||||
(md4-pack-int32 (aref md4-buffer 2))
|
||||
(md4-pack-int32 (aref md4-buffer 3))))
|
||||
|
||||
(defsubst md4-F (x y z) (logior (logand x y) (logand (lognot x) z)))
|
||||
(defsubst md4-G (x y z) (logior (logand x y) (logand x z) (logand y z)))
|
||||
(defsubst md4-H (x y z) (logxor x y z))
|
||||
|
||||
(defmacro md4-make-step (name func)
|
||||
(`
|
||||
(defun (, name) (a b c d xk s ac)
|
||||
(let*
|
||||
((h1 (+ (car a) ((, func) (car b) (car c) (car d)) (car xk) (car ac)))
|
||||
(l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr xk) (cdr ac)))
|
||||
(h2 (logand 65535 (+ h1 (lsh l1 -16))))
|
||||
(l2 (logand 65535 l1))
|
||||
;; cyclic shift of 32 bits integer
|
||||
(h3 (logand 65535 (if (> s 15)
|
||||
(+ (lsh h2 (- s 32)) (lsh l2 (- s 16)))
|
||||
(+ (lsh h2 s) (lsh l2 (- s 16))))))
|
||||
(l3 (logand 65535 (if (> s 15)
|
||||
(+ (lsh l2 (- s 32)) (lsh h2 (- s 16)))
|
||||
(+ (lsh l2 s) (lsh h2 (- s 16)))))))
|
||||
(cons h3 l3)))))
|
||||
|
||||
(md4-make-step md4-round1 md4-F)
|
||||
(md4-make-step md4-round2 md4-G)
|
||||
(md4-make-step md4-round3 md4-H)
|
||||
|
||||
(defsubst md4-add (x y)
|
||||
"Return 32-bit sum of 32-bit integers X and Y."
|
||||
(let ((h (+ (car x) (car y)))
|
||||
(l (+ (cdr x) (cdr y))))
|
||||
(cons (logand 65535 (+ h (lsh l -16))) (logand 65535 l))))
|
||||
|
||||
(defsubst md4-and (x y)
|
||||
(cons (logand (car x) (car y)) (logand (cdr x) (cdr y))))
|
||||
|
||||
(defun md4-64 (m)
|
||||
"Calculate md4 of 64 bytes chunk M which is represented as 16 pairs of
|
||||
32 bits integers. The resulting md4 value is placed in md4-buffer."
|
||||
(let ((a (aref md4-buffer 0))
|
||||
(b (aref md4-buffer 1))
|
||||
(c (aref md4-buffer 2))
|
||||
(d (aref md4-buffer 3)))
|
||||
(setq a (md4-round1 a b c d (aref m 0) 3 '(0 . 0))
|
||||
d (md4-round1 d a b c (aref m 1) 7 '(0 . 0))
|
||||
c (md4-round1 c d a b (aref m 2) 11 '(0 . 0))
|
||||
b (md4-round1 b c d a (aref m 3) 19 '(0 . 0))
|
||||
a (md4-round1 a b c d (aref m 4) 3 '(0 . 0))
|
||||
d (md4-round1 d a b c (aref m 5) 7 '(0 . 0))
|
||||
c (md4-round1 c d a b (aref m 6) 11 '(0 . 0))
|
||||
b (md4-round1 b c d a (aref m 7) 19 '(0 . 0))
|
||||
a (md4-round1 a b c d (aref m 8) 3 '(0 . 0))
|
||||
d (md4-round1 d a b c (aref m 9) 7 '(0 . 0))
|
||||
c (md4-round1 c d a b (aref m 10) 11 '(0 . 0))
|
||||
b (md4-round1 b c d a (aref m 11) 19 '(0 . 0))
|
||||
a (md4-round1 a b c d (aref m 12) 3 '(0 . 0))
|
||||
d (md4-round1 d a b c (aref m 13) 7 '(0 . 0))
|
||||
c (md4-round1 c d a b (aref m 14) 11 '(0 . 0))
|
||||
b (md4-round1 b c d a (aref m 15) 19 '(0 . 0))
|
||||
|
||||
a (md4-round2 a b c d (aref m 0) 3 '(23170 . 31129)) ;0x5A827999
|
||||
d (md4-round2 d a b c (aref m 4) 5 '(23170 . 31129))
|
||||
c (md4-round2 c d a b (aref m 8) 9 '(23170 . 31129))
|
||||
b (md4-round2 b c d a (aref m 12) 13 '(23170 . 31129))
|
||||
a (md4-round2 a b c d (aref m 1) 3 '(23170 . 31129))
|
||||
d (md4-round2 d a b c (aref m 5) 5 '(23170 . 31129))
|
||||
c (md4-round2 c d a b (aref m 9) 9 '(23170 . 31129))
|
||||
b (md4-round2 b c d a (aref m 13) 13 '(23170 . 31129))
|
||||
a (md4-round2 a b c d (aref m 2) 3 '(23170 . 31129))
|
||||
d (md4-round2 d a b c (aref m 6) 5 '(23170 . 31129))
|
||||
c (md4-round2 c d a b (aref m 10) 9 '(23170 . 31129))
|
||||
b (md4-round2 b c d a (aref m 14) 13 '(23170 . 31129))
|
||||
a (md4-round2 a b c d (aref m 3) 3 '(23170 . 31129))
|
||||
d (md4-round2 d a b c (aref m 7) 5 '(23170 . 31129))
|
||||
c (md4-round2 c d a b (aref m 11) 9 '(23170 . 31129))
|
||||
b (md4-round2 b c d a (aref m 15) 13 '(23170 . 31129))
|
||||
|
||||
a (md4-round3 a b c d (aref m 0) 3 '(28377 . 60321)) ;0x6ED9EBA1
|
||||
d (md4-round3 d a b c (aref m 8) 9 '(28377 . 60321))
|
||||
c (md4-round3 c d a b (aref m 4) 11 '(28377 . 60321))
|
||||
b (md4-round3 b c d a (aref m 12) 15 '(28377 . 60321))
|
||||
a (md4-round3 a b c d (aref m 2) 3 '(28377 . 60321))
|
||||
d (md4-round3 d a b c (aref m 10) 9 '(28377 . 60321))
|
||||
c (md4-round3 c d a b (aref m 6) 11 '(28377 . 60321))
|
||||
b (md4-round3 b c d a (aref m 14) 15 '(28377 . 60321))
|
||||
a (md4-round3 a b c d (aref m 1) 3 '(28377 . 60321))
|
||||
d (md4-round3 d a b c (aref m 9) 9 '(28377 . 60321))
|
||||
c (md4-round3 c d a b (aref m 5) 11 '(28377 . 60321))
|
||||
b (md4-round3 b c d a (aref m 13) 15 '(28377 . 60321))
|
||||
a (md4-round3 a b c d (aref m 3) 3 '(28377 . 60321))
|
||||
d (md4-round3 d a b c (aref m 11) 9 '(28377 . 60321))
|
||||
c (md4-round3 c d a b (aref m 7) 11 '(28377 . 60321))
|
||||
b (md4-round3 b c d a (aref m 15) 15 '(28377 . 60321)))
|
||||
|
||||
(aset md4-buffer 0 (md4-add a (aref md4-buffer 0)))
|
||||
(aset md4-buffer 1 (md4-add b (aref md4-buffer 1)))
|
||||
(aset md4-buffer 2 (md4-add c (aref md4-buffer 2)))
|
||||
(aset md4-buffer 3 (md4-add d (aref md4-buffer 3)))
|
||||
))
|
||||
|
||||
(defun md4-copy64 (seq)
|
||||
"Unpack a 64 bytes string into 16 pairs of 32 bits integers."
|
||||
(let ((int32s (make-vector 16 0)) (i 0) j)
|
||||
(while (< i 16)
|
||||
(setq j (* i 4))
|
||||
(aset int32s i (cons (+ (aref seq (+ j 2)) (lsh (aref seq (+ j 3)) 8))
|
||||
(+ (aref seq j) (lsh (aref seq (1+ j)) 8))))
|
||||
(setq i (1+ i)))
|
||||
int32s))
|
||||
|
||||
;;;
|
||||
;;; sub functions
|
||||
|
||||
(defun md4-pack-int16 (int16)
|
||||
"Pack 16 bits integer in 2 bytes string as little endian."
|
||||
(let ((str (make-string 2 0)))
|
||||
(aset str 0 (logand int16 255))
|
||||
(aset str 1 (lsh int16 -8))
|
||||
str))
|
||||
|
||||
(defun md4-pack-int32 (int32)
|
||||
"Pack 32 bits integer in a 4 bytes string as little endian. A 32 bits
|
||||
integer is represented as a pair of two 16 bits integers (cons high low)."
|
||||
(let ((str (make-string 4 0))
|
||||
(h (car int32)) (l (cdr int32)))
|
||||
(aset str 0 (logand l 255))
|
||||
(aset str 1 (lsh l -8))
|
||||
(aset str 2 (logand h 255))
|
||||
(aset str 3 (lsh h -8))
|
||||
str))
|
||||
|
||||
(defun md4-unpack-int16 (str)
|
||||
(if (eq 2 (length str))
|
||||
(+ (lsh (aref str 1) 8) (aref str 0))
|
||||
(error "%s is not 2 bytes long" str)))
|
||||
|
||||
(defun md4-unpack-int32 (str)
|
||||
(if (eq 4 (length str))
|
||||
(cons (+ (lsh (aref str 3) 8) (aref str 2))
|
||||
(+ (lsh (aref str 1) 8) (aref str 0)))
|
||||
(error "%s is not 4 bytes long" str)))
|
||||
|
||||
(provide 'md4)
|
||||
|
||||
;;; md4.el ends here
|
||||
55
flim-1.14.9/md5-dl.el
Normal file
55
flim-1.14.9/md5-dl.el
Normal file
@ -0,0 +1,55 @@
|
||||
;;; md5-dl.el --- MD5 Message Digest Algorithm using DL module.
|
||||
|
||||
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: MD5, RFC 1321
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(provide 'md5-dl) ; beware of circular dependency.
|
||||
(eval-when-compile (require 'md5)) ; md5-dl-module.
|
||||
|
||||
;;; This file is loaded (from "md5.el") only when md5-dl-module is exists.
|
||||
(defvar md5-dl-handle (dynamic-link md5-dl-module))
|
||||
|
||||
;;; md5-dl-module provides `md5-string'.
|
||||
(dynamic-call "emacs_md5_init" md5-dl-handle)
|
||||
|
||||
(defun md5-region (beg end)
|
||||
(md5-string (buffer-substring-no-properties beg end)))
|
||||
|
||||
;;; Note that v21 `md5' takes two more args: CODING and NOERROR.
|
||||
(defun md5 (object &optional beg end)
|
||||
"Return the MD5 (a secure message digest algorithm) of an object.
|
||||
OBJECT is either a string or a buffer.
|
||||
Optional arguments BEG and END denote buffer positions for computing the
|
||||
hash of a portion of OBJECT."
|
||||
(if (stringp object)
|
||||
(md5-string object)
|
||||
(save-excursion
|
||||
(set-buffer object)
|
||||
(md5-region (or beg (point-min)) (or end (point-max))))))
|
||||
|
||||
(provide 'md5-dl)
|
||||
|
||||
;;; md5-dl.el ends here
|
||||
408
flim-1.14.9/md5-el.el
Normal file
408
flim-1.14.9/md5-el.el
Normal file
@ -0,0 +1,408 @@
|
||||
;;; md5.el -- MD5 Message Digest Algorithm
|
||||
;;; Gareth Rees <gdr11@cl.cam.ac.uk>
|
||||
|
||||
;; LCD Archive Entry:
|
||||
;; md5|Gareth Rees|gdr11@cl.cam.ac.uk|
|
||||
;; MD5 cryptographic message digest algorithm|
|
||||
;; 13-Nov-95|1.0|~/misc/md5.el.Z|
|
||||
|
||||
;;; Details: ------------------------------------------------------------------
|
||||
|
||||
;; This is a direct translation into Emacs LISP of the reference C
|
||||
;; implementation of the MD5 Message-Digest Algorithm written by RSA
|
||||
;; Data Security, Inc.
|
||||
;;
|
||||
;; The algorithm takes a message (that is, a string of bytes) and
|
||||
;; computes a 16-byte checksum or "digest" for the message. This digest
|
||||
;; is supposed to be cryptographically strong in the sense that if you
|
||||
;; are given a 16-byte digest D, then there is no easier way to
|
||||
;; construct a message whose digest is D than to exhaustively search the
|
||||
;; space of messages. However, the robustness of the algorithm has not
|
||||
;; been proven, and a similar algorithm (MD4) was shown to be unsound,
|
||||
;; so treat with caution!
|
||||
;;
|
||||
;; The C algorithm uses 32-bit integers; because GNU Emacs
|
||||
;; implementations provide 28-bit integers (with 24-bit integers on
|
||||
;; versions prior to 19.29), the code represents a 32-bit integer as the
|
||||
;; cons of two 16-bit integers. The most significant word is stored in
|
||||
;; the car and the least significant in the cdr. The algorithm requires
|
||||
;; at least 17 bits of integer representation in order to represent the
|
||||
;; carry from a 16-bit addition.
|
||||
|
||||
;;; Usage: --------------------------------------------------------------------
|
||||
|
||||
;; To compute the MD5 Message Digest for a message M (represented as a
|
||||
;; string or as a vector of bytes), call
|
||||
;;
|
||||
;; (md5-encode M)
|
||||
;;
|
||||
;; which returns the message digest as a vector of 16 bytes. If you
|
||||
;; need to supply the message in pieces M1, M2, ... Mn, then call
|
||||
;;
|
||||
;; (md5-init)
|
||||
;; (md5-update M1)
|
||||
;; (md5-update M2)
|
||||
;; ...
|
||||
;; (md5-update Mn)
|
||||
;; (md5-final)
|
||||
|
||||
;;; Copyright and licence: ----------------------------------------------------
|
||||
|
||||
;; Copyright (C) 1995, 1996, 1997 by Gareth Rees
|
||||
;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm
|
||||
;;
|
||||
;; md5.el 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.
|
||||
;;
|
||||
;; md5.el 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.
|
||||
;;
|
||||
;; The original copyright notice is given below, as required by the
|
||||
;; licence for the original code. This code is distributed under *both*
|
||||
;; RSA's original licence and the GNU General Public Licence. (There
|
||||
;; should be no problems, as the former is more liberal than the
|
||||
;; latter).
|
||||
|
||||
;;; Original copyright notice: ------------------------------------------------
|
||||
|
||||
;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved.
|
||||
;;
|
||||
;; License to copy and use this software is granted provided that it is
|
||||
;; identified as the "RSA Data Security, Inc. MD5 Message- Digest
|
||||
;; Algorithm" in all material mentioning or referencing this software or
|
||||
;; this function.
|
||||
;;
|
||||
;; License is also granted to make and use derivative works provided
|
||||
;; that such works are identified as "derived from the RSA Data
|
||||
;; Security, Inc. MD5 Message-Digest Algorithm" in all material
|
||||
;; mentioning or referencing the derived work.
|
||||
;;
|
||||
;; RSA Data Security, Inc. makes no representations concerning either
|
||||
;; the merchantability of this software or the suitability of this
|
||||
;; software for any particular purpose. It is provided "as is" without
|
||||
;; express or implied warranty of any kind.
|
||||
;;
|
||||
;; These notices must be retained in any copies of any part of this
|
||||
;; documentation and/or software.
|
||||
|
||||
;;; Code: ---------------------------------------------------------------------
|
||||
|
||||
(defvar md5-program "md5"
|
||||
"*Program that reads a message on its standard input and writes an
|
||||
MD5 digest on its output.")
|
||||
|
||||
(defvar md5-maximum-internal-length 4096
|
||||
"*The maximum size of a piece of data that should use the MD5 routines
|
||||
written in lisp. If a message exceeds this, it will be run through an
|
||||
external filter for processing. Also see the `md5-program' variable.
|
||||
This variable has no effect if you call the md5-init|update|final
|
||||
functions - only used by the `md5' function's simpler interface.")
|
||||
|
||||
(defvar md5-bits (make-vector 4 0)
|
||||
"Number of bits handled, modulo 2^64.
|
||||
Represented as four 16-bit numbers, least significant first.")
|
||||
(defvar md5-buffer (make-vector 4 '(0 . 0))
|
||||
"Scratch buffer (four 32-bit integers).")
|
||||
(defvar md5-input (make-vector 64 0)
|
||||
"Input buffer (64 bytes).")
|
||||
|
||||
(defun md5-unhex (x)
|
||||
(if (> x ?9)
|
||||
(if (>= x ?a)
|
||||
(+ 10 (- x ?a))
|
||||
(+ 10 (- x ?A)))
|
||||
(- x ?0)))
|
||||
|
||||
(defun md5-encode (message)
|
||||
"Encodes MESSAGE using the MD5 message digest algorithm.
|
||||
MESSAGE must be a string or an array of bytes.
|
||||
Returns a vector of 16 bytes containing the message digest."
|
||||
(if (or (null md5-maximum-internal-length)
|
||||
(<= (length message) md5-maximum-internal-length))
|
||||
(progn
|
||||
(md5-init)
|
||||
(md5-update message)
|
||||
(md5-final))
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer-create " *md5-work*"))
|
||||
(erase-buffer)
|
||||
(insert message)
|
||||
(call-process-region (point-min) (point-max)
|
||||
md5-program
|
||||
t (current-buffer))
|
||||
;; MD5 digest is 32 chars long
|
||||
;; mddriver adds a newline to make neaten output for tty
|
||||
;; viewing, make sure we leave it behind.
|
||||
(let ((data (buffer-substring (point-min) (+ (point-min) 32)))
|
||||
(vec (make-vector 16 0))
|
||||
(ctr 0))
|
||||
(while (< ctr 16)
|
||||
(aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2))))
|
||||
(md5-unhex (aref data (1+ (* ctr 2))))))
|
||||
(setq ctr (1+ ctr)))))))
|
||||
|
||||
(defsubst md5-add (x y)
|
||||
"Return 32-bit sum of 32-bit integers X and Y."
|
||||
(let ((m (+ (car x) (car y)))
|
||||
(l (+ (cdr x) (cdr y))))
|
||||
(cons (logand 65535 (+ m (lsh l -16))) (logand l 65535))))
|
||||
|
||||
;; FF, GG, HH and II are basic MD5 functions, providing transformations
|
||||
;; for rounds 1, 2, 3 and 4 respectively. Each function follows this
|
||||
;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x
|
||||
;; by y bits to the left):
|
||||
;;
|
||||
;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b
|
||||
;;
|
||||
;; so we use the macro `md5-make-step' to construct each one. The
|
||||
;; helper functions F, G, H and I operate on 16-bit numbers; the full
|
||||
;; operation splits its inputs, operates on the halves separately and
|
||||
;; then puts the results together.
|
||||
|
||||
(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z)))
|
||||
(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z))))
|
||||
(defsubst md5-H (x y z) (logxor x y z))
|
||||
(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z)))))
|
||||
|
||||
(defmacro md5-make-step (name func)
|
||||
(`
|
||||
(defun (, name) (a b c d x s ac)
|
||||
(let*
|
||||
((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac)))
|
||||
(l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac)))
|
||||
(m2 (logand 65535 (+ m1 (lsh l1 -16))))
|
||||
(l2 (logand 65535 l1))
|
||||
(m3 (logand 65535 (if (> s 15)
|
||||
(+ (lsh m2 (- s 32)) (lsh l2 (- s 16)))
|
||||
(+ (lsh m2 s) (lsh l2 (- s 16))))))
|
||||
(l3 (logand 65535 (if (> s 15)
|
||||
(+ (lsh l2 (- s 32)) (lsh m2 (- s 16)))
|
||||
(+ (lsh l2 s) (lsh m2 (- s 16)))))))
|
||||
(md5-add (cons m3 l3) b)))))
|
||||
|
||||
(md5-make-step md5-FF md5-F)
|
||||
(md5-make-step md5-GG md5-G)
|
||||
(md5-make-step md5-HH md5-H)
|
||||
(md5-make-step md5-II md5-I)
|
||||
|
||||
(defun md5-init ()
|
||||
"Initialise the state of the message-digest routines."
|
||||
(aset md5-bits 0 0)
|
||||
(aset md5-bits 1 0)
|
||||
(aset md5-bits 2 0)
|
||||
(aset md5-bits 3 0)
|
||||
(aset md5-buffer 0 '(26437 . 8961))
|
||||
(aset md5-buffer 1 '(61389 . 43913))
|
||||
(aset md5-buffer 2 '(39098 . 56574))
|
||||
(aset md5-buffer 3 '( 4146 . 21622)))
|
||||
|
||||
(defun md5-update (string)
|
||||
"Update the current MD5 state with STRING (an array of bytes)."
|
||||
(let ((len (length string))
|
||||
(i 0)
|
||||
(j 0))
|
||||
(while (< i len)
|
||||
;; Compute number of bytes modulo 64
|
||||
(setq j (% (/ (aref md5-bits 0) 8) 64))
|
||||
|
||||
;; Store this byte (truncating to 8 bits to be sure)
|
||||
(aset md5-input j (logand 255 (aref string i)))
|
||||
|
||||
;; Update number of bits by 8 (modulo 2^64)
|
||||
(let ((c 8) (k 0))
|
||||
(while (and (> c 0) (< k 4))
|
||||
(let ((b (aref md5-bits k)))
|
||||
(aset md5-bits k (logand 65535 (+ b c)))
|
||||
(setq c (if (> b (- 65535 c)) 1 0)
|
||||
k (1+ k)))))
|
||||
|
||||
;; Increment number of bytes processed
|
||||
(setq i (1+ i))
|
||||
|
||||
;; When 64 bytes accumulated, pack them into sixteen 32-bit
|
||||
;; integers in the array `in' and then tranform them.
|
||||
(if (= j 63)
|
||||
(let ((in (make-vector 16 (cons 0 0)))
|
||||
(k 0)
|
||||
(kk 0))
|
||||
(while (< k 16)
|
||||
(aset in k (md5-pack md5-input kk))
|
||||
(setq k (+ k 1) kk (+ kk 4)))
|
||||
(md5-transform in))))))
|
||||
|
||||
(defun md5-pack (array i)
|
||||
"Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer."
|
||||
(cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2)))
|
||||
(+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0)))))
|
||||
|
||||
(defun md5-byte (array n b)
|
||||
"Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers."
|
||||
(let ((e (aref array n)))
|
||||
(cond ((eq b 0) (logand 255 (cdr e)))
|
||||
((eq b 1) (lsh (cdr e) -8))
|
||||
((eq b 2) (logand 255 (car e)))
|
||||
((eq b 3) (lsh (car e) -8)))))
|
||||
|
||||
(defun md5-final ()
|
||||
(let ((in (make-vector 16 (cons 0 0)))
|
||||
(j 0)
|
||||
(digest (make-vector 16 0))
|
||||
(padding))
|
||||
|
||||
;; Save the number of bits in the message
|
||||
(aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0)))
|
||||
(aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2)))
|
||||
|
||||
;; Compute number of bytes modulo 64
|
||||
(setq j (% (/ (aref md5-bits 0) 8) 64))
|
||||
|
||||
;; Pad out computation to 56 bytes modulo 64
|
||||
(setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0))
|
||||
(aset padding 0 128)
|
||||
(md5-update padding)
|
||||
|
||||
;; Append length in bits and transform
|
||||
(let ((k 0) (kk 0))
|
||||
(while (< k 14)
|
||||
(aset in k (md5-pack md5-input kk))
|
||||
(setq k (+ k 1) kk (+ kk 4))))
|
||||
(md5-transform in)
|
||||
|
||||
;; Store the results in the digest
|
||||
(let ((k 0) (kk 0))
|
||||
(while (< k 4)
|
||||
(aset digest (+ kk 0) (md5-byte md5-buffer k 0))
|
||||
(aset digest (+ kk 1) (md5-byte md5-buffer k 1))
|
||||
(aset digest (+ kk 2) (md5-byte md5-buffer k 2))
|
||||
(aset digest (+ kk 3) (md5-byte md5-buffer k 3))
|
||||
(setq k (+ k 1) kk (+ kk 4))))
|
||||
|
||||
;; Return digest
|
||||
digest))
|
||||
|
||||
;; It says in the RSA source, "Note that if the Mysterious Constants are
|
||||
;; arranged backwards in little-endian order and decrypted with the DES
|
||||
;; they produce OCCULT MESSAGES!" Security through obscurity?
|
||||
|
||||
(defun md5-transform (in)
|
||||
"Basic MD5 step. Transform md5-buffer based on array IN."
|
||||
(let ((a (aref md5-buffer 0))
|
||||
(b (aref md5-buffer 1))
|
||||
(c (aref md5-buffer 2))
|
||||
(d (aref md5-buffer 3)))
|
||||
(setq
|
||||
a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104))
|
||||
d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934))
|
||||
c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891))
|
||||
b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974))
|
||||
a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015))
|
||||
d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730))
|
||||
c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939))
|
||||
b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145))
|
||||
a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128))
|
||||
d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407))
|
||||
c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473))
|
||||
b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230))
|
||||
a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386))
|
||||
d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075))
|
||||
c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294))
|
||||
b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081))
|
||||
a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570))
|
||||
d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888))
|
||||
c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121))
|
||||
b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114))
|
||||
a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189))
|
||||
d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203))
|
||||
c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009))
|
||||
b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456))
|
||||
a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710))
|
||||
d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006))
|
||||
c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463))
|
||||
b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357))
|
||||
a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653))
|
||||
d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976))
|
||||
c (md5-GG c d a b (aref in 7) 14 '(26479 . 729))
|
||||
b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594))
|
||||
a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658))
|
||||
d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105))
|
||||
c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866))
|
||||
b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348))
|
||||
a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972))
|
||||
d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161))
|
||||
c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296))
|
||||
b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240))
|
||||
a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454))
|
||||
d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234))
|
||||
c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421))
|
||||
b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429))
|
||||
a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305))
|
||||
d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397))
|
||||
c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992))
|
||||
b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117))
|
||||
a (md5-II a b c d (aref in 0) 6 '(62505 . 8772))
|
||||
d (md5-II d a b c (aref in 7) 10 '(17194 . 65431))
|
||||
c (md5-II c d a b (aref in 14) 15 '(43924 . 9127))
|
||||
b (md5-II b c d a (aref in 5) 21 '(64659 . 41017))
|
||||
a (md5-II a b c d (aref in 12) 6 '(25947 . 22979))
|
||||
d (md5-II d a b c (aref in 3) 10 '(36620 . 52370))
|
||||
c (md5-II c d a b (aref in 10) 15 '(65519 . 62589))
|
||||
b (md5-II b c d a (aref in 1) 21 '(34180 . 24017))
|
||||
a (md5-II a b c d (aref in 8) 6 '(28584 . 32335))
|
||||
d (md5-II d a b c (aref in 15) 10 '(65068 . 59104))
|
||||
c (md5-II c d a b (aref in 6) 15 '(41729 . 17172))
|
||||
b (md5-II b c d a (aref in 13) 21 '(19976 . 4513))
|
||||
a (md5-II a b c d (aref in 4) 6 '(63315 . 32386))
|
||||
d (md5-II d a b c (aref in 11) 10 '(48442 . 62005))
|
||||
c (md5-II c d a b (aref in 2) 15 '(10967 . 53947))
|
||||
b (md5-II b c d a (aref in 9) 21 '(60294 . 54161)))
|
||||
|
||||
(aset md5-buffer 0 (md5-add (aref md5-buffer 0) a))
|
||||
(aset md5-buffer 1 (md5-add (aref md5-buffer 1) b))
|
||||
(aset md5-buffer 2 (md5-add (aref md5-buffer 2) c))
|
||||
(aset md5-buffer 3 (md5-add (aref md5-buffer 3) d))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Here begins the merger with the XEmacs API and the md5.el from the URL
|
||||
;;; package. Courtesy wmperry@cs.indiana.edu
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(defun md5 (object &optional start end)
|
||||
"Return the MD5 (a secure message digest algorithm) of an object.
|
||||
OBJECT is either a string or a buffer.
|
||||
Optional arguments START and END denote buffer positions for computing the
|
||||
hash of a portion of OBJECT."
|
||||
(let ((buffer nil))
|
||||
(unwind-protect
|
||||
(save-excursion
|
||||
(setq buffer (generate-new-buffer " *md5-work*"))
|
||||
(set-buffer buffer)
|
||||
(cond
|
||||
((bufferp object)
|
||||
(insert-buffer-substring object start end))
|
||||
((stringp object)
|
||||
(insert (if (or start end)
|
||||
(substring object start end)
|
||||
object)))
|
||||
(t nil))
|
||||
(prog1
|
||||
(if (or (null md5-maximum-internal-length)
|
||||
(<= (point-max) md5-maximum-internal-length))
|
||||
(mapconcat
|
||||
(function (lambda (node) (format "%02x" node)))
|
||||
(md5-encode (buffer-string))
|
||||
"")
|
||||
(call-process-region (point-min) (point-max)
|
||||
shell-file-name
|
||||
t buffer nil
|
||||
shell-command-switch md5-program)
|
||||
;; MD5 digest is 32 chars long
|
||||
;; mddriver adds a newline to make neaten output for tty
|
||||
;; viewing, make sure we leave it behind.
|
||||
(buffer-substring (point-min) (+ (point-min) 32)))
|
||||
(kill-buffer buffer)))
|
||||
(and buffer (buffer-name buffer) (kill-buffer buffer) nil))))
|
||||
|
||||
(provide 'md5-el)
|
||||
79
flim-1.14.9/md5.el
Normal file
79
flim-1.14.9/md5.el
Normal file
@ -0,0 +1,79 @@
|
||||
;;; md5.el --- MD5 Message Digest Algorithm.
|
||||
|
||||
;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: MD5, RFC 1321
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Test cases from RFC 1321.
|
||||
;;
|
||||
;; (md5 "")
|
||||
;; => d41d8cd98f00b204e9800998ecf8427e
|
||||
;;
|
||||
;; (md5 "a")
|
||||
;; => 0cc175b9c0f1b6a831c399e269772661
|
||||
;;
|
||||
;; (md5 "abc")
|
||||
;; => 900150983cd24fb0d6963f7d28e17f72
|
||||
;;
|
||||
;; (md5 "message digest")
|
||||
;; => f96b697d7cb7938d525a2f31aaf161d0
|
||||
;;
|
||||
;; (md5 "abcdefghijklmnopqrstuvwxyz")
|
||||
;; => c3fcd3d76192e4007dfb496cca67e13b
|
||||
;;
|
||||
;; (md5 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")
|
||||
;; => d174ab98d277d9f5a5611c2c9f419d9f
|
||||
;;
|
||||
;; (md5 "12345678901234567890123456789012345678901234567890123456789012345678901234567890")
|
||||
;; => 57edf4a22be3c955ac49da2e2107b67a
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar md5-dl-module
|
||||
(cond
|
||||
((and (fboundp 'md5)
|
||||
(subrp (symbol-function 'md5)))
|
||||
nil)
|
||||
((fboundp 'dynamic-link)
|
||||
;; Should we take care of `dynamic-link-path'?
|
||||
(let ((path (expand-file-name "md5.so" exec-directory)))
|
||||
(if (file-exists-p path)
|
||||
path
|
||||
nil)))
|
||||
(t
|
||||
nil)))
|
||||
|
||||
(cond
|
||||
((and (fboundp 'md5)
|
||||
(subrp (symbol-function 'md5)))
|
||||
;; do nothing.
|
||||
)
|
||||
((and (stringp md5-dl-module)
|
||||
(file-exists-p md5-dl-module))
|
||||
(require 'md5-dl))
|
||||
(t
|
||||
(require 'md5-el)))
|
||||
|
||||
(provide 'md5)
|
||||
|
||||
;;; md5.el ends here
|
||||
481
flim-1.14.9/mel-b-ccl.el
Normal file
481
flim-1.14.9/mel-b-ccl.el
Normal file
@ -0,0 +1,481 @@
|
||||
;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL.
|
||||
|
||||
;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Tanaka Akira <akr@m17n.org>
|
||||
;; Created: 1998/9/17
|
||||
;; Keywords: MIME, Base64
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ccl)
|
||||
(require 'pccl)
|
||||
(require 'mime-def)
|
||||
|
||||
|
||||
;;; @ constants
|
||||
;;;
|
||||
|
||||
(eval-when-compile
|
||||
|
||||
(defconst mel-ccl-4-table
|
||||
'( 0 1 2 3))
|
||||
|
||||
(defconst mel-ccl-16-table
|
||||
'( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))
|
||||
|
||||
(defconst mel-ccl-64-table
|
||||
'( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
|
||||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
|
||||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
|
||||
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63))
|
||||
|
||||
(defconst mel-ccl-256-table
|
||||
'( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
|
||||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
|
||||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
|
||||
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
|
||||
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
|
||||
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
|
||||
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
|
||||
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
|
||||
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
|
||||
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
|
||||
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
|
||||
176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
|
||||
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207
|
||||
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
|
||||
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
|
||||
240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255))
|
||||
|
||||
(defconst mel-ccl-256-to-64-table
|
||||
'(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil 62 nil nil nil 63
|
||||
52 53 54 55 56 57 58 59 60 61 nil nil nil t nil nil
|
||||
nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
|
||||
15 16 17 18 19 20 21 22 23 24 25 nil nil nil nil nil
|
||||
nil 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
|
||||
41 42 43 44 45 46 47 48 49 50 51 nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
|
||||
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
|
||||
|
||||
(defconst mel-ccl-64-to-256-table
|
||||
(mapcar
|
||||
'char-int
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZ\
|
||||
abcdefghijklmnopqrstuvwxyz\
|
||||
0123456789\
|
||||
+/"))
|
||||
|
||||
)
|
||||
|
||||
|
||||
;;; @ CCL programs
|
||||
;;;
|
||||
|
||||
(eval-when-compile
|
||||
|
||||
(defun mel-ccl-decode-b-bit-ex (v)
|
||||
(logior
|
||||
(lsh (logand v (lsh 255 16)) -16)
|
||||
(logand v (lsh 255 8))
|
||||
(lsh (logand v 255) 16)))
|
||||
|
||||
)
|
||||
|
||||
(eval-when-compile
|
||||
|
||||
(defconst mel-ccl-decode-b-0-table
|
||||
(vconcat
|
||||
(mapcar
|
||||
(lambda (v)
|
||||
(if (integerp v)
|
||||
(mel-ccl-decode-b-bit-ex (lsh v 18))
|
||||
(lsh 1 24)))
|
||||
mel-ccl-256-to-64-table)))
|
||||
|
||||
(defconst mel-ccl-decode-b-1-table
|
||||
(vconcat
|
||||
(mapcar
|
||||
(lambda (v)
|
||||
(if (integerp v)
|
||||
(mel-ccl-decode-b-bit-ex (lsh v 12))
|
||||
(lsh 1 25)))
|
||||
mel-ccl-256-to-64-table)))
|
||||
|
||||
(defconst mel-ccl-decode-b-2-table
|
||||
(vconcat
|
||||
(mapcar
|
||||
(lambda (v)
|
||||
(if (integerp v)
|
||||
(mel-ccl-decode-b-bit-ex (lsh v 6))
|
||||
(lsh 1 26)))
|
||||
mel-ccl-256-to-64-table)))
|
||||
|
||||
(defconst mel-ccl-decode-b-3-table
|
||||
(vconcat
|
||||
(mapcar
|
||||
(lambda (v)
|
||||
(if (integerp v)
|
||||
(mel-ccl-decode-b-bit-ex v)
|
||||
(lsh 1 27)))
|
||||
mel-ccl-256-to-64-table)))
|
||||
|
||||
)
|
||||
|
||||
(check-broken-facility ccl-cascading-read)
|
||||
|
||||
(if-broken ccl-cascading-read
|
||||
(define-ccl-program mel-ccl-decode-b
|
||||
`(1
|
||||
(loop
|
||||
(loop
|
||||
(read-branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (v)
|
||||
(cond
|
||||
((or (eq v nil) (eq v t)) '(repeat))
|
||||
(t `((r0 = ,(lsh v 2)) (break)))))
|
||||
mel-ccl-256-to-64-table)))
|
||||
(loop
|
||||
(read-branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (v)
|
||||
(cond
|
||||
((or (eq v nil) (eq v t)) '(repeat))
|
||||
((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
|
||||
(t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))))
|
||||
mel-ccl-256-to-64-table)))
|
||||
(loop
|
||||
(read-branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (v)
|
||||
(cond
|
||||
((eq v nil) '(repeat))
|
||||
((eq v t) '(end))
|
||||
((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
|
||||
(t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))))
|
||||
mel-ccl-256-to-64-table)))
|
||||
(loop
|
||||
(read-branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (v)
|
||||
(cond
|
||||
((eq v nil) '(repeat))
|
||||
((eq v t) '(end))
|
||||
(t `((r0 |= ,v) (write r0) (break)))))
|
||||
mel-ccl-256-to-64-table)))
|
||||
(repeat))))
|
||||
(define-ccl-program mel-ccl-decode-b
|
||||
`(1
|
||||
(loop
|
||||
(read r0 r1 r2 r3)
|
||||
(r4 = r0 ,mel-ccl-decode-b-0-table)
|
||||
(r5 = r1 ,mel-ccl-decode-b-1-table)
|
||||
(r4 |= r5)
|
||||
(r5 = r2 ,mel-ccl-decode-b-2-table)
|
||||
(r4 |= r5)
|
||||
(r5 = r3 ,mel-ccl-decode-b-3-table)
|
||||
(r4 |= r5)
|
||||
(if (r4 & ,(lognot (1- (lsh 1 24))))
|
||||
((loop
|
||||
(if (r4 & ,(lsh 1 24))
|
||||
((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
|
||||
(r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
|
||||
(r5 = r3 ,mel-ccl-decode-b-3-table)
|
||||
(r4 |= r5)
|
||||
(repeat))
|
||||
(break)))
|
||||
(loop
|
||||
(if (r4 & ,(lsh 1 25))
|
||||
((r1 = r2) (r2 = r3) (read r3)
|
||||
(r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
|
||||
(r5 = r3 ,mel-ccl-decode-b-3-table)
|
||||
(r4 |= r5)
|
||||
(repeat))
|
||||
(break)))
|
||||
(loop
|
||||
(if (r2 != ?=)
|
||||
(if (r4 & ,(lsh 1 26))
|
||||
((r2 = r3) (read r3)
|
||||
(r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
|
||||
(r5 = r3 ,mel-ccl-decode-b-3-table)
|
||||
(r4 |= r5)
|
||||
(repeat))
|
||||
((r6 = 0)
|
||||
(break)))
|
||||
((r6 = 1)
|
||||
(break))))
|
||||
(loop
|
||||
(if (r3 != ?=)
|
||||
(if (r4 & ,(lsh 1 27))
|
||||
((read r3)
|
||||
(r4 = r3 ,mel-ccl-decode-b-3-table)
|
||||
(repeat))
|
||||
(break))
|
||||
((r6 |= 2)
|
||||
(break))))
|
||||
(r4 = r0 ,mel-ccl-decode-b-0-table)
|
||||
(r5 = r1 ,mel-ccl-decode-b-1-table)
|
||||
(r4 |= r5)
|
||||
(branch
|
||||
r6
|
||||
;; BBBB
|
||||
((r5 = r2 ,mel-ccl-decode-b-2-table)
|
||||
(r4 |= r5)
|
||||
(r5 = r3 ,mel-ccl-decode-b-3-table)
|
||||
(r4 |= r5)
|
||||
(r4 >8= 0)
|
||||
(write r7)
|
||||
(r4 >8= 0)
|
||||
(write r7)
|
||||
(write-repeat r4))
|
||||
;; error: BB=B
|
||||
((write (r4 & 255))
|
||||
(end))
|
||||
;; BBB=
|
||||
((r5 = r2 ,mel-ccl-decode-b-2-table)
|
||||
(r4 |= r5)
|
||||
(r4 >8= 0)
|
||||
(write r7)
|
||||
(write (r4 & 255))
|
||||
(end) ; Excessive (end) is workaround for XEmacs 21.0.
|
||||
; Without this, "AAA=" is converted to "^@^@^@".
|
||||
(end))
|
||||
;; BB==
|
||||
((write (r4 & 255))
|
||||
(end))))
|
||||
((r4 >8= 0)
|
||||
(write r7)
|
||||
(r4 >8= 0)
|
||||
(write r7)
|
||||
(write-repeat r4))))))
|
||||
)
|
||||
|
||||
(eval-when-compile
|
||||
|
||||
;; Generated CCL program works not properly on 20.2 because CCL_EOF_BLOCK
|
||||
;; is not executed.
|
||||
(defun mel-ccl-encode-base64-generic
|
||||
(&optional quantums-per-line output-crlf terminate-with-newline)
|
||||
`(2
|
||||
((r3 = 0)
|
||||
(r2 = 0)
|
||||
(read r1)
|
||||
(loop
|
||||
(branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (r1)
|
||||
`((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
|
||||
(r0 = ,(logand r1 3))))
|
||||
mel-ccl-256-table))
|
||||
(r2 = 1)
|
||||
(read-branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (r1)
|
||||
`((write r0 ,(vconcat
|
||||
(mapcar
|
||||
(lambda (r0)
|
||||
(nth (logior (lsh r0 4)
|
||||
(lsh r1 -4))
|
||||
mel-ccl-64-to-256-table))
|
||||
mel-ccl-4-table)))
|
||||
(r0 = ,(logand r1 15))))
|
||||
mel-ccl-256-table))
|
||||
(r2 = 2)
|
||||
(read-branch
|
||||
r1
|
||||
,@(mapcar
|
||||
(lambda (r1)
|
||||
`((write r0 ,(vconcat
|
||||
(mapcar
|
||||
(lambda (r0)
|
||||
(nth (logior (lsh r0 2)
|
||||
(lsh r1 -6))
|
||||
mel-ccl-64-to-256-table))
|
||||
mel-ccl-16-table)))))
|
||||
mel-ccl-256-table))
|
||||
(r1 &= 63)
|
||||
(write r1 ,(vconcat
|
||||
(mapcar
|
||||
(lambda (r1)
|
||||
(nth r1 mel-ccl-64-to-256-table))
|
||||
mel-ccl-64-table)))
|
||||
(r3 += 1)
|
||||
(r2 = 0)
|
||||
(read r1)
|
||||
,@(when quantums-per-line
|
||||
`((if (r3 == ,quantums-per-line)
|
||||
((write ,(if output-crlf "\r\n" "\n"))
|
||||
(r3 = 0)))))
|
||||
(repeat)))
|
||||
(branch
|
||||
r2
|
||||
,(if terminate-with-newline
|
||||
`(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
|
||||
`(r0 = 0))
|
||||
((write r0 ,(vconcat
|
||||
(mapcar
|
||||
(lambda (r0)
|
||||
(nth (lsh r0 4) mel-ccl-64-to-256-table))
|
||||
mel-ccl-4-table)))
|
||||
(write ,(if terminate-with-newline
|
||||
(if output-crlf "==\r\n" "==\n")
|
||||
"==")))
|
||||
((write r0 ,(vconcat
|
||||
(mapcar
|
||||
(lambda (r0)
|
||||
(nth (lsh r0 2) mel-ccl-64-to-256-table))
|
||||
mel-ccl-16-table)))
|
||||
(write ,(if terminate-with-newline
|
||||
(if output-crlf "=\r\n" "=\n")
|
||||
"="))))
|
||||
))
|
||||
)
|
||||
|
||||
(define-ccl-program mel-ccl-encode-b
|
||||
(mel-ccl-encode-base64-generic))
|
||||
|
||||
;; 19 * 4 = 76
|
||||
(define-ccl-program mel-ccl-encode-base64-crlf-crlf
|
||||
(mel-ccl-encode-base64-generic 19 t))
|
||||
|
||||
(define-ccl-program mel-ccl-encode-base64-crlf-lf
|
||||
(mel-ccl-encode-base64-generic 19 nil))
|
||||
|
||||
|
||||
;;; @ coding system
|
||||
;;;
|
||||
|
||||
(make-ccl-coding-system
|
||||
'mel-ccl-b-rev ?B "MIME B-encoding (reversed)"
|
||||
'mel-ccl-encode-b 'mel-ccl-decode-b)
|
||||
|
||||
(make-ccl-coding-system
|
||||
'mel-ccl-base64-crlf-rev
|
||||
?B "MIME Base64-encoding (reversed)"
|
||||
'mel-ccl-encode-base64-crlf-crlf
|
||||
'mel-ccl-decode-b)
|
||||
|
||||
(make-ccl-coding-system
|
||||
'mel-ccl-base64-lf-rev
|
||||
?B "MIME Base64-encoding (LF encoding) (reversed)"
|
||||
'mel-ccl-encode-base64-crlf-lf
|
||||
'mel-ccl-decode-b)
|
||||
|
||||
|
||||
;;; @ B
|
||||
;;;
|
||||
|
||||
(check-broken-facility ccl-execute-eof-block-on-decoding-some)
|
||||
|
||||
(unless-broken ccl-execute-eof-block-on-decoding-some
|
||||
|
||||
(defun base64-ccl-encode-string (string &optional no-line-break)
|
||||
"Encode STRING with base64 encoding."
|
||||
(if no-line-break
|
||||
(decode-coding-string string 'mel-ccl-b-rev)
|
||||
(decode-coding-string string 'mel-ccl-base64-lf-rev)))
|
||||
(defalias-maybe 'base64-encode-string 'base64-ccl-encode-string)
|
||||
|
||||
(defun base64-ccl-encode-region (start end &optional no-line-break)
|
||||
"Encode region from START to END with base64 encoding."
|
||||
(interactive "*r")
|
||||
(if no-line-break
|
||||
(decode-coding-region start end 'mel-ccl-b-rev)
|
||||
(decode-coding-region start end 'mel-ccl-base64-lf-rev)))
|
||||
(defalias-maybe 'base64-encode-region 'base64-ccl-encode-region)
|
||||
|
||||
(defun base64-ccl-insert-encoded-file (filename)
|
||||
"Encode contents of file FILENAME to base64, and insert the result."
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(insert
|
||||
(decode-coding-string
|
||||
(with-temp-buffer
|
||||
(set-buffer-multibyte nil)
|
||||
(insert-file-contents-as-binary filename)
|
||||
(buffer-string))
|
||||
'mel-ccl-base64-lf-rev)))
|
||||
|
||||
(mel-define-method-function (mime-encode-string string (nil "base64"))
|
||||
'base64-ccl-encode-string)
|
||||
(mel-define-method-function (mime-encode-region start end (nil "base64"))
|
||||
'base64-ccl-encode-region)
|
||||
(mel-define-method-function
|
||||
(mime-insert-encoded-file filename (nil "base64"))
|
||||
'base64-ccl-insert-encoded-file)
|
||||
|
||||
(mel-define-method-function (encoded-text-encode-string string (nil "B"))
|
||||
'base64-ccl-encode-string)
|
||||
)
|
||||
|
||||
(defun base64-ccl-decode-string (string)
|
||||
"Decode base64 encoded STRING"
|
||||
(encode-coding-string string 'mel-ccl-b-rev))
|
||||
(defalias-maybe 'base64-decode-string 'base64-ccl-decode-string)
|
||||
|
||||
(defun base64-ccl-decode-region (start end)
|
||||
"Decode base64 encoded the region from START to END."
|
||||
(interactive "*r")
|
||||
(encode-coding-region start end 'mel-ccl-b-rev))
|
||||
(defalias-maybe 'base64-decode-region 'base64-ccl-decode-region)
|
||||
|
||||
(defun base64-ccl-write-decoded-region (start end filename)
|
||||
"Decode the region from START to END and write out to FILENAME."
|
||||
(interactive "*r\nFWrite decoded region to file: ")
|
||||
(let ((coding-system-for-write 'mel-ccl-b-rev)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename)))
|
||||
|
||||
(mel-define-method-function (mime-decode-string string (nil "base64"))
|
||||
'base64-ccl-decode-string)
|
||||
(mel-define-method-function (mime-decode-region start end (nil "base64"))
|
||||
'base64-ccl-decode-region)
|
||||
(mel-define-method-function
|
||||
(mime-write-decoded-region start end filename (nil "base64"))
|
||||
'base64-ccl-write-decoded-region)
|
||||
|
||||
(mel-define-method encoded-text-decode-string (string (nil "B"))
|
||||
(if (string-match (eval-when-compile
|
||||
(concat "\\`" B-encoded-text-regexp "\\'"))
|
||||
string)
|
||||
(base64-ccl-decode-string string)
|
||||
(error "Invalid encoded-text %s" string)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel-b-ccl)
|
||||
|
||||
;;; mel-b-ccl.el ends here.
|
||||
114
flim-1.14.9/mel-b-dl.el
Normal file
114
flim-1.14.9/mel-b-dl.el
Normal file
@ -0,0 +1,114 @@
|
||||
;;; mel-b-dl.el --- Base64 encoder/decoder using DL module.
|
||||
|
||||
;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Keywords: MIME, Base64
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
|
||||
(defvar base64-dl-handle
|
||||
(and (stringp base64-dl-module)
|
||||
(file-exists-p base64-dl-module)
|
||||
(dynamic-link base64-dl-module)))
|
||||
|
||||
(dynamic-call "emacs_base64_init" base64-dl-handle)
|
||||
|
||||
;; base64-dl-module provides `encode-base64-string' and `decode-base64-string'.
|
||||
(defalias 'base64-encode-string 'encode-base64-string)
|
||||
(defalias 'base64-decode-string 'decode-base64-string)
|
||||
|
||||
(defun base64-encode-region (start end)
|
||||
"Encode current region by base64.
|
||||
START and END are buffer positions."
|
||||
(interactive "*r")
|
||||
(insert
|
||||
(prog1
|
||||
(base64-encode-string
|
||||
(buffer-substring start end))
|
||||
(delete-region start end)))
|
||||
(or (bolp) (insert ?\n)))
|
||||
|
||||
(defun base64-decode-region (start end)
|
||||
"Decode current region by base64.
|
||||
START and END are buffer positions."
|
||||
(interactive "*r")
|
||||
(insert
|
||||
(prog1
|
||||
(base64-decode-string
|
||||
(buffer-substring start end))
|
||||
(delete-region start end))))
|
||||
|
||||
|
||||
(mel-define-method-function (mime-encode-string string (nil "base64"))
|
||||
'base64-encode-string)
|
||||
(mel-define-method-function (mime-decode-string string (nil "base64"))
|
||||
'base64-decode-string)
|
||||
(mel-define-method-function (mime-encode-region start end (nil "base64"))
|
||||
'base64-encode-region)
|
||||
(mel-define-method-function (mime-decode-region start end (nil "base64"))
|
||||
'base64-decode-region)
|
||||
|
||||
(mel-define-method-function (encoded-text-encode-string string (nil "B"))
|
||||
'base64-encode-string)
|
||||
|
||||
(mel-define-method encoded-text-decode-string (string (nil "B"))
|
||||
(if (string-match (eval-when-compile
|
||||
(concat "\\`" B-encoded-text-regexp "\\'"))
|
||||
string)
|
||||
(base64-decode-string string)
|
||||
(error "Invalid encoded-text %s" string)))
|
||||
|
||||
|
||||
;;; @ base64 encoder/decoder for file
|
||||
;;;
|
||||
|
||||
(mel-define-method mime-insert-encoded-file (filename (nil "base64"))
|
||||
"Encode contents of file FILENAME to base64, and insert the result.
|
||||
It calls external base64 encoder specified by
|
||||
`base64-external-encoder'. So you must install the program (maybe
|
||||
mmencode included in metamail or XEmacs package)."
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(insert (base64-encode-string
|
||||
(with-temp-buffer
|
||||
(set-buffer-multibyte nil)
|
||||
(insert-file-contents-as-binary filename)
|
||||
(buffer-string))))
|
||||
(or (bolp) (insert ?\n)))
|
||||
|
||||
;; (mel-define-method mime-write-decoded-region (start end filename
|
||||
;; (nil "base64"))
|
||||
;; "Decode and write current region encoded by base64 into FILENAME.
|
||||
;; START and END are buffer positions."
|
||||
;; (interactive "*r\nFWrite decoded region to file: ")
|
||||
;; (let ((str (buffer-substring start end)))
|
||||
;; (with-temp-buffer
|
||||
;; (insert (base64-decode-string str))
|
||||
;; (write-region-as-binary (point-min)(point-max) filename))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel-b-dl)
|
||||
|
||||
;;; mel-b-dl.el ends here.
|
||||
403
flim-1.14.9/mel-b-el.el
Normal file
403
flim-1.14.9/mel-b-el.el
Normal file
@ -0,0 +1,403 @@
|
||||
;;; mel-b-el.el --- Base64 encoder/decoder.
|
||||
|
||||
;; Copyright (C) 1992,95,96,97,98,99,2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
|
||||
;; MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Created: 1995/6/24
|
||||
;; Keywords: MIME, Base64
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(eval-when-compile
|
||||
;; XXX: the macro `as-binary-process' should be provided when compiling.
|
||||
(require 'pces))
|
||||
|
||||
|
||||
;;; @ variables
|
||||
;;;
|
||||
|
||||
(defgroup base64 nil
|
||||
"Base64 encoder/decoder"
|
||||
:group 'mime)
|
||||
|
||||
(defcustom base64-external-encoder '("mmencode")
|
||||
"*list of base64 encoder program name and its arguments."
|
||||
:group 'base64
|
||||
:type '(cons (file :tag "Command")(repeat :tag "Arguments" string)))
|
||||
|
||||
(defcustom base64-external-decoder '("mmencode" "-u")
|
||||
"*list of base64 decoder program name and its arguments."
|
||||
:group 'base64
|
||||
:type '(cons (file :tag "Command")(repeat :tag "Arguments" string)))
|
||||
|
||||
(defcustom base64-external-decoder-option-to-specify-file '("-o")
|
||||
"*list of options of base64 decoder program to specify file.
|
||||
If the base64 decoder program does not have such option, set this as nil."
|
||||
:group 'base64
|
||||
:type '(repeat :tag "Arguments" string))
|
||||
|
||||
(defcustom base64-internal-encoding-limit 1000
|
||||
"*limit size to use internal base64 encoder.
|
||||
If size of input to encode is larger than this limit,
|
||||
external encoder is called."
|
||||
:group 'base64
|
||||
:type '(choice (const :tag "Always use internal encoder" nil)
|
||||
(integer :tag "Size")))
|
||||
|
||||
(defcustom base64-internal-decoding-limit (if (and (featurep 'xemacs)
|
||||
(featurep 'mule))
|
||||
1000
|
||||
7600)
|
||||
"*limit size to use internal base64 decoder.
|
||||
If size of input to decode is larger than this limit,
|
||||
external decoder is called."
|
||||
:group 'base64
|
||||
:type '(choice (const :tag "Always use internal decoder" nil)
|
||||
(integer :tag "Size")))
|
||||
|
||||
|
||||
;;; @ utility function
|
||||
;;;
|
||||
|
||||
(defun pack-sequence (seq size)
|
||||
"Split sequence SEQ into SIZE elements packs, and return list of packs.
|
||||
\[mel-b-el; tl-seq function]"
|
||||
(let ((len (length seq))
|
||||
(p 0)
|
||||
dest unit)
|
||||
(while (< p len)
|
||||
(setq unit (cons (elt seq p) unit))
|
||||
(setq p (1+ p))
|
||||
(when (zerop (mod p size))
|
||||
(setq dest (cons (nreverse unit) dest))
|
||||
(setq unit nil)))
|
||||
(if unit
|
||||
(nreverse (cons (nreverse unit) dest))
|
||||
(nreverse dest))))
|
||||
|
||||
|
||||
;;; @ internal base64 encoder
|
||||
;;; based on base64 decoder by Enami Tsugutomo
|
||||
|
||||
(eval-and-compile
|
||||
(defconst base64-characters
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
|
||||
)
|
||||
|
||||
(defmacro base64-num-to-char (n)
|
||||
`(aref base64-characters ,n))
|
||||
|
||||
(defun base64-encode-1 (pack)
|
||||
(let ((buf (make-string 4 ?=)))
|
||||
(aset buf 0 (base64-num-to-char (ash (car pack) -2)))
|
||||
(if (nth 1 pack)
|
||||
(progn
|
||||
(aset buf 1 (base64-num-to-char
|
||||
(logior (ash (logand (car pack) 3) 4)
|
||||
(ash (nth 1 pack) -4))))
|
||||
(if (nth 2 pack)
|
||||
(progn
|
||||
(aset buf 2 (base64-num-to-char
|
||||
(logior (ash (logand (nth 1 pack) 15) 2)
|
||||
(ash (nth 2 pack) -6))))
|
||||
(aset buf 3 (base64-num-to-char
|
||||
(logand (nth 2 pack) 63))))
|
||||
(aset buf 2 (base64-num-to-char
|
||||
(ash (logand (nth 1 pack) 15) 2)))))
|
||||
(aset buf 1 (base64-num-to-char
|
||||
(ash (logand (car pack) 3) 4))))
|
||||
buf))
|
||||
|
||||
(defun-maybe base64-encode-string (string &optional no-line-break)
|
||||
"Base64-encode STRING and return the result.
|
||||
Optional second argument NO-LINE-BREAK means do not break long lines
|
||||
into shorter lines."
|
||||
(let* ((len (length string))
|
||||
(b 0)(e 57)
|
||||
(dest ""))
|
||||
(while (< e len)
|
||||
(setq dest
|
||||
(concat dest
|
||||
(mapconcat
|
||||
(function base64-encode-1)
|
||||
(pack-sequence (substring string b e) 3)
|
||||
"")
|
||||
(if (not no-line-break) "\n")))
|
||||
(setq b e
|
||||
e (+ e 57)))
|
||||
(concat dest
|
||||
(mapconcat
|
||||
(function base64-encode-1)
|
||||
(pack-sequence (substring string b) 3)
|
||||
""))))
|
||||
|
||||
(defun base64-internal-encode-region (beg end &optional no-line-break)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(insert
|
||||
(prog1
|
||||
(base64-encode-string (buffer-substring beg end) no-line-break)
|
||||
(delete-region beg end))))))
|
||||
|
||||
|
||||
;;; @ internal base64 decoder
|
||||
;;;
|
||||
|
||||
(defconst base64-numbers
|
||||
(eval-when-compile
|
||||
(let ((len (length base64-characters))
|
||||
(vec (make-vector 123 nil))
|
||||
(i 0))
|
||||
(while (< i len)
|
||||
(aset vec (aref base64-characters i) i)
|
||||
(setq i (1+ i)))
|
||||
vec)))
|
||||
|
||||
(defmacro base64-char-to-num (c)
|
||||
`(aref base64-numbers ,c))
|
||||
|
||||
(defsubst base64-internal-decode (string buffer)
|
||||
(let* ((len (length string))
|
||||
(i 0)(j 0)
|
||||
v1 v2 v3)
|
||||
(catch 'tag
|
||||
(while (< i len)
|
||||
(when (prog1 (setq v1 (base64-char-to-num (aref string i)))
|
||||
(setq i (1+ i)))
|
||||
(setq v2 (base64-char-to-num (aref string i))
|
||||
i (1+ i)
|
||||
v3 (base64-char-to-num (aref string i))
|
||||
i (1+ i))
|
||||
(aset buffer j (logior (lsh v1 2)(lsh v2 -4)))
|
||||
(setq j (1+ j))
|
||||
(if v3
|
||||
(let ((v4 (base64-char-to-num (aref string i))))
|
||||
(setq i (1+ i))
|
||||
(aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2)))
|
||||
(setq j (1+ j))
|
||||
(if v4
|
||||
(aset buffer (prog1 j (setq j (1+ j)))
|
||||
(logior (lsh (logand v3 3) 6) v4))
|
||||
(throw 'tag nil)))
|
||||
(throw 'tag nil)))))
|
||||
(substring buffer 0 j)))
|
||||
|
||||
(defun base64-internal-decode-string (string)
|
||||
(base64-internal-decode string (make-string (length string) 0)))
|
||||
|
||||
;; (defsubst base64-decode-string! (string)
|
||||
;; (setq string (string-as-unibyte string))
|
||||
;; (base64-internal-decode string string))
|
||||
|
||||
(defun base64-internal-decode-region (beg end)
|
||||
(save-excursion
|
||||
(let ((str (string-as-unibyte (buffer-substring beg end))))
|
||||
(insert
|
||||
(prog1
|
||||
(base64-internal-decode str str)
|
||||
(delete-region beg end))))))
|
||||
|
||||
;; (defun base64-internal-decode-region2 (beg end)
|
||||
;; (save-excursion
|
||||
;; (let ((str (buffer-substring beg end)))
|
||||
;; (delete-region beg end)
|
||||
;; (goto-char beg)
|
||||
;; (insert (base64-decode-string! str)))))
|
||||
|
||||
;; (defun base64-internal-decode-region3 (beg end)
|
||||
;; (save-excursion
|
||||
;; (let ((str (buffer-substring beg end)))
|
||||
;; (delete-region beg end)
|
||||
;; (goto-char beg)
|
||||
;; (insert (base64-internal-decode-string str)))))
|
||||
|
||||
|
||||
;;; @ external encoder/decoder
|
||||
;;;
|
||||
|
||||
(defun base64-external-encode-region (beg end &optional no-line-break)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
beg end (car base64-external-encoder)
|
||||
t t nil
|
||||
(cdr base64-external-encoder)))
|
||||
;; for OS/2
|
||||
;; regularize line break code
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r$" nil t)
|
||||
(replace-match ""))
|
||||
(if no-line-break
|
||||
(progn
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "\n" nil t)
|
||||
(replace-match "")))))))
|
||||
|
||||
(defun base64-external-decode-region (beg end)
|
||||
(save-excursion
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
beg end (car base64-external-decoder)
|
||||
t t nil
|
||||
(cdr base64-external-decoder)))))
|
||||
|
||||
(defun base64-external-decode-string (string)
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
(point-min)(point-max) (car base64-external-decoder)
|
||||
t t nil
|
||||
(cdr base64-external-decoder)))
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
;;; @ application interfaces
|
||||
;;;
|
||||
|
||||
(defun-maybe base64-encode-region (start end &optional no-line-break)
|
||||
"Base64-encode the region between START and END.
|
||||
Return the length of the encoded text.
|
||||
Optional third argument NO-LINE-BREAK means do not break long lines
|
||||
into shorter lines.
|
||||
This function calls internal base64 encoder if size of region is
|
||||
smaller than `base64-internal-encoding-limit', otherwise it calls
|
||||
external base64 encoder specified by `base64-external-encoder'. In
|
||||
this case, you must install the program (maybe mmencode included in
|
||||
metamail or XEmacs package)."
|
||||
(interactive "*r")
|
||||
(if (and base64-internal-encoding-limit
|
||||
(> (- end start) base64-internal-encoding-limit))
|
||||
(base64-external-encode-region start end no-line-break)
|
||||
(base64-internal-encode-region start end no-line-break)))
|
||||
|
||||
(defun-maybe base64-decode-region (start end)
|
||||
"Decode current region by base64.
|
||||
START and END are buffer positions.
|
||||
This function calls internal base64 decoder if size of region is
|
||||
smaller than `base64-internal-decoding-limit', otherwise it calls
|
||||
external base64 decoder specified by `base64-external-decoder'. In
|
||||
this case, you must install the program (maybe mmencode included in
|
||||
metamail or XEmacs package)."
|
||||
(interactive "*r")
|
||||
(if (and base64-internal-decoding-limit
|
||||
(> (- end start) base64-internal-decoding-limit))
|
||||
(base64-external-decode-region start end)
|
||||
(base64-internal-decode-region start end)))
|
||||
|
||||
(defun-maybe base64-decode-string (string)
|
||||
"Decode STRING which is encoded in base64, and return the result.
|
||||
This function calls internal base64 decoder if size of STRING is
|
||||
smaller than `base64-internal-decoding-limit', otherwise it calls
|
||||
external base64 decoder specified by `base64-external-decoder'. In
|
||||
this case, you must install the program (maybe mmencode included in
|
||||
metamail or XEmacs package)."
|
||||
(if (and base64-internal-decoding-limit
|
||||
(> (length string) base64-internal-decoding-limit))
|
||||
(base64-external-decode-string string)
|
||||
(base64-internal-decode-string string)))
|
||||
|
||||
|
||||
(mel-define-method-function (mime-encode-string string (nil "base64"))
|
||||
'base64-encode-string)
|
||||
(mel-define-method-function (mime-decode-string string (nil "base64"))
|
||||
'base64-decode-string)
|
||||
(mel-define-method-function (mime-encode-region start end (nil "base64"))
|
||||
'base64-encode-region)
|
||||
(mel-define-method-function (mime-decode-region start end (nil "base64"))
|
||||
'base64-decode-region)
|
||||
|
||||
(mel-define-method-function (encoded-text-encode-string string (nil "B"))
|
||||
'base64-encode-string)
|
||||
|
||||
(mel-define-method encoded-text-decode-string (string (nil "B"))
|
||||
(if (string-match (eval-when-compile
|
||||
(concat "\\`" B-encoded-text-regexp "\\'"))
|
||||
string)
|
||||
(base64-decode-string string)
|
||||
(error "Invalid encoded-text %s" string)))
|
||||
|
||||
(defun base64-insert-encoded-file (filename)
|
||||
"Encode contents of file FILENAME to base64, and insert the result.
|
||||
It calls external base64 encoder specified by
|
||||
`base64-external-encoder'. So you must install the program (maybe
|
||||
mmencode included in metamail or XEmacs package)."
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(if (and base64-internal-encoding-limit
|
||||
(> (nth 7 (file-attributes filename))
|
||||
base64-internal-encoding-limit))
|
||||
(apply (function call-process)
|
||||
(car base64-external-encoder)
|
||||
filename t nil
|
||||
(cdr base64-external-encoder))
|
||||
(insert
|
||||
(base64-encode-string
|
||||
(with-temp-buffer
|
||||
(set-buffer-multibyte nil)
|
||||
(insert-file-contents-as-binary filename)
|
||||
(buffer-string))))
|
||||
(or (bolp) (insert ?\n))))
|
||||
|
||||
(mel-define-method-function (mime-insert-encoded-file filename (nil "base64"))
|
||||
'base64-insert-encoded-file)
|
||||
|
||||
(defun base64-write-decoded-region (start end filename)
|
||||
"Decode and write current region encoded by base64 into FILENAME.
|
||||
START and END are buffer positions."
|
||||
(interactive "*r\nFWrite decoded region to file: ")
|
||||
(if (and base64-internal-decoding-limit
|
||||
(> (- end start) base64-internal-decoding-limit))
|
||||
(progn
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
start end (car base64-external-decoder)
|
||||
(null base64-external-decoder-option-to-specify-file)
|
||||
(unless base64-external-decoder-option-to-specify-file
|
||||
(list (current-buffer) nil))
|
||||
nil
|
||||
(delq nil
|
||||
(append
|
||||
(cdr base64-external-decoder)
|
||||
base64-external-decoder-option-to-specify-file
|
||||
(when base64-external-decoder-option-to-specify-file
|
||||
(list filename))))))
|
||||
(unless base64-external-decoder-option-to-specify-file
|
||||
(write-region-as-binary (point-min) (point-max) filename)))
|
||||
(let ((str (buffer-substring start end)))
|
||||
(with-temp-buffer
|
||||
(insert (base64-internal-decode-string str))
|
||||
(write-region-as-binary (point-min) (point-max) filename)))))
|
||||
|
||||
(mel-define-method-function
|
||||
(mime-write-decoded-region start end filename (nil "base64"))
|
||||
'base64-write-decoded-region)
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel-b-el)
|
||||
|
||||
;;; mel-b-el.el ends here.
|
||||
128
flim-1.14.9/mel-g.el
Normal file
128
flim-1.14.9/mel-g.el
Normal file
@ -0,0 +1,128 @@
|
||||
;;; mel-g.el --- Gzip64 encoder/decoder.
|
||||
|
||||
;; Copyright (C) 1995,96,97,98,99,2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Maintainer: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Created: 1995/10/25
|
||||
;; Keywords: Gzip64, base64, gzip, MIME
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; NOTE: Gzip64 is an experimental Content-Transfer-Encoding and its
|
||||
;;; use is STRONGLY DISCOURAGED except for private communication.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(require 'path-util)
|
||||
|
||||
|
||||
;;; @ variables
|
||||
;;;
|
||||
|
||||
(defvar gzip64-external-encoder '("sh" "-c" "gzip -c | mmencode")
|
||||
"*list of gzip64 encoder program name and its arguments.")
|
||||
|
||||
(defvar gzip64-external-decoder '("sh" "-c" "mmencode -u | gzip -dc")
|
||||
"*list of gzip64 decoder program name and its arguments.")
|
||||
|
||||
|
||||
;;; @ encoder/decoder for region
|
||||
;;;
|
||||
|
||||
(defun gzip64-external-encode-region (beg end)
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(let ((coding-system-for-write 'binary))
|
||||
(apply (function call-process-region)
|
||||
beg end (car gzip64-external-encoder)
|
||||
t t nil
|
||||
(cdr gzip64-external-encoder)))
|
||||
;; for OS/2
|
||||
;; regularize line break code
|
||||
;;(goto-char (point-min))
|
||||
;;(while (re-search-forward "\r$" nil t)
|
||||
;; (replace-match ""))
|
||||
))
|
||||
|
||||
(defun gzip64-external-decode-region (beg end)
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(let ((coding-system-for-read 'binary))
|
||||
(apply (function call-process-region)
|
||||
beg end (car gzip64-external-decoder)
|
||||
t t nil
|
||||
(cdr gzip64-external-decoder)))))
|
||||
|
||||
(mel-define-method-function (mime-encode-region start end (nil "x-gzip64"))
|
||||
'gzip64-external-encode-region)
|
||||
(mel-define-method-function (mime-decode-region start end (nil "x-gzip64"))
|
||||
'gzip64-external-decode-region)
|
||||
|
||||
|
||||
;;; @ encoder/decoder for string
|
||||
;;;
|
||||
|
||||
(mel-define-method mime-encode-string (string (nil "x-gzip64"))
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(gzip64-external-encode-region (point-min)(point-max))
|
||||
(buffer-string)))
|
||||
|
||||
(mel-define-method mime-decode-string (string (nil "x-gzip64"))
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(gzip64-external-decode-region (point-min)(point-max))
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
;;; @ encoder/decoder for file
|
||||
;;;
|
||||
|
||||
(mel-define-method mime-insert-encoded-file (filename (nil "x-gzip64"))
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(apply (function call-process)
|
||||
(car gzip64-external-encoder)
|
||||
filename t nil
|
||||
(cdr gzip64-external-encoder)))
|
||||
|
||||
(mel-define-method mime-write-decoded-region (start end filename
|
||||
(nil "x-gzip64"))
|
||||
"Decode and write current region encoded by gzip64 into FILENAME.
|
||||
START and END are buffer positions."
|
||||
(interactive "*r\nFWrite decoded region to file: ")
|
||||
(let ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
(apply (function call-process-region)
|
||||
start end (car gzip64-external-decoder)
|
||||
nil nil nil
|
||||
(let ((args (cdr gzip64-external-decoder)))
|
||||
(append (butlast args)
|
||||
(list (concat (car (last args)) ">" filename)))))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel-g)
|
||||
|
||||
;;; mel-g.el ends here
|
||||
1000
flim-1.14.9/mel-q-ccl.el
Normal file
1000
flim-1.14.9/mel-q-ccl.el
Normal file
File diff suppressed because it is too large
Load Diff
343
flim-1.14.9/mel-q.el
Normal file
343
flim-1.14.9/mel-q.el
Normal file
@ -0,0 +1,343 @@
|
||||
;;; mel-q.el --- Quoted-Printable encoder/decoder.
|
||||
|
||||
;; Copyright (C) 1995,96,97,98,99,2000,2001 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Created: 1995/6/25
|
||||
;; Keywords: MIME, Quoted-Printable, Q-encoding
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(require 'path-util)
|
||||
(eval-when-compile
|
||||
;; XXX: should provide char-list instead of string-to-char-list.
|
||||
;; XXx: and also the macro `as-binary-process' should be provided
|
||||
;; XXx: by the module "pces" which will be loaded by way of "poem".
|
||||
(require 'poem))
|
||||
|
||||
|
||||
;;; @ Quoted-Printable encoder
|
||||
;;;
|
||||
|
||||
(defsubst quoted-printable-quote-char (character)
|
||||
(concat
|
||||
"="
|
||||
(char-to-string (aref quoted-printable-hex-chars (ash character -4)))
|
||||
(char-to-string (aref quoted-printable-hex-chars (logand character 15)))))
|
||||
|
||||
(defun quoted-printable-internal-encode-region (start end)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region (goto-char start) end)
|
||||
(let ((col 0)
|
||||
chr)
|
||||
(while (not (eobp))
|
||||
(cond
|
||||
((>= col 75) ; soft line break.
|
||||
(insert "=\n")
|
||||
(setq col 0))
|
||||
((eolp) ; end of line.
|
||||
(forward-char)
|
||||
(setq col 0))
|
||||
(t
|
||||
(setq chr (char-after (point)))
|
||||
(cond
|
||||
((and (memq chr '(? ?\t)) ; encode WSP char before CRLF.
|
||||
(eq (char-after (1+ (point))) ?\n))
|
||||
(forward-char)
|
||||
(insert "=\n")
|
||||
(forward-char)
|
||||
(setq col 0))
|
||||
((and (bolp) ; "^From " is not safe.
|
||||
(eq chr ?F)
|
||||
(eq (char-after (1+ (point))) ?r)
|
||||
(eq (char-after (+ 2 (point))) ?o)
|
||||
(eq (char-after (+ 3 (point))) ?m)
|
||||
(eq (char-after (+ 4 (point))) ? ))
|
||||
(delete-region (point)(1+ (point)))
|
||||
(insert "=46") ; moved to ?r.
|
||||
(forward-char 4) ; skip "rom ".
|
||||
(setq col 7))
|
||||
((or (= chr ?\t) ; skip safe char.
|
||||
(and (<= 32 chr)(/= chr ?=)(< chr 127)))
|
||||
(forward-char)
|
||||
(setq col (1+ col)))
|
||||
((>= col 73) ; soft line break.
|
||||
(insert "=\n")
|
||||
(setq col 0))
|
||||
(t ; encode unsafe char.
|
||||
(delete-region (point)(1+ (point)))
|
||||
;; (insert (quoted-printable-quote-char chr))
|
||||
(insert
|
||||
?=
|
||||
(aref quoted-printable-hex-chars (ash chr -4))
|
||||
(aref quoted-printable-hex-chars (logand chr 15)))
|
||||
(setq col (+ col 3)))))))))))
|
||||
|
||||
|
||||
(defvar quoted-printable-external-encoder '("mmencode" "-q")
|
||||
"*list of quoted-printable encoder program name and its arguments.")
|
||||
|
||||
(defun quoted-printable-external-encode-region (start end)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
start end (car quoted-printable-external-encoder)
|
||||
t t nil
|
||||
(cdr quoted-printable-external-encoder)))
|
||||
;; for OS/2
|
||||
;; regularize line break code
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r$" nil t)
|
||||
(replace-match "")))))
|
||||
|
||||
|
||||
(defvar quoted-printable-internal-encoding-limit
|
||||
(if (and (featurep 'xemacs)(featurep 'mule))
|
||||
0
|
||||
(require 'path-util)
|
||||
(if (exec-installed-p "mmencode")
|
||||
1000
|
||||
;; XXX: Fix this message, or simply remove it.
|
||||
;; (message "Don't found external encoder for Quoted-Printable!")
|
||||
nil))
|
||||
"*limit size to use internal quoted-printable encoder.
|
||||
If size of input to encode is larger than this limit,
|
||||
external encoder is called.")
|
||||
|
||||
(defun quoted-printable-encode-region (start end)
|
||||
"Encode current region by quoted-printable.
|
||||
START and END are buffer positions.
|
||||
This function calls internal quoted-printable encoder if size of
|
||||
region is smaller than `quoted-printable-internal-encoding-limit',
|
||||
otherwise it calls external quoted-printable encoder specified by
|
||||
`quoted-printable-external-encoder'. In this case, you must install
|
||||
the program (maybe mmencode included in metamail or XEmacs package)."
|
||||
(interactive "*r")
|
||||
(if (and quoted-printable-internal-encoding-limit
|
||||
(> (- end start) quoted-printable-internal-encoding-limit))
|
||||
(quoted-printable-external-encode-region start end)
|
||||
(quoted-printable-internal-encode-region start end)))
|
||||
|
||||
(defun quoted-printable-encode-string (string)
|
||||
"Encode STRING to quoted-printable, and return the result."
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(quoted-printable-encode-region (point-min)(point-max))
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
(mel-define-method-function
|
||||
(mime-encode-string string (nil "quoted-printable"))
|
||||
'quoted-printable-encode-string)
|
||||
|
||||
(mel-define-method-function
|
||||
(mime-encode-region start end (nil "quoted-printable"))
|
||||
'quoted-printable-encode-region)
|
||||
|
||||
(mel-define-method mime-insert-encoded-file (filename (nil "quoted-printable"))
|
||||
"Encode contents of file FILENAME to quoted-printable, and insert the result.
|
||||
It calls external quoted-printable encoder specified by
|
||||
`quoted-printable-external-encoder'. So you must install the program
|
||||
\(maybe mmencode included in metamail or XEmacs package)."
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(apply (function call-process)
|
||||
(car quoted-printable-external-encoder)
|
||||
filename t nil
|
||||
(cdr quoted-printable-external-encoder)))
|
||||
|
||||
|
||||
;;; @ Quoted-Printable decoder
|
||||
;;;
|
||||
|
||||
(defsubst quoted-printable-hex-char-to-num (chr)
|
||||
(cond ((<= ?a chr) (+ (- chr ?a) 10))
|
||||
((<= ?A chr) (+ (- chr ?A) 10))
|
||||
((<= ?0 chr) (- chr ?0))
|
||||
))
|
||||
|
||||
(defun quoted-printable-internal-decode-region (start end)
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(goto-char (point-min))
|
||||
(while (search-forward "=" nil t)
|
||||
(cond
|
||||
((eolp)
|
||||
;; unfold soft line break.
|
||||
(delete-region (1- (point))(1+ (point))))
|
||||
((and (memq (char-after (point))
|
||||
(eval-when-compile
|
||||
;; XXX: should provide char-list instead.
|
||||
(string-to-char-list quoted-printable-hex-chars)))
|
||||
(memq (char-after (1+ (point)))
|
||||
(eval-when-compile
|
||||
;; XXX: should provide char-list instead.
|
||||
(string-to-char-list quoted-printable-hex-chars))))
|
||||
;; encoded char.
|
||||
(insert
|
||||
(prog1
|
||||
(logior
|
||||
(ash (quoted-printable-hex-char-to-num (char-after (point))) 4)
|
||||
(quoted-printable-hex-char-to-num (char-after (1+ (point)))))
|
||||
(delete-region (1- (point))(+ 2 (point))))))
|
||||
(t
|
||||
;; invalid encoding.
|
||||
))))))
|
||||
|
||||
(defvar quoted-printable-external-decoder '("mmencode" "-q" "-u")
|
||||
"*list of quoted-printable decoder program name and its arguments.")
|
||||
|
||||
(defun quoted-printable-external-decode-region (start end)
|
||||
(save-excursion
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
start end (car quoted-printable-external-decoder)
|
||||
t t nil
|
||||
(cdr quoted-printable-external-decoder)))))
|
||||
|
||||
|
||||
(defvar quoted-printable-internal-decoding-limit nil
|
||||
"*limit size to use internal quoted-printable decoder.
|
||||
If size of input to decode is larger than this limit,
|
||||
external decoder is called.")
|
||||
|
||||
(defun quoted-printable-decode-region (start end)
|
||||
"Decode current region by quoted-printable.
|
||||
START and END are buffer positions.
|
||||
This function calls internal quoted-printable decoder if size of
|
||||
region is smaller than `quoted-printable-internal-decoding-limit',
|
||||
otherwise it calls external quoted-printable decoder specified by
|
||||
`quoted-printable-external-decoder'. In this case, you must install
|
||||
the program (maybe mmencode included in metamail or XEmacs package)."
|
||||
(interactive "*r")
|
||||
(if (and quoted-printable-internal-decoding-limit
|
||||
(> (- end start) quoted-printable-internal-decoding-limit))
|
||||
(quoted-printable-external-decode-region start end)
|
||||
(quoted-printable-internal-decode-region start end)))
|
||||
|
||||
(defun quoted-printable-decode-string (string)
|
||||
"Decode STRING which is encoded in quoted-printable, and return the result."
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(quoted-printable-decode-region (point-min)(point-max))
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
(mel-define-method-function
|
||||
(mime-decode-string string (nil "quoted-printable"))
|
||||
'quoted-printable-decode-string)
|
||||
|
||||
(mel-define-method-function
|
||||
(mime-decode-region start end (nil "quoted-printable"))
|
||||
'quoted-printable-decode-region)
|
||||
|
||||
|
||||
(defvar quoted-printable-external-decoder-option-to-specify-file '("-o")
|
||||
"*list of options of quoted-printable decoder program to specify file.
|
||||
If the quoted-printable decoder does not have such option, set this as nil.")
|
||||
|
||||
(mel-define-method mime-write-decoded-region (start end filename
|
||||
(nil "quoted-printable"))
|
||||
"Decode and write current region encoded by quoted-printable into FILENAME.
|
||||
START and END are buffer positions."
|
||||
(interactive "*r\nFWrite decoded region to file: ")
|
||||
(as-binary-process
|
||||
(apply (function call-process-region)
|
||||
start end (car quoted-printable-external-decoder)
|
||||
(null quoted-printable-external-decoder-option-to-specify-file)
|
||||
(unless quoted-printable-external-decoder-option-to-specify-file
|
||||
(list (current-buffer) nil))
|
||||
nil
|
||||
(delq nil
|
||||
(append
|
||||
(cdr quoted-printable-external-decoder)
|
||||
quoted-printable-external-decoder-option-to-specify-file
|
||||
(when quoted-printable-external-decoder-option-to-specify-file
|
||||
(list filename))))))
|
||||
(unless quoted-printable-external-decoder-option-to-specify-file
|
||||
(write-region-as-binary (point-min) (point-max) filename)))
|
||||
|
||||
|
||||
;;; @ Q-encoding encode/decode string
|
||||
;;;
|
||||
|
||||
(defconst q-encoding-special-chars-alist
|
||||
'((text ?= ?? ?_)
|
||||
(comment ?= ?? ?_ ?\( ?\) ?\\)
|
||||
(phrase ?= ?? ?_ ?\( ?\) ?\\ ?\" ?# ?$ ?% ?& ?' ?, ?. ?/
|
||||
?: ?\; ?< ?> ?@ ?\[ ?\] ?^ ?` ?{ ?| ?} ?~)
|
||||
))
|
||||
|
||||
(defun q-encoding-encode-string (string &optional mode)
|
||||
"Encode STRING to Q-encoding of encoded-word, and return the result.
|
||||
MODE allows `text', `comment', `phrase' or nil. Default value is
|
||||
`phrase'."
|
||||
(let ((specials (cdr (or (assq mode q-encoding-special-chars-alist)
|
||||
(assq 'phrase q-encoding-special-chars-alist)))))
|
||||
(mapconcat (function
|
||||
(lambda (chr)
|
||||
(cond ((eq chr ? ) "_")
|
||||
((or (< chr 32) (< 126 chr)
|
||||
(memq chr specials))
|
||||
(quoted-printable-quote-char chr))
|
||||
(t
|
||||
(char-to-string chr)))))
|
||||
string "")))
|
||||
|
||||
(defun q-encoding-decode-string (string)
|
||||
"Decode STRING which is encoded in Q-encoding and return the result."
|
||||
(let (q h l)
|
||||
(mapconcat (function
|
||||
(lambda (chr)
|
||||
(cond ((eq chr ?_) " ")
|
||||
((eq chr ?=)
|
||||
(setq q t)
|
||||
"")
|
||||
(q (setq h (quoted-printable-hex-char-to-num chr))
|
||||
(setq q nil)
|
||||
"")
|
||||
(h (setq l (quoted-printable-hex-char-to-num chr))
|
||||
(prog1
|
||||
(char-to-string (logior (ash h 4) l))
|
||||
(setq h nil)))
|
||||
(t (char-to-string chr)))))
|
||||
string "")))
|
||||
|
||||
(mel-define-method-function (encoded-text-encode-string string (nil "Q"))
|
||||
'q-encoding-encode-string)
|
||||
|
||||
(mel-define-method encoded-text-decode-string (string (nil "Q"))
|
||||
(if (string-match (eval-when-compile
|
||||
(concat "\\`" Q-encoded-text-regexp "\\'"))
|
||||
string)
|
||||
(q-encoding-decode-string string)
|
||||
(error "Invalid encoded-text %s" string)))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel-q)
|
||||
|
||||
;;; mel-q.el ends here.
|
||||
164
flim-1.14.9/mel-u.el
Normal file
164
flim-1.14.9/mel-u.el
Normal file
@ -0,0 +1,164 @@
|
||||
;;; mel-u.el --- uuencode encoder/decoder.
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Created: 1995/10/25
|
||||
;; Keywords: uuencode
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(require 'path-util)
|
||||
|
||||
|
||||
(mel-define-backend "x-uue")
|
||||
|
||||
|
||||
;;; @ variables
|
||||
;;;
|
||||
|
||||
(defvar uuencode-external-encoder '("uuencode" "-")
|
||||
"*list of uuencode encoder program name and its arguments.")
|
||||
|
||||
(defvar uuencode-external-decoder '("sh" "-c" "uudecode")
|
||||
"*list of uuencode decoder program name and its arguments.")
|
||||
|
||||
|
||||
;;; @ uuencode encoder/decoder for region
|
||||
;;;
|
||||
|
||||
(defun uuencode-external-encode-region (start end)
|
||||
"Encode current region by unofficial uuencode format.
|
||||
This function uses external uuencode encoder which is specified by
|
||||
variable `uuencode-external-encoder'."
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(let ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
(apply (function call-process-region)
|
||||
start end (car uuencode-external-encoder)
|
||||
t t nil
|
||||
(cdr uuencode-external-encoder)))
|
||||
;; for OS/2
|
||||
;; regularize line break code
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "\r$" nil t)
|
||||
(replace-match ""))))
|
||||
|
||||
(defun uuencode-external-decode-region (start end)
|
||||
"Decode current region by unofficial uuencode format.
|
||||
This function uses external uuencode decoder which is specified by
|
||||
variable `uuencode-external-decoder'."
|
||||
(interactive "*r")
|
||||
(save-excursion
|
||||
(let ((filename (make-temp-file "x-uue")))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(set-mark end)
|
||||
(narrow-to-region start end)
|
||||
(goto-char start)
|
||||
(when (and (re-search-forward "^begin [0-9]+ " nil t)
|
||||
(looking-at ".+$"))
|
||||
(replace-match filename)
|
||||
(let ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
(apply (function call-process-region)
|
||||
start (mark) (car uuencode-external-decoder)
|
||||
t nil nil
|
||||
(cdr uuencode-external-decoder)))
|
||||
(insert-file-contents filename)
|
||||
;; The previous line causes the buffer to be made read-only, I
|
||||
;; do not pretend to understand the control flow leading to this
|
||||
;; but suspect it has something to do with image-mode. -slb
|
||||
;; Use `inhibit-read-only' to avoid to force
|
||||
;; buffer-read-only nil. - tomo.
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-file filename))))))))
|
||||
|
||||
(mel-define-method-function (mime-encode-region start end (nil "x-uue"))
|
||||
'uuencode-external-encode-region)
|
||||
(mel-define-method-function (mime-decode-region start end (nil "x-uue"))
|
||||
'uuencode-external-decode-region)
|
||||
|
||||
|
||||
;;; @ encoder/decoder for string
|
||||
;;;
|
||||
|
||||
(mel-define-method mime-encode-string (string (nil "x-uue"))
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(uuencode-external-encode-region (point-min)(point-max))
|
||||
(buffer-string)))
|
||||
|
||||
(mel-define-method mime-decode-string (string (nil "x-uue"))
|
||||
(with-temp-buffer
|
||||
(insert string)
|
||||
(uuencode-external-decode-region (point-min)(point-max))
|
||||
(buffer-string)))
|
||||
|
||||
|
||||
;;; @ uuencode encoder/decoder for file
|
||||
;;;
|
||||
|
||||
(mel-define-method mime-insert-encoded-file (filename (nil "x-uue"))
|
||||
"Insert file encoded by unofficial uuencode format.
|
||||
This function uses external uuencode encoder which is specified by
|
||||
variable `uuencode-external-encoder'."
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(call-process (car uuencode-external-encoder)
|
||||
filename t nil
|
||||
(file-name-nondirectory filename)))
|
||||
|
||||
(mel-define-method mime-write-decoded-region (start end filename
|
||||
(nil "x-uue"))
|
||||
"Decode and write current region encoded by uuencode into FILENAME.
|
||||
START and END are buffer positions."
|
||||
(interactive "*r\nFWrite decoded region to file: ")
|
||||
(save-excursion
|
||||
(let ((clone-buf (clone-buffer " *x-uue*"))
|
||||
(file (make-temp-file "x-uue")))
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(set-buffer clone-buf)
|
||||
(narrow-to-region start end)
|
||||
(setq buffer-read-only nil)
|
||||
(goto-char start)
|
||||
(when (and (re-search-forward "^begin [0-9]+ " nil t)
|
||||
(looking-at ".+$"))
|
||||
(replace-match file)
|
||||
(let ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
(apply (function call-process-region)
|
||||
(point-min) (point-max) (car uuencode-external-decoder)
|
||||
nil nil nil
|
||||
(cdr uuencode-external-decoder))
|
||||
(rename-file file filename 'overwrites)
|
||||
(message (concat "Wrote " filename))))))
|
||||
(kill-buffer clone-buf))))
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel-u)
|
||||
|
||||
(mel-define-backend "x-uuencode" ("x-uue"))
|
||||
|
||||
;;; mel-u.el ends here.
|
||||
343
flim-1.14.9/mel.el
Normal file
343
flim-1.14.9/mel.el
Normal file
@ -0,0 +1,343 @@
|
||||
;;; mel.el --- A MIME encoding/decoding library.
|
||||
|
||||
;; Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Created: 1995/6/25
|
||||
;; Keywords: MIME, Base64, Quoted-Printable, uuencode, gzip64
|
||||
|
||||
;; 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., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
(require 'alist)
|
||||
|
||||
(defcustom mime-encoding-list
|
||||
'("7bit" "8bit" "binary" "base64" "quoted-printable")
|
||||
"List of Content-Transfer-Encoding. Each encoding must be string."
|
||||
:group 'mime
|
||||
:type '(repeat string))
|
||||
|
||||
(defun mime-encoding-list (&optional service)
|
||||
"Return list of Content-Transfer-Encoding.
|
||||
If SERVICE is specified, it returns available list of
|
||||
Content-Transfer-Encoding for it."
|
||||
(if service
|
||||
(let (dest)
|
||||
(mapatoms (lambda (sym)
|
||||
(or (eq sym nil)
|
||||
(setq dest (cons (symbol-name sym) dest)))
|
||||
)
|
||||
(symbol-value (intern (format "%s-obarray" service))))
|
||||
(let ((rest mel-encoding-module-alist)
|
||||
pair)
|
||||
(while (setq pair (car rest))
|
||||
(let ((key (car pair)))
|
||||
(or (member key dest)
|
||||
(<= (length key) 1)
|
||||
(setq dest (cons key dest))))
|
||||
(setq rest (cdr rest)))
|
||||
)
|
||||
dest)
|
||||
mime-encoding-list))
|
||||
|
||||
(defun mime-encoding-alist (&optional service)
|
||||
"Return table of Content-Transfer-Encoding for completion."
|
||||
(mapcar #'list (mime-encoding-list service)))
|
||||
|
||||
(defsubst mel-use-module (name encodings)
|
||||
(while encodings
|
||||
(set-alist 'mel-encoding-module-alist
|
||||
(car encodings)
|
||||
(cons name (cdr (assoc (car encodings)
|
||||
mel-encoding-module-alist))))
|
||||
(setq encodings (cdr encodings))))
|
||||
|
||||
(defsubst mel-find-function (service encoding)
|
||||
(mel-find-function-from-obarray
|
||||
(symbol-value (intern (format "%s-obarray" service))) encoding))
|
||||
|
||||
|
||||
;;; @ setting for modules
|
||||
;;;
|
||||
|
||||
(defun 8bit-insert-encoded-file (filename)
|
||||
"Insert file FILENAME encoded by \"7bit\" format."
|
||||
(let ((coding-system-for-read 'raw-text)
|
||||
format-alist)
|
||||
;; Returns list of absolute file name and length of data inserted.
|
||||
(insert-file-contents filename)))
|
||||
|
||||
(defun 8bit-write-decoded-region (start end filename)
|
||||
"Decode and write current region encoded by \"8bit\" into FILENAME."
|
||||
(let ((coding-system-for-write 'raw-text)
|
||||
format-alist)
|
||||
(write-region start end filename)))
|
||||
|
||||
(mel-define-backend "8bit")
|
||||
(mel-define-method-function (mime-encode-string string (nil "8bit"))
|
||||
'identity)
|
||||
(mel-define-method-function (mime-decode-string string (nil "8bit"))
|
||||
'identity)
|
||||
(mel-define-method mime-encode-region (start end (nil "8bit")))
|
||||
(mel-define-method mime-decode-region (start end (nil "8bit")))
|
||||
(mel-define-method-function (mime-insert-encoded-file filename (nil "8bit"))
|
||||
'8bit-insert-encoded-file)
|
||||
(mel-define-method-function (mime-write-decoded-region
|
||||
start end filename (nil "8bit"))
|
||||
'8bit-write-decoded-region)
|
||||
|
||||
|
||||
(defalias '7bit-insert-encoded-file '8bit-insert-encoded-file)
|
||||
(defalias '7bit-write-decoded-region '8bit-write-decoded-region)
|
||||
|
||||
(mel-define-backend "7bit" ("8bit"))
|
||||
|
||||
|
||||
(defun binary-write-decoded-region (start end filename)
|
||||
"Decode and write current region encoded by \"binary\" into FILENAME."
|
||||
(let ((coding-system-for-write 'binary)
|
||||
jka-compr-compression-info-list jam-zcat-filename-list)
|
||||
(write-region start end filename)))
|
||||
|
||||
(defalias 'binary-insert-encoded-file 'insert-file-contents-literally)
|
||||
|
||||
(defun binary-find-file-noselect (filename &optional nowarn rawfile)
|
||||
"Like `find-file-noselect', q.v., but don't code and format conversion."
|
||||
(let ((coding-system-for-read 'binary)
|
||||
format-alist)
|
||||
(find-file-noselect filename nowarn rawfile)))
|
||||
|
||||
(defun binary-funcall (name &rest args)
|
||||
"Like `funcall', q.v., but read and write as binary."
|
||||
(let ((coding-system-for-read 'binary)
|
||||
(coding-system-for-write 'binary))
|
||||
(apply name args)))
|
||||
|
||||
(defun binary-to-text-funcall (coding-system name &rest args)
|
||||
"Like `funcall', q.v., but write as binary and read as text.
|
||||
Read text is decoded as CODING-SYSTEM."
|
||||
(let ((coding-system-for-read coding-system)
|
||||
(coding-system-for-write 'binary))
|
||||
(apply name args)))
|
||||
|
||||
(mel-define-backend "binary")
|
||||
(mel-define-method-function (mime-encode-string string (nil "binary"))
|
||||
'identity)
|
||||
(mel-define-method-function (mime-decode-string string (nil "binary"))
|
||||
'identity)
|
||||
(mel-define-method mime-encode-region (start end (nil "binary")))
|
||||
(mel-define-method mime-decode-region (start end (nil "binary")))
|
||||
(mel-define-method-function (mime-insert-encoded-file filename (nil "binary"))
|
||||
'binary-insert-encoded-file)
|
||||
(mel-define-method-function (mime-write-decoded-region
|
||||
start end filename (nil "binary"))
|
||||
'binary-write-decoded-region)
|
||||
|
||||
(defvar mel-b-builtin
|
||||
(and (fboundp 'base64-encode-string)
|
||||
(subrp (symbol-function 'base64-encode-string))))
|
||||
|
||||
(when mel-b-builtin
|
||||
(mel-define-backend "base64")
|
||||
(mel-define-method-function (mime-encode-string string (nil "base64"))
|
||||
'base64-encode-string)
|
||||
(mel-define-method-function (mime-decode-string string (nil "base64"))
|
||||
'base64-decode-string)
|
||||
(mel-define-method-function (mime-encode-region start end (nil "base64"))
|
||||
'base64-encode-region)
|
||||
(mel-define-method-function (mime-decode-region start end (nil "base64"))
|
||||
'base64-decode-region)
|
||||
(mel-define-method mime-insert-encoded-file (filename (nil "base64"))
|
||||
"Encode contents of file FILENAME to base64, and insert the result.
|
||||
It calls external base64 encoder specified by
|
||||
`base64-external-encoder'. So you must install the program (maybe
|
||||
mmencode included in metamail or XEmacs package)."
|
||||
(interactive "*fInsert encoded file: ")
|
||||
(insert (base64-encode-string
|
||||
(with-temp-buffer
|
||||
(set-buffer-multibyte nil)
|
||||
(binary-insert-encoded-file filename)
|
||||
(buffer-string))))
|
||||
(or (bolp) (insert ?\n)))
|
||||
(mel-define-method mime-write-decoded-region (start end filename
|
||||
(nil "base64"))
|
||||
"Decode the region from START to END and write out to FILENAME."
|
||||
(interactive "*r\nFWrite decoded region to file: ")
|
||||
(let ((str (buffer-substring start end)))
|
||||
(with-temp-buffer
|
||||
(insert str)
|
||||
(base64-decode-region (point-min) (point-max))
|
||||
(write-region-as-binary (point-min) (point-max) filename))))
|
||||
|
||||
;; (mel-define-method-function (encoded-text-encode-string string (nil "B"))
|
||||
;; 'base64-encode-string)
|
||||
(mel-define-method encoded-text-decode-string (string (nil "B"))
|
||||
(if (string-match (eval-when-compile
|
||||
(concat "\\`" B-encoded-text-regexp "\\'"))
|
||||
string)
|
||||
(base64-decode-string string)
|
||||
(error "Invalid encoded-text %s" string)))
|
||||
)
|
||||
|
||||
(mel-use-module 'mel-b-el '("base64" "B"))
|
||||
(mel-use-module 'mel-q '("quoted-printable" "Q"))
|
||||
(mel-use-module 'mel-g '("x-gzip64"))
|
||||
(mel-use-module 'mel-u '("x-uue" "x-uuencode"))
|
||||
|
||||
(defvar mel-b-ccl-module
|
||||
(and (featurep 'mule)
|
||||
(progn
|
||||
(require 'path-util)
|
||||
(module-installed-p 'mel-b-ccl))))
|
||||
|
||||
(defvar mel-q-ccl-module
|
||||
(and (featurep 'mule)
|
||||
(progn
|
||||
(require 'path-util)
|
||||
(module-installed-p 'mel-q-ccl))))
|
||||
|
||||
(when mel-b-ccl-module
|
||||
(mel-use-module 'mel-b-ccl '("base64" "B")))
|
||||
|
||||
(when mel-q-ccl-module
|
||||
(mel-use-module 'mel-q-ccl '("quoted-printable" "Q")))
|
||||
|
||||
(when base64-dl-module
|
||||
(mel-use-module 'mel-b-dl '("base64" "B")))
|
||||
|
||||
|
||||
;;; @ region
|
||||
;;;
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-encode-region (start end encoding)
|
||||
"Encode region START to END of current buffer using ENCODING.
|
||||
ENCODING must be string."
|
||||
(interactive
|
||||
(list (region-beginning)(region-end)
|
||||
(completing-read "Encoding: "
|
||||
(mime-encoding-alist)
|
||||
nil t "base64")))
|
||||
(funcall (mel-find-function 'mime-encode-region encoding) start end))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-decode-region (start end encoding)
|
||||
"Decode region START to END of current buffer using ENCODING.
|
||||
ENCODING must be string."
|
||||
(interactive
|
||||
(list (region-beginning)(region-end)
|
||||
(completing-read "Encoding: "
|
||||
(mime-encoding-alist 'mime-decode-region)
|
||||
nil t "base64")))
|
||||
(funcall (mel-find-function 'mime-decode-region encoding)
|
||||
start end))
|
||||
|
||||
|
||||
;;; @ string
|
||||
;;;
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-decode-string (string encoding)
|
||||
"Decode STRING using ENCODING.
|
||||
ENCODING must be string. If ENCODING is found in
|
||||
`mime-string-decoding-method-alist' as its key, this function decodes
|
||||
the STRING by its value."
|
||||
(let ((f (mel-find-function 'mime-decode-string encoding)))
|
||||
(if f
|
||||
(funcall f string)
|
||||
string)))
|
||||
|
||||
|
||||
(mel-define-service encoded-text-encode-string)
|
||||
(defun encoded-text-encode-string (string encoding &optional mode)
|
||||
"Encode STRING as encoded-text using ENCODING.
|
||||
ENCODING must be string.
|
||||
Optional argument MODE allows `text', `comment', `phrase' or nil.
|
||||
Default value is `phrase'."
|
||||
(if (string= encoding "B")
|
||||
(base64-encode-string string 'no-line-break)
|
||||
(let ((f (mel-find-function 'encoded-text-encode-string encoding)))
|
||||
(if f
|
||||
(funcall f string mode)
|
||||
string))))
|
||||
|
||||
(mel-define-service encoded-text-decode-string (string encoding)
|
||||
"Decode STRING as encoded-text using ENCODING. ENCODING must be string.")
|
||||
|
||||
(defun base64-encoded-length (string)
|
||||
(* (/ (+ (length string) 2) 3) 4))
|
||||
|
||||
(defsubst Q-encoding-printable-char-p (chr mode)
|
||||
(and (not (memq chr '(?= ?? ?_)))
|
||||
(<= ?\ chr)(<= chr ?~)
|
||||
(cond ((eq mode 'text) t)
|
||||
((eq mode 'comment)
|
||||
(not (memq chr '(?\( ?\) ?\\))))
|
||||
(t
|
||||
(string-match "[A-Za-z0-9!*+/=_---]" (char-to-string chr))))))
|
||||
|
||||
(defun Q-encoded-text-length (string &optional mode)
|
||||
(let ((l 0)(i 0)(len (length string)) chr)
|
||||
(while (< i len)
|
||||
(setq chr (aref string i))
|
||||
(if (or (Q-encoding-printable-char-p chr mode)
|
||||
(eq chr ? ))
|
||||
(setq l (+ l 1))
|
||||
(setq l (+ l 3)))
|
||||
(setq i (+ i 1)))
|
||||
l))
|
||||
|
||||
|
||||
;;; @ file
|
||||
;;;
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-insert-encoded-file (filename encoding)
|
||||
"Insert file FILENAME encoded by ENCODING format."
|
||||
(interactive
|
||||
(list (read-file-name "Insert encoded file: ")
|
||||
(completing-read "Encoding: "
|
||||
(mime-encoding-alist)
|
||||
nil t "base64")))
|
||||
(funcall (mel-find-function 'mime-insert-encoded-file encoding)
|
||||
filename))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-write-decoded-region (start end filename encoding)
|
||||
"Decode and write current region encoded by ENCODING into FILENAME.
|
||||
START and END are buffer positions."
|
||||
(interactive
|
||||
(list (region-beginning)(region-end)
|
||||
(read-file-name "Write decoded region to file: ")
|
||||
(completing-read "Encoding: "
|
||||
(mime-encoding-alist 'mime-write-decoded-region)
|
||||
nil t "base64")))
|
||||
(funcall (mel-find-function 'mime-write-decoded-region encoding)
|
||||
start end filename))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mel)
|
||||
|
||||
;;; mel.el ends here.
|
||||
275
flim-1.14.9/mime-conf.el
Normal file
275
flim-1.14.9/mime-conf.el
Normal file
@ -0,0 +1,275 @@
|
||||
;;; mime-conf.el --- mailcap parser and MIME playback configuration
|
||||
|
||||
;; Copyright (C) 1997,1998,1999,2000,2004 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Created: 1997-06-27
|
||||
;; Original: 1997-06-27 mailcap.el by MORIOKA Tomohiko
|
||||
;; Renamed: 2000-11-24 to mime-conf.el by MORIOKA Tomohiko
|
||||
;; Keywords: mailcap, setting, configuration, MIME, multimedia
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'mime-def)
|
||||
|
||||
|
||||
;;; @ comment
|
||||
;;;
|
||||
|
||||
(defsubst mime-mailcap-skip-comment ()
|
||||
(let ((chr (char-after (point))))
|
||||
(when (and chr
|
||||
(or (= chr ?\n)
|
||||
(= chr ?#)))
|
||||
(forward-line)
|
||||
t)))
|
||||
|
||||
|
||||
;;; @ token
|
||||
;;;
|
||||
|
||||
(defsubst mime-mailcap-look-at-token ()
|
||||
(if (looking-at mime-token-regexp)
|
||||
(let ((beg (match-beginning 0))
|
||||
(end (match-end 0)))
|
||||
(goto-char end)
|
||||
(buffer-substring beg end)
|
||||
)))
|
||||
|
||||
|
||||
;;; @ typefield
|
||||
;;;
|
||||
|
||||
(defsubst mime-mailcap-look-at-type-field ()
|
||||
(let ((type (mime-mailcap-look-at-token)))
|
||||
(if type
|
||||
(if (eq (char-after (point)) ?/)
|
||||
(progn
|
||||
(forward-char)
|
||||
(let ((subtype (mime-mailcap-look-at-token)))
|
||||
(if subtype
|
||||
(cons (cons 'type (intern type))
|
||||
(unless (string= subtype "*")
|
||||
(list (cons 'subtype (intern subtype)))
|
||||
)))))
|
||||
(list (cons 'type (intern type)))
|
||||
))))
|
||||
|
||||
|
||||
;;; @ field separator
|
||||
;;;
|
||||
|
||||
(defsubst mime-mailcap-skip-field-separator ()
|
||||
(let ((ret (looking-at "\\([ \t]\\|\\\\\n\\)*;\\([ \t]\\|\\\\\n\\)*")))
|
||||
(when ret
|
||||
(goto-char (match-end 0))
|
||||
t)))
|
||||
|
||||
|
||||
;;; @ mtext
|
||||
;;;
|
||||
|
||||
(defsubst mime-mailcap-look-at-schar ()
|
||||
(let ((chr (char-after (point))))
|
||||
(if (and chr
|
||||
(>= chr ? )
|
||||
(/= chr ?\;)
|
||||
(/= chr ?\\)
|
||||
)
|
||||
(prog1
|
||||
chr
|
||||
(forward-char)))))
|
||||
|
||||
(defsubst mime-mailcap-look-at-qchar ()
|
||||
(when (eq (char-after (point)) ?\\)
|
||||
(prog2
|
||||
(forward-char)
|
||||
(char-after (point))
|
||||
(forward-char))))
|
||||
|
||||
(defsubst mime-mailcap-look-at-mtext ()
|
||||
(let ((beg (point)))
|
||||
(while (or (mime-mailcap-look-at-qchar)
|
||||
(mime-mailcap-look-at-schar)))
|
||||
(buffer-substring beg (point))
|
||||
))
|
||||
|
||||
|
||||
;;; @ field
|
||||
;;;
|
||||
|
||||
(defsubst mime-mailcap-look-at-field ()
|
||||
(let ((token (mime-mailcap-look-at-token)))
|
||||
(if token
|
||||
(if (looking-at "[ \t]*=[ \t]*")
|
||||
(let ((value (progn
|
||||
(goto-char (match-end 0))
|
||||
(mime-mailcap-look-at-mtext))))
|
||||
(if value
|
||||
(cons (intern token) value)
|
||||
))
|
||||
(list (intern token))
|
||||
))))
|
||||
|
||||
|
||||
;;; @ mailcap entry
|
||||
;;;
|
||||
|
||||
(defun mime-mailcap-look-at-entry ()
|
||||
(let ((type (mime-mailcap-look-at-type-field)))
|
||||
(if (and type (mime-mailcap-skip-field-separator))
|
||||
(let ((view (mime-mailcap-look-at-mtext))
|
||||
fields field)
|
||||
(when view
|
||||
(while (and (mime-mailcap-skip-field-separator)
|
||||
(setq field (mime-mailcap-look-at-field))
|
||||
)
|
||||
(setq fields (cons field fields))
|
||||
)
|
||||
(nconc type
|
||||
(list (cons 'view view))
|
||||
fields))))))
|
||||
|
||||
|
||||
;;; @ main
|
||||
;;;
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-parse-mailcap-buffer (&optional buffer order)
|
||||
"Parse BUFFER as a mailcap, and return the result.
|
||||
If optional argument ORDER is a function, result is sorted by it.
|
||||
If optional argument ORDER is not specified, result is sorted original
|
||||
order. Otherwise result is not sorted."
|
||||
(save-excursion
|
||||
(if buffer
|
||||
(set-buffer buffer))
|
||||
(goto-char (point-min))
|
||||
(let (entries entry)
|
||||
(while (progn
|
||||
(while (mime-mailcap-skip-comment))
|
||||
(setq entry (mime-mailcap-look-at-entry))
|
||||
)
|
||||
(setq entries (cons entry entries))
|
||||
(forward-line)
|
||||
)
|
||||
(cond ((functionp order) (sort entries order))
|
||||
((null order) (nreverse entries))
|
||||
(t entries)
|
||||
))))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defvar mime-mailcap-file "~/.mailcap"
|
||||
"*File name of user's mailcap file.")
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-parse-mailcap-file (&optional filename order)
|
||||
"Parse FILENAME as a mailcap, and return the result.
|
||||
If optional argument ORDER is a function, result is sorted by it.
|
||||
If optional argument ORDER is not specified, result is sorted original
|
||||
order. Otherwise result is not sorted."
|
||||
(or filename
|
||||
(setq filename mime-mailcap-file))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents filename)
|
||||
(mime-parse-mailcap-buffer (current-buffer) order)
|
||||
))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defun mime-format-mailcap-command (mtext situation)
|
||||
"Return formated command string from MTEXT and SITUATION.
|
||||
|
||||
MTEXT is a command text of mailcap specification, such as
|
||||
view-command.
|
||||
|
||||
SITUATION is an association-list about information of entity. Its key
|
||||
may be:
|
||||
|
||||
'type primary media-type
|
||||
'subtype media-subtype
|
||||
'filename filename
|
||||
STRING parameter of Content-Type field"
|
||||
(let ((i 0)
|
||||
(len (length mtext))
|
||||
(p 0)
|
||||
dest)
|
||||
(while (< i len)
|
||||
(let ((chr (aref mtext i)))
|
||||
(cond ((eq chr ?%)
|
||||
(setq i (1+ i)
|
||||
chr (aref mtext i))
|
||||
(cond ((eq chr ?s)
|
||||
(let ((file (cdr (assq 'filename situation))))
|
||||
(if (null file)
|
||||
(error "'filename is not specified in situation.")
|
||||
(setq dest (concat dest
|
||||
(substring mtext p (1- i))
|
||||
(shell-quote-argument file))
|
||||
i (1+ i)
|
||||
p i)
|
||||
)))
|
||||
((eq chr ?t)
|
||||
(let ((type (or (mime-type/subtype-string
|
||||
(cdr (assq 'type situation))
|
||||
(cdr (assq 'subtype situation)))
|
||||
"text/plain")))
|
||||
(setq dest (concat dest
|
||||
(substring mtext p (1- i))
|
||||
type)
|
||||
i (1+ i)
|
||||
p i)
|
||||
))
|
||||
((eq chr ?\{)
|
||||
(setq i (1+ i))
|
||||
(if (not (string-match "}" mtext i))
|
||||
(error "parse error!!!")
|
||||
(let* ((me (match-end 0))
|
||||
(attribute (substring mtext i (1- me)))
|
||||
(parameter (cdr (assoc attribute situation))))
|
||||
(if (null parameter)
|
||||
(error "\"%s\" is not specified in situation."
|
||||
attribute)
|
||||
(setq dest (concat dest
|
||||
(substring mtext p (- i 2))
|
||||
parameter)
|
||||
i me
|
||||
p i)
|
||||
)
|
||||
)))
|
||||
(t (error "Invalid sequence `%%%c'." chr))
|
||||
))
|
||||
((eq chr ?\\)
|
||||
(setq dest (concat dest (substring mtext p i))
|
||||
p (1+ i)
|
||||
i (+ i 2))
|
||||
)
|
||||
(t (setq i (1+ i)))
|
||||
)))
|
||||
(concat dest (substring mtext p))
|
||||
))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mime-conf)
|
||||
|
||||
;;; mime-conf.el ends here
|
||||
402
flim-1.14.9/mime-def.el
Normal file
402
flim-1.14.9/mime-def.el
Normal file
@ -0,0 +1,402 @@
|
||||
;;; mime-def.el --- definition module about MIME -*- coding: iso-8859-4; -*-
|
||||
|
||||
;; Copyright (C) 1995,96,97,98,99,2000,2001,2002,2003,2004,2005,2006
|
||||
;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: MORIOKA Tomohiko <tomo@m17n.org>
|
||||
;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
|
||||
;; Keywords: definition, MIME, multimedia, mail, news
|
||||
|
||||
;; 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 GNU Emacs; see the file COPYING. If not, write to the
|
||||
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
;; Boston, MA 02110-1301, USA.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'custom)
|
||||
(require 'mcharset)
|
||||
(require 'alist)
|
||||
|
||||
(eval-when-compile (require 'luna)) ; luna-arglist-to-arguments
|
||||
|
||||
(eval-and-compile
|
||||
(defconst mime-library-product ["FLIM" (1 14 9) "Gojò"]
|
||||
"Product name, version number and code name of MIME-library package."))
|
||||
|
||||
(defmacro mime-product-name (product)
|
||||
`(aref ,product 0))
|
||||
|
||||
(defmacro mime-product-version (product)
|
||||
`(aref ,product 1))
|
||||
|
||||
(defmacro mime-product-code-name (product)
|
||||
`(aref ,product 2))
|
||||
|
||||
(defconst mime-library-version
|
||||
(eval-when-compile
|
||||
(concat (mime-product-name mime-library-product) " "
|
||||
(mapconcat #'number-to-string
|
||||
(mime-product-version mime-library-product) ".")
|
||||
" - \"" (mime-product-code-name mime-library-product) "\"")))
|
||||
|
||||
|
||||
;;; @ variables
|
||||
;;;
|
||||
|
||||
(defgroup mime '((default-mime-charset custom-variable))
|
||||
"Emacs MIME Interfaces"
|
||||
:group 'news
|
||||
:group 'mail)
|
||||
|
||||
(defcustom mime-uuencode-encoding-name-list '("x-uue" "x-uuencode")
|
||||
"*List of encoding names for uuencode format."
|
||||
:group 'mime
|
||||
:type '(repeat string))
|
||||
|
||||
|
||||
;;; @@ for encoded-word
|
||||
;;;
|
||||
|
||||
(defgroup mime-header nil
|
||||
"Header representation, specially encoded-word"
|
||||
:group 'mime)
|
||||
|
||||
;;; @@@ decoding
|
||||
;;;
|
||||
|
||||
(defcustom mime-field-decoding-max-size 1000
|
||||
"*Max size to decode header field."
|
||||
:group 'mime-header
|
||||
:type '(choice (integer :tag "Limit (bytes)")
|
||||
(const :tag "Don't limit" nil)))
|
||||
|
||||
(defcustom mime-header-accept-quoted-encoded-words nil
|
||||
"*Accept encoded-words in quoted-strings."
|
||||
:group 'mime-header
|
||||
:type 'boolean)
|
||||
|
||||
|
||||
;;; @@@ encoding
|
||||
;;;
|
||||
|
||||
(defcustom mime-field-encoding-method-alist
|
||||
'(("X-Nsubject" . iso-2022-jp-2)
|
||||
("Newsgroups" . nil)
|
||||
("Message-ID" . nil)
|
||||
(t . mime)
|
||||
)
|
||||
"*Alist to specify field encoding method.
|
||||
Its key is field-name, value is encoding method.
|
||||
|
||||
If method is `mime', this field will be encoded into MIME format.
|
||||
|
||||
If method is a MIME-charset, this field will be encoded as the charset
|
||||
when it must be convert into network-code.
|
||||
|
||||
If method is `default-mime-charset', this field will be encoded as
|
||||
variable `default-mime-charset' when it must be convert into
|
||||
network-code.
|
||||
|
||||
If method is nil, this field will not be encoded."
|
||||
:group 'mime-header
|
||||
:type '(repeat (cons (choice :tag "Field"
|
||||
(string :tag "Name")
|
||||
(const :tag "Default" t))
|
||||
(choice :tag "Method"
|
||||
(const :tag "MIME conversion" mime)
|
||||
(symbol :tag "non-MIME conversion")
|
||||
(const :tag "no-conversion" nil)))))
|
||||
|
||||
|
||||
;;; @ required functions
|
||||
;;;
|
||||
|
||||
(defsubst regexp-* (regexp)
|
||||
(concat regexp "*"))
|
||||
|
||||
(defsubst regexp-or (&rest args)
|
||||
(concat "\\(" (mapconcat (function identity) args "\\|") "\\)"))
|
||||
|
||||
(or (fboundp 'char-int)
|
||||
(defalias 'char-int 'identity))
|
||||
|
||||
|
||||
;;; @ MIME constants
|
||||
;;;
|
||||
|
||||
(defconst mime-tspecial-char-list
|
||||
'(?\] ?\[ ?\( ?\) ?< ?> ?@ ?, ?\; ?: ?\\ ?\" ?/ ?? ?=))
|
||||
(defconst mime-token-regexp
|
||||
(concat "[^" mime-tspecial-char-list "\000-\040]+"))
|
||||
(defconst mime-attribute-char-regexp
|
||||
(concat "[^" mime-tspecial-char-list "\000-\040"
|
||||
"*'%" ; introduced in RFC 2231.
|
||||
"]"))
|
||||
|
||||
(defconst mime-charset-regexp
|
||||
(concat "[^" mime-tspecial-char-list "\000-\040"
|
||||
"*'%" ; should not include "%"?
|
||||
"]+"))
|
||||
|
||||
;; More precisely, length of "[A-Za-z]+" is limited to at most 8.
|
||||
;; (defconst mime-language-regexp "[A-Za-z]+\\(-[A-Za-z]+\\)*")
|
||||
(defconst mime-language-regexp "[-A-Za-z]+")
|
||||
|
||||
(defconst mime-encoding-regexp mime-token-regexp)
|
||||
|
||||
|
||||
;;; @@ base64 / B
|
||||
;;;
|
||||
|
||||
(defconst base64-token-regexp "[A-Za-z0-9+/]")
|
||||
(defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
|
||||
|
||||
(defconst B-encoded-text-regexp
|
||||
(concat "\\(\\("
|
||||
base64-token-regexp
|
||||
base64-token-regexp
|
||||
base64-token-regexp
|
||||
base64-token-regexp
|
||||
"\\)*"
|
||||
base64-token-regexp
|
||||
base64-token-regexp
|
||||
base64-token-padding-regexp
|
||||
base64-token-padding-regexp
|
||||
"\\)"))
|
||||
|
||||
;; (defconst eword-B-encoding-and-encoded-text-regexp
|
||||
;; (concat "\\(B\\)\\?" eword-B-encoded-text-regexp))
|
||||
|
||||
|
||||
;;; @@ Quoted-Printable / Q
|
||||
;;;
|
||||
|
||||
(defconst quoted-printable-hex-chars "0123456789ABCDEF")
|
||||
|
||||
(defconst quoted-printable-octet-regexp
|
||||
(concat "=[" quoted-printable-hex-chars
|
||||
"][" quoted-printable-hex-chars "]"))
|
||||
|
||||
(defconst Q-encoded-text-regexp
|
||||
(concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
|
||||
|
||||
;; (defconst eword-Q-encoding-and-encoded-text-regexp
|
||||
;; (concat "\\(Q\\)\\?" eword-Q-encoded-text-regexp))
|
||||
|
||||
|
||||
;;; @ Content-Type
|
||||
;;;
|
||||
|
||||
(defsubst make-mime-content-type (type subtype &optional parameters)
|
||||
(cons (cons 'type type)
|
||||
(cons (cons 'subtype subtype)
|
||||
parameters)))
|
||||
|
||||
(defsubst mime-content-type-primary-type (content-type)
|
||||
"Return primary-type of CONTENT-TYPE."
|
||||
(cdr (car content-type)))
|
||||
|
||||
(defsubst mime-content-type-subtype (content-type)
|
||||
"Return subtype of CONTENT-TYPE."
|
||||
(cdr (car (cdr content-type))))
|
||||
|
||||
(defsubst mime-content-type-parameters (content-type)
|
||||
"Return parameters of CONTENT-TYPE."
|
||||
(cdr (cdr content-type)))
|
||||
|
||||
(defsubst mime-content-type-parameter (content-type parameter)
|
||||
"Return PARAMETER value of CONTENT-TYPE."
|
||||
(cdr (assoc parameter (cdr (cdr content-type)))))
|
||||
|
||||
|
||||
(defsubst mime-type/subtype-string (type &optional subtype)
|
||||
"Return type/subtype string from TYPE and SUBTYPE."
|
||||
(if type
|
||||
(if subtype
|
||||
(format "%s/%s" type subtype)
|
||||
(format "%s" type))))
|
||||
|
||||
|
||||
;;; @ Content-Disposition
|
||||
;;;
|
||||
|
||||
(defsubst make-mime-content-disposition (type &optional parameters)
|
||||
(cons (cons 'type type)
|
||||
parameters))
|
||||
|
||||
(defsubst mime-content-disposition-type (content-disposition)
|
||||
"Return disposition-type of CONTENT-DISPOSITION."
|
||||
(cdr (car content-disposition)))
|
||||
|
||||
(defsubst mime-content-disposition-parameters (content-disposition)
|
||||
"Return disposition-parameters of CONTENT-DISPOSITION."
|
||||
(cdr content-disposition))
|
||||
|
||||
(defsubst mime-content-disposition-parameter (content-disposition parameter)
|
||||
"Return PARAMETER value of CONTENT-DISPOSITION."
|
||||
(cdr (assoc parameter (cdr content-disposition))))
|
||||
|
||||
(defsubst mime-content-disposition-filename (content-disposition)
|
||||
"Return filename of CONTENT-DISPOSITION."
|
||||
(mime-content-disposition-parameter content-disposition "filename"))
|
||||
|
||||
|
||||
;;; @ message structure
|
||||
;;;
|
||||
|
||||
(defvar mime-message-structure nil
|
||||
"Information about structure of message.
|
||||
Please use reference function `mime-entity-SLOT' to get value of SLOT.
|
||||
|
||||
Following is a list of slots of the structure:
|
||||
|
||||
node-id node-id (list of integers)
|
||||
content-type content-type (content-type)
|
||||
content-disposition content-disposition (content-disposition)
|
||||
encoding Content-Transfer-Encoding (string or nil)
|
||||
children entities included in this entity (list of entity)
|
||||
|
||||
If an entity includes other entities in its body, such as multipart or
|
||||
message/rfc822, `mime-entity' structures of them are included in
|
||||
`children', so the `mime-entity' structure become a tree.")
|
||||
|
||||
(make-variable-buffer-local 'mime-message-structure)
|
||||
|
||||
(make-obsolete-variable 'mime-message-structure "should not use it.")
|
||||
|
||||
|
||||
;;; @ for mel-backend
|
||||
;;;
|
||||
|
||||
(defvar mel-service-list nil)
|
||||
|
||||
(defmacro mel-define-service (name &optional args &rest rest)
|
||||
"Define NAME as a service for Content-Transfer-Encodings.
|
||||
If ARGS is specified, NAME is defined as a generic function for the
|
||||
service."
|
||||
`(progn
|
||||
(add-to-list 'mel-service-list ',name)
|
||||
(defvar ,(intern (format "%s-obarray" name)) (make-vector 7 0))
|
||||
,@(if args
|
||||
`((defun ,name ,args
|
||||
,@rest
|
||||
(funcall (mel-find-function ',name ,(car (last args)))
|
||||
,@(luna-arglist-to-arguments (butlast args)))
|
||||
)))
|
||||
))
|
||||
|
||||
(put 'mel-define-service 'lisp-indent-function 'defun)
|
||||
|
||||
|
||||
(defvar mel-encoding-module-alist nil)
|
||||
|
||||
(defsubst mel-find-function-from-obarray (ob-array encoding)
|
||||
(let* ((f (intern-soft encoding ob-array)))
|
||||
(or f
|
||||
(let ((rest (cdr (assoc encoding mel-encoding-module-alist))))
|
||||
(while (and rest
|
||||
(progn
|
||||
(require (car rest))
|
||||
(null (setq f (intern-soft encoding ob-array)))
|
||||
))
|
||||
(setq rest (cdr rest))
|
||||
)
|
||||
f))))
|
||||
|
||||
(defsubst mel-copy-method (service src-backend dst-backend)
|
||||
(let* ((oa (symbol-value (intern (format "%s-obarray" service))))
|
||||
(f (mel-find-function-from-obarray oa src-backend))
|
||||
sym)
|
||||
(when f
|
||||
(setq sym (intern dst-backend oa))
|
||||
(or (fboundp sym)
|
||||
(fset sym (symbol-function f))
|
||||
))))
|
||||
|
||||
(defsubst mel-copy-backend (src-backend dst-backend)
|
||||
(let ((services mel-service-list))
|
||||
(while services
|
||||
(mel-copy-method (car services) src-backend dst-backend)
|
||||
(setq services (cdr services)))))
|
||||
|
||||
(defmacro mel-define-backend (type &optional parents)
|
||||
"Define TYPE as a mel-backend.
|
||||
If PARENTS is specified, TYPE inherits PARENTS.
|
||||
Each parent must be backend name (string)."
|
||||
(cons 'progn
|
||||
(mapcar (lambda (parent)
|
||||
`(mel-copy-backend ,parent ,type)
|
||||
)
|
||||
parents)))
|
||||
|
||||
(defmacro mel-define-method (name args &rest body)
|
||||
"Define NAME as a method function of (nth 1 (car (last ARGS))) backend.
|
||||
ARGS is like an argument list of lambda, but (car (last ARGS)) must be
|
||||
specialized parameter. (car (car (last ARGS))) is name of variable
|
||||
and (nth 1 (car (last ARGS))) is name of backend (encoding)."
|
||||
(let* ((specializer (car (last args)))
|
||||
(class (nth 1 specializer)))
|
||||
`(progn
|
||||
(mel-define-service ,name)
|
||||
(fset (intern ,class ,(intern (format "%s-obarray" name)))
|
||||
(lambda ,(butlast args)
|
||||
,@body)))))
|
||||
|
||||
(put 'mel-define-method 'lisp-indent-function 'defun)
|
||||
|
||||
(defmacro mel-define-method-function (spec function)
|
||||
"Set SPEC's function definition to FUNCTION.
|
||||
First element of SPEC is service.
|
||||
Rest of ARGS is like an argument list of lambda, but (car (last ARGS))
|
||||
must be specialized parameter. (car (car (last ARGS))) is name of
|
||||
variable and (nth 1 (car (last ARGS))) is name of backend (encoding)."
|
||||
(let* ((name (car spec))
|
||||
(args (cdr spec))
|
||||
(specializer (car (last args)))
|
||||
(class (nth 1 specializer)))
|
||||
`(let (sym)
|
||||
(mel-define-service ,name)
|
||||
(setq sym (intern ,class ,(intern (format "%s-obarray" name))))
|
||||
(or (fboundp sym)
|
||||
(fset sym (symbol-function ,function))))))
|
||||
|
||||
(defmacro mel-define-function (function spec)
|
||||
(let* ((name (car spec))
|
||||
(args (cdr spec))
|
||||
(specializer (car (last args)))
|
||||
(class (nth 1 specializer)))
|
||||
`(progn
|
||||
(define-function ,function
|
||||
(intern ,class ,(intern (format "%s-obarray" name))))
|
||||
)))
|
||||
|
||||
(defvar base64-dl-module
|
||||
(if (and (fboundp 'base64-encode-string)
|
||||
(subrp (symbol-function 'base64-encode-string)))
|
||||
nil
|
||||
(if (fboundp 'dynamic-link)
|
||||
(let ((path (expand-file-name "base64.so" exec-directory)))
|
||||
(and (file-exists-p path)
|
||||
path)
|
||||
))))
|
||||
|
||||
|
||||
;;; @ end
|
||||
;;;
|
||||
|
||||
(provide 'mime-def)
|
||||
|
||||
;;; mime-def.el ends here
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
x
Reference in New Issue
Block a user