public/elisp-vcs
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

delete versioned wl support libs

Browse Source
This commit is contained in:
Kai Tetzlaff 2010-08-15 19:44:14 +02:00
parent f3a54b99c8
commit 20685a4ebe
165 changed files with 0 additions and 65324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
apel-10.7/APEL-CFG
View File

@ -1,88 +0,0 @@
;;; 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 "~/.emacs.d/lisp/apel")
(setq EMU_DIR "~/.emacs.d/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
View File

@ -1,19 +0,0 @@
;;; 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
View File

@ -1,197 +0,0 @@
;;; 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
View File

File diff suppressed because it is too large Load Diff

220
apel-10.7/EMU-ELS
View File

@ -1,220 +0,0 @@
;;; 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
View File

@ -1,67 +0,0 @@
#
# 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
View File

@ -1,492 +0,0 @@
-*- 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
View File

@ -1,585 +0,0 @@
-*- 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
View File

@ -1,101 +0,0 @@
;;; 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
View File

@ -1,62 +0,0 @@
;;; 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
View File

@ -1,191 +0,0 @@
;;; 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
View File

@ -1,114 +0,0 @@
;;; 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
View File

@ -1,331 +0,0 @@
;;; 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
View File

@ -1,61 +0,0 @@
;;; 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
View File

@ -1,262 +0,0 @@
;;; 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
View File

@ -1,115 +0,0 @@
;;; 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
View File

@ -1,39 +0,0 @@
;;; 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
View File

@ -1,170 +0,0 @@
;;; 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
View File

@ -1,306 +0,0 @@
;;; 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
View File

@ -1,79 +0,0 @@
;;; 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
View File

@ -1,61 +0,0 @@
;;; 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
View File

@ -1,68 +0,0 @@
;;; 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
View File

@ -1,42 +0,0 @@
;;; 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
View File

@ -1,308 +0,0 @@
;;; 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
View File

@ -1,56 +0,0 @@
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
View File

@ -1,215 +0,0 @@
@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
View File

@ -1,109 +0,0 @@
;;; 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
View File

@ -1,235 +0,0 @@
;;; 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
View File

@ -1,187 +0,0 @@
;;; 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
View File

@ -1,110 +0,0 @@
;;; 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
View File

@ -1,130 +0,0 @@
;;; 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
View File

@ -1,243 +0,0 @@
;;; 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
View File

@ -1,201 +0,0 @@
;;; 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
View File

@ -1,101 +0,0 @@
;;; 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
View File

@ -1,86 +0,0 @@
;;; 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
View File

@ -1,201 +0,0 @@
;;; 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
View File

@ -1,175 +0,0 @@
;;; 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
View File

@ -1,129 +0,0 @@
;;; 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
View File

@ -1,170 +0,0 @@
;;; 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
View File

@ -1,239 +0,0 @@
;;; -*-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
View File

@ -1,48 +0,0 @@
;;; 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
View File

@ -1,150 +0,0 @@
;;; -*-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
View File

@ -1,276 +0,0 @@
;;; 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
View File

@ -1,340 +0,0 @@
;;; 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
View File

@ -1,172 +0,0 @@
;;; 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
View File

@ -1,48 +0,0 @@
;;; 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
View File

@ -1,78 +0,0 @@
;;; 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
View File

@ -1,59 +0,0 @@
;;; 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
View File

@ -1,65 +0,0 @@
;;; 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
View File

@ -1,847 +0,0 @@
;;; 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
View File

@ -1,239 +0,0 @@
;;; 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
View File

File diff suppressed because it is too large Load Diff

65
apel-10.7/poem-e20.el
View File

@ -1,65 +0,0 @@
;;; 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
View File

@ -1,93 +0,0 @@
;;; 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
View File

@ -1,68 +0,0 @@
;;; -*-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
View File

@ -1,154 +0,0 @@
;;; 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
View File

@ -1,219 +0,0 @@
;;; 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
View File

@ -1,164 +0,0 @@
;;; 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
View File

@ -1,99 +0,0 @@
;;; 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
View File

@ -1,106 +0,0 @@
;;; 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
View File

@ -1,428 +0,0 @@
;;; 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
View File

@ -1,296 +0,0 @@
;;; 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 ([&not eval] [&rest sexp])]
[&optional (eval [&optional ("interactive" interactive)] def-body)]
&rest (&rest sexp)))
(def-edebug-spec defmacro-maybe-cond
(&define name lambda-list
[&rest ([&not eval] [&rest sexp])]
[&optional (eval def-body)]
&rest (&rest sexp)))
(def-edebug-spec defsubst-maybe-cond
(&define name lambda-list
[&optional stringp]
[&rest ([&not 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
View File

@ -1,185 +0,0 @@
;;; 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
View File

@ -1,89 +0,0 @@
;;; 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
View File

@ -1,516 +0,0 @@
;;; 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
View File

@ -1,180 +0,0 @@
;; 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
View File

@ -1,169 +0,0 @@
;;;
;;; $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
View File

File diff suppressed because it is too large Load Diff

1053
flim-1.14.9/FLIM-API.en
View File

File diff suppressed because it is too large Load Diff

69
flim-1.14.9/FLIM-CFG
View File

@ -1,69 +0,0 @@
;;; -*-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.
(setq install-default-elisp-directory "~/.emacs.d/lisp")
(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 "~/.emacs.d/lisp/"))
(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
View File

@ -1,48 +0,0 @@
;;; -*-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
View File

@ -1,99 +0,0 @@
;;; -*-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
View File

@ -1,75 +0,0 @@
#
# 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
View File

@ -1,164 +0,0 @@
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
View File

@ -1,149 +0,0 @@
[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
View File

@ -1,159 +0,0 @@
[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
View File

@ -1,108 +0,0 @@
[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
View File

@ -1,823 +0,0 @@
;;; 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
View File

@ -1,726 +0,0 @@
;;; 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
View File

@ -1,73 +0,0 @@
;;; 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
View File

@ -1,85 +0,0 @@
;;; 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
View File

@ -1,93 +0,0 @@
;;; 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
View File

@ -1,86 +0,0 @@
;;; 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
View File

@ -1,434 +0,0 @@
;;; 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
View File

@ -1,331 +0,0 @@
;;; 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
View File

@ -1,67 +0,0 @@
;;; 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
View File

@ -1,228 +0,0 @@
;;; 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
View File

@ -1,55 +0,0 @@
;;; 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
View File

@ -1,408 +0,0 @@
;;; 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
View File

@ -1,79 +0,0 @@
;;; 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
View File

@ -1,481 +0,0 @@
;;; 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
View File

@ -1,114 +0,0 @@
;;; 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
View File

@ -1,403 +0,0 @@
;;; 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
View File

@ -1,128 +0,0 @@
;;; 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
View File

File diff suppressed because it is too large Load Diff

343
flim-1.14.9/mel-q.el
View File

@ -1,343 +0,0 @@
;;; 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
View File

@ -1,164 +0,0 @@
;;; 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
View File

@ -1,343 +0,0 @@
;;; 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
View File

@ -1,275 +0,0 @@
;;; 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
View File

@ -1,402 +0,0 @@
;;; 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