+1998-09-20 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * mcs-xm.el (charsets-mime-charset-alist): Comment out invalid
+ definition for iso-2022-int-1.
+
+1998-09-19 Tanaka Akira <akr@jaist.ac.jp>
+
+ * broken.el: New file.
+
+ * pccl.el (apel-broken-facility): Abolished
+ (apel-broken-p): Abolished
+
+ * EMU-ELS (emu-modules): Add 'broken.
+
+ * Makefile (elc): Do not remove emu*.elc.
+
+ * pccl-20.el: require 'broken.
+ (ccl-use-symbol-as-program): Abolished.
+ (ccl-accept-symbol-as-program): New facility.
+ (make-ccl-coding-system): Use `when-broken' to define.
+ (ccl-encoder-eof-block-is-broken): Abolished.
+ (ccl-decoder-eof-block-is-broken): Abolished.
+ (ccl-eof-block-is-broken): Abolished
+ (ccl-execute-eof-block-on-encoding-null): New facility.
+ (ccl-execute-eof-block-on-encoding-some): Ditto.
+ (ccl-execute-eof-block-on-decoding-null): Ditto.
+ (ccl-execute-eof-block-on-decoding-some): Ditto.
+ (ccl-execute-eof-block-on-encoding): Ditto.
+ (ccl-execute-eof-block-on-decoding): Ditto.
+ (ccl-execute-eof-block): Ditto.
+
+ * pccl-om.el: require 'broken.
+ (ccl-use-symbol-as-program): Abolished.
+ (ccl-accept-symbol-as-program): New facility.
+ (ccl-encoder-eof-block-is-broken): Abolished.
+ (ccl-decoder-eof-block-is-broken): Abolished.
+ (ccl-eof-block-is-broken): Abolished
+ (ccl-execute-eof-block-on-encoding-null): New facility.
+ (ccl-execute-eof-block-on-encoding-some): Ditto.
+ (ccl-execute-eof-block-on-decoding-null): Ditto.
+ (ccl-execute-eof-block-on-decoding-some): Ditto.
+ (ccl-execute-eof-block-on-encoding): Ditto.
+ (ccl-execute-eof-block-on-decoding): Ditto.
+ (ccl-execute-eof-block): Ditto.
+ (ccl-execute-on-string-ignore-contin): New facility.
+
+1998-09-18 Tanaka Akira <akr@jaist.ac.jp>
+
+ * pccl.el (apel-broken-facility): New function.
+ (apel-broken-p): New function.
+
+1998-09-18 Tanaka Akira <akr@jaist.ac.jp>
+
+ * pccl.el: Fix author.
+
+1998-09-17 Katsumi Yamaoka <yamaoka@jpl.org>
+
+ * pccl-om.el (make-ccl-coding-system): Enclose with
+ `eval-and-compile'.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el (unless): New macro.
+
+ * emu.el: Define tl:overlay obsolete aliases for all emacsen.
+
+ * poem-nemacs.el (decode-coding-string): Regard integer as
+ coding-system.
+ (encode-coding-string): Likewise.
+ (decode-coding-region): Likewise.
+ (encode-coding-region): Likewise.
+
+ * poe-18.el (set-text-properties): New function.
+
+ * install.el (install-detect-elisp-directory): Fix problem on
+ Nemacs.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poem-ltn1.el (set-buffer-multibyte): Use `defun-maybe' instead
+ of `defmacro-maybe'.
+
+ * poem-e20_2.el (set-buffer-multibyte): Use `defun-maybe' instead
+ of `defsubst-maybe'.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * EMU-ELS: New implementation.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, emu-mule.el, EMU-ELS: Move code about CCL from
+ emu-mule.el to pccl-om.el.
+
+ * pccl.el: New file.
+
+ * pccl.el: - Rename emu-e20.el to pccl-20.el.
+ - Move definition of emu-x20.el to pccl-20.el.
+ - Move code about CCL from emu-mule.el to pccl-om.el.
+
+ * pccl-om.el: New file (move code about CCL from emu-mule.el).
+
+ * pccl-20.el: New file (renamed from emu-e20.el; move definition
+ of emu-x20.el to pccl-20.el; abolish emu-x20.el).
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, emu-x20.el, emu-e20.el: Move function `char-category'
+ from emu-e20.el and emu-x20.el to emu.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, emu-nemacs.el, emu-latin1.el, EMU-ELS: Move definitions
+ of emu-nemacs.el and emu-latin1.el to emu.el; abolish
+ emu-nemacs.el and emu-latin1.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el: Modify conditions to load sub-modules.
+
+ * emu.el, emu-e20.el: Move alias
+ `insert-binary-file-contents-literally' from emu-e20.el to emu.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poem.el, emu.el: Move `string-as-unibyte',
+ `string-as-multibyte', `char-int', `int-char' and
+ `char-or-char-int-p' from emu.el to poem.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * mcharset.el, emu.el: Move function `charsets-to-mime-charset'
+ from emu.el to mcharset.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, emu-x20.el, emu-nemacs.el, emu-mule.el, emu-latin1.el,
+ emu-e20.el:
+ - Move `insert-binary-file-contents' from emu-e20.el,
+ emu-latin1.el, emu-mule.el, emu-nemacs.el and emu-x20.el to
+ emu.el.
+ - Move `insert-binary-file-contents-literally' from
+ emu-latin1.el, emu-mule.el, emu-nemacs.el and emu-x20.el to
+ emu.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe-18.el (make-obsolete): New function.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, EMU-ELS: Split code about MIME charset from emu to
+ mcharset.
+
+ * mcharset.el: New file.
+
+ * mcs-xm.el: New file (split code about MIME charset from
+ emu-x20.el).
+
+ * emu-x20.el: Split code about MIME charset to mcs-xm.el.
+
+ * mcs-om.el: New file (split code about MIME charset from
+ emu-mule.el).
+
+ * emu-mule.el: Split code about MIME charset to mcs-om.el.
+
+ * mcs-nemacs.el: New file (split code about MIME charset from
+ emu-nemacs.el).
+
+ * emu-nemacs.el: Split code about MIME charset to mcs-nemacs.el.
+
+ * mcs-ltn1.el: New file (split code about MIME charset from
+ emu-latin1.el).
+
+ * emu-latin1.el: Split code about MIME charset to mcs-latin1.el.
+
+ * mcs-e20.el: New file (split code about MIME charset from
+ emu-e20.el).
+
+ * emu-e20.el: Split code about MIME charset to mcs-e20.el.
+
+ * mcs-20.el: New file (renamed from emu-20.el).
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, emu-20.el: Move constant `*noconv*' from emu-20.el to
+ emu.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el, EMU-ELS: Split core part about MULE from emu to poem.
+
+ * poem.el: New file.
+
+ * poem-e20_3.el: New file (renamed from emu-e20_3.el).
+
+ * poem-e20_2.el: New file (renamed from poem-e20_2.el).
+
+ * poem-xm.el: New file (split core part of MULE from emu-x20.el).
+
+ * emu-x20.el: Split core part of MULE to poem-xm.el.
+
+ * poem-om.el: New file (split core part of MULE from emu-mule.el).
+
+ * emu-mule.el: Split core part of MULE to poem-om.el.
+
+ * poem-ltn1.el: New file (split core part of MULE from
+ emu-latin1.el).
+
+ * emu-latin1.el: Split core part of MULE to poem-ltn1.el.
+
+ * poem-e20.el: New file (split core part of MULE from emu-e20.el).
+
+ * emu-e20.el: Split core part of MULE to poem-e20.el.
+
+ * poem-20.el: New file (split core part of MULE from emu-20.el).
+
+ * emu-20.el: Split core part of MULE to poem-20.el.
+
+ * poem-nemacs.el: New file (split core part of MULE from
+ emu-nemacs.el).
+
+ * emu-nemacs.el: Split core part of MULE to poem-nemacs.el; move
+ overlay emulation code of Nemacs to poe-18.el.
+
+ * poe-18.el: Move overlay emulation code of Nemacs from
+ emu-nemacs.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el, emu.el: Move function `point-at-bol' and `point-at-eol'
+ from emu.el to poe.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * emu.el (point-at-bol): New function.
+ (point-at-eol): Use `line-end-position'.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el (line-beginning-position): New function.
+ (line-end-position): New function.
+
+ * poe-xemacs.el (line-beginning-position): New alias.
+ (line-end-position): New alias.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el, emu.el: Move function `functionp' from emu.el to poe.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el, emu.el: Move Emacs 19.30 emulating definitions, Emacs
+ 19.31 emulating definitions and Emacs 20.1 emulating definitions
+ from emu.el to poe.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el, emu.el: Move constant `emacs-minor-version', Emacs 19
+ emulating definitions and Emacs 19.29 emulating definitions from
+ emu.el to poe.el.
+
+1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+ * poe.el: New file (split core part from emu.el).
+
+ * poe-xemacs.el: New file (renamed from emu-xemacs.el).
+
+ * poe-19.el: New file (renamed from emu-e19.el).
+
+ * poe-18.el: New file (renamed from emu-18.el).
+
+ * emu.el, emu-nemacs.el, emu-mule.el, emu-e20.el, EMU-ELS: modify
+ for new structure.
+
1998-09-17 MORIOKA Tomohiko <morioka@jaist.ac.jp>
* emu-x20.el (make-ccl-coding-system): New function.
;;; Code:
-(setq emu-modules
- (cons
- 'emu
- (if (or running-emacs-19_29-or-later
- running-xemacs-19_14-or-later)
- '(richtext)
- '(tinyrich)
- )))
+(setq emu-modules (cons 'emu
+ (if (or running-emacs-19_29-or-later
+ running-xemacs-19_14-or-later)
+ '(richtext)
+ '(tinyrich)
+ )))
-(setq emu-modules
- (nconc
- (cond (running-xemacs
- ;; for XEmacs
- (cons 'emu-xemacs
- (if (featurep 'mule)
- '(emu-20 emu-x20) ; for XEmacs with MULE
- '(emu-latin1) ; for XEmacs without MULE
- ))
- )
- (running-mule-merged-emacs
- ;; for Emacs 20.1 or later
- (cons (if (and (fboundp 'set-buffer-multibyte)
- (subrp (symbol-function 'set-buffer-multibyte)))
- 'emu-e20_3 ; for Emacs 20.3
- 'emu-e20_2 ; for Emacs 20.1 and 20.2
- )
- '(emu-20 emu-e19 emu-e20))
- )
- ((boundp 'MULE)
- ;; for MULE 1.* and MULE 2.*
- (cons 'emu-mule
- (if running-emacs-18
- '(emu-18 env)
- '(emu-e19)))
- )
- ((boundp 'NEMACS)
- ;; for NEmacs
- '(emu-18 emu-nemacs)
- )
- (t
- ;; for Emacs 19.34
- '(emu-e19 emu-latin1)
- ))
- emu-modules))
+(let ((poe-modules '(poe))
+ (poem-modules '(poem))
+ (mcs-modules '(mcharset))
+ pccl-modules)
+ (setq poe-modules (cons (cond ((featurep 'xemacs)
+ 'poe-xemacs)
+ ((>= emacs-major-version 19)
+ 'poe-19)
+ (t
+ 'poe-18))
+ poe-modules))
+
+ (cond ((featurep 'mule)
+ (setq pccl-modules '(pccl))
+ (cond ((featurep 'xemacs)
+ (setq poem-modules (cons 'poem-xm (cons 'poem-20
+ poem-modules))
+ mcs-modules (cons 'mcs-xm (cons 'mcs-20 mcs-modules))
+ pccl-modules (cons 'pccl-20 pccl-modules))
+ )
+ ((>= emacs-major-version 20)
+ (setq poem-modules (cons 'poem-e20 (cons 'poem-20
+ poem-modules))
+ mcs-modules (cons 'mcs-e20 (cons 'mcs-20
+ mcs-modules))
+ pccl-modules (cons 'pccl-20 pccl-modules))
+
+ (setq poem-modules
+ (cons
+ (if (and
+ (fboundp 'set-buffer-multibyte)
+ (subrp (symbol-function 'set-buffer-multibyte)))
+ 'poem-e20_3
+ 'poem-e20_2)
+ poem-modules))
+ )
+ (t
+ (setq poem-modules (cons 'poem-om poem-modules)
+ mcs-modules (cons 'mcs-om mcs-modules)
+ pccl-modules (cons 'pccl-om pccl-modules)
+ emu-modules (cons 'emu-mule emu-modules))
+ ))
+ )
+ ((boundp 'NEMACS)
+ (setq poem-modules (cons 'poem-nemacs poem-modules)
+ mcs-modules (cons 'mcs-nemacs mcs-modules))
+ )
+ (t
+ (setq poem-modules (cons 'poem-ltn1 poem-modules)
+ mcs-modules (cons 'mcs-ltn1 mcs-modules))
+ ))
+
+ (setq emu-modules (append poe-modules poem-modules
+ mcs-modules pccl-modules
+ emu-modules))
+ (setq emu-modules (cons 'broken emu-modules))
+ )
;;; EMU-ELS ends here
elc:
- -rm emu*.elc
$(EMACS) $(FLAGS) -f compile-apel
install:
--- /dev/null
+;;; broken.el --- Emacs broken facility infomation registry.
+
+;; Copyright (C) 1998 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(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 ommited and evaluated to nil and NO-NOTICE is nil, it is noticed."
+ (let ((assertion-value (eval assertion)))
+ (eval `(broken-facility-internal ',facility ,docstring ',assertion-value))
+ (when (and assertion (not assertion-value) (not no-notice)
+ notice-non-obvious-broken-facility)
+ (message "BROKEN FACILITY DETECTED: %s" docstring))
+ `(broken-facility-internal ',facility ,docstring ',assertion-value)))
+
+(put 'if-broken 'lisp-indent-function 2)
+(defmacro if-broken (facility then &rest else)
+ "If FACILITY is broken, expand to THEN, otherwise (progn . ELSE)."
+ (if (broken-p facility)
+ then
+ `(progn . ,else)))
+
+(put 'when-broken 'lisp-indent-function 1)
+(defmacro when-broken (facility &rest body)
+ "If FACILITY is broken, expand to (progn . BODY), otherwise nil."
+ (when (broken-p facility)
+ `(progn . ,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."
+ (unless (broken-p facility)
+ `(progn . ,body)))
+
+
+;;; @ end
+;;;
+
+(provide 'broken)
+
+;;; broken.el ends here
+++ /dev/null
-;;; emu-18.el --- emu API implementation for Emacs 18.*
-
-;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version: $Id: emu-18.el,v 7.33 1997/04/05 06:44:01 morioka Exp $
-;; Keywords: emulation, compatibility
-
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(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)
-
-(defvar data-directory exec-directory)
-
-
-;;; @ for EMACS 18.55
-;;;
-
-(defvar buffer-undo-list nil)
-
-
-;;; @ hook
-;;;
-
-;; These function are imported from EMACS 19.28.
-(defun add-hook (hook function &optional append)
- "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.
-
-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.
-\[emu-18.el; EMACS 19 emulating function]"
- (or (boundp hook)
- (set 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))
- ))
- (or (if (consp function)
- ;; Clever way to tell whether a given lambda-expression
- ;; is equal to anything in the hook.
- (let ((tail (assoc (cdr function) (symbol-value hook))))
- (equal function tail)
- )
- (memq function (symbol-value hook))
- )
- (set hook
- (if append
- (nconc (symbol-value hook) (list function))
- (cons function (symbol-value hook))
- ))
- ))
-
-(defun remove-hook (hook function)
- "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'.
-\[emu-18.el; EMACS 19 emulating function]"
- (if (or (not (boundp hook)) ;unbound symbol, or
- (null (symbol-value hook)) ;value is nil, or
- (null function)) ;function is nil, then
- nil ;Do nothing.
- (let ((hook-value (symbol-value hook)))
- (if (consp hook-value)
- (setq hook-value (delete function hook-value))
- (if (equal hook-value function)
- (setq hook-value nil)
- ))
- (set hook hook-value)
- )))
-
-
-;;; @ list
-;;;
-
-(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.
-\[emu-18.el; EMACS 19 emulating function]"
- (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'.
-\[emu-18.el; EMACS 19 emulating function]"
- (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))
- )
- (rplacd rest (cdr rrest))
- list)))
-
-
-;;; @ function
-;;;
-
-(defun defalias (sym newdef)
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.
-Associates the function with the current load file, if any.
-\[emu-18.el; EMACS 19 emulating function]"
- (fset sym newdef)
- )
-
-(defun byte-code-function-p (exp)
- "T if OBJECT is a byte-compiled function object.
-\[emu-18.el; EMACS 19 emulating function]"
- (and (consp exp)
- (let* ((rest (cdr (cdr exp))) 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))
- ))
- )))
-
-(defmacro-maybe defsubst (name arglist &rest body)
- "Define an inline function. The syntax is just like that of `defun'."
- (cons 'defun (cons name (cons arglist body)))
- )
-
-
-;;; @ file
-;;;
-
-(defun make-directory-internal (dirname)
- "Create a directory. One argument, a file name string.
-\[emu-18.el; EMACS 19 emulating function]"
- (if (file-exists-p dirname)
- (error "Creating directory: %s is already exist" dirname)
- (if (not (= (call-process "mkdir" nil nil nil dirname) 0))
- (error "Creating directory: no such file or directory, %s" dirname)
- )))
-
-(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.
-\[emu-18.el; EMACS 19 emulating function]"
- (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)
- ))
-
-;; Imported from files.el of EMACS 19.33.
-(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)))
-
-;; Imported from files.el of 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)))))
-
-(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.
-\[emu-18.el; EMACS 19 emulating function]"
- (si:directory-files directory full match)
- )
-
-
-;;; @ mark
-;;;
-
-(or (fboundp 'si:mark)
- (fset 'si:mark (symbol-function 'mark)))
-(defun mark (&optional force)
- (si:mark)
- )
-
-
-;;; @ mode-line
-;;;
-
-;;; Imported from Emacs 19.30.
-(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.
-\[emu-18.el; Emacs 19 emulating function]"
- (if all (save-excursion (set-buffer (other-buffer))))
- (set-buffer-modified-p (buffer-modified-p)))
-
-
-;;; @ overlay
-;;;
-
-(defun overlay-buffer (overlay))
-
-
-;;; @ text property
-;;;
-
-(defun remove-text-properties (start end properties &optional object))
-
-
-;;; @@ visible/invisible
-;;;
-
-(defmacro enable-invisible ()
- (`
- (progn
- (make-local-variable 'original-selective-display)
- (setq original-selective-display selective-display)
- (setq selective-display t)
- )))
-
-(defmacro end-of-invisible ()
- (` (setq selective-display
- (if (boundp 'original-selective-display)
- original-selective-display))
- ))
-
-(defun invisible-region (start end)
- (let ((buffer-read-only nil) ;Okay even if write protected.
- (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 ?\^M t)
- (set-buffer-modified-p modp)
- )))
-
-(defun visible-region (start end)
- (let ((buffer-read-only nil) ;Okay even if write protected.
- (modp (buffer-modified-p)))
- (unwind-protect
- (subst-char-in-region start end ?\^M ?\n t)
- (set-buffer-modified-p modp)
- )))
-
-(defun invisible-p (pos)
- (save-excursion
- (goto-char pos)
- (eq (following-char) ?\^M)
- ))
-
-(defun next-visible-point (pos)
- (save-excursion
- (goto-char pos)
- (end-of-line)
- (if (eq (following-char) ?\n)
- (forward-char)
- )
- (point)
- ))
-
-
-;;; @ mouse
-;;;
-
-(defvar mouse-button-1 nil)
-(defvar mouse-button-2 nil)
-(defvar mouse-button-3 nil)
-
-
-;;; @ string
-;;;
-
-(defun char-list-to-string (char-list)
- "Convert list of character CHAR-LIST to string. [emu-18.el]"
- (mapconcat (function char-to-string) char-list "")
- )
-
-
-;;; @ buffer
-;;;
-
-(defun-maybe 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))
-
-
-;;; @ end
-;;;
-
-(provide 'emu-18)
-
-;;; emu-18.el ends here
+++ /dev/null
-;;; emu-20.el --- emu API implementation for Emacs 20 and XEmacs/mule
-
-;; Copyright (C) 1997,1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, 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))
-
-
-;;; @ 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))
- (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 ((coding-system-for-read 'binary)
- 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 (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 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)))
-
-
-;;; @@ Mule emulating aliases
-;;;
-;;; You should not use it.
-
-(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.")
-
-
-;;; @ MIME charset
-;;;
-
-(defcustom mime-charset-coding-system-alist
- `,(let ((rest
- '((us-ascii . raw-text)
- (gb2312 . cn-gb-2312)
- (iso-2022-jp-2 . iso-2022-7bit-ss2)
- (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)))
-
-(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)))
- )
- (let ((ret (assq charset mime-charset-coding-system-alist)))
- (if ret
- (setq charset (cdr ret))
- ))
- (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 (find-coding-system charset)
- charset
- ))
-
-(defsubst mime-charset-list ()
- "Return a list of all existing MIME-charset."
- (nconc (mapcar (function car) mime-charset-coding-system-alist)
- (coding-system-list)))
-
-
-(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-ctext
- "Default value of MIME-charset.
-It is used when MIME-charset is not specified.
-It must be symbol."
- :group 'i18n
- :type 'mime-charset)
-
-(defsubst detect-mime-charset-region (start end)
- "Return MIME charset for region between START and END."
- (charsets-to-mime-charset (find-charset-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
-;;;
-
-(provide 'emu-20)
-
-;;; emu-20.el ends here
+++ /dev/null
-;;; emu-e19.el --- emu API implementation for Emacs 19.*
-
-;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Keywords: emulation, compatibility
-
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-;;; @ face
-;;;
-
-(defun-maybe find-face (face)
- (car (memq face (face-list)))
- )
-
-
-;;; @ for tm-7.106
-;;;
-
-(defalias 'tl:make-overlay 'make-overlay)
-(defalias 'tl:overlay-put 'overlay-put)
-(defalias 'tl:overlay-buffer 'overlay-buffer)
-
-(make-obsolete 'tl:make-overlay 'make-overlay)
-(make-obsolete 'tl:overlay-put 'overlay-put)
-(make-obsolete 'tl:overlay-buffer 'overlay-buffer)
-
-
-;;; @ visible/invisible
-;;;
-
-(defmacro enable-invisible ())
-
-(defmacro end-of-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)
- (save-excursion
- (goto-char (next-single-property-change pos 'invisible))
- (if (eq (following-char) ?\n)
- (forward-char)
- )
- (point)))
-
-
-;;; @ mouse
-;;;
-
-(defvar mouse-button-1 [mouse-1])
-(defvar mouse-button-2 [mouse-2])
-(defvar mouse-button-3 [down-mouse-3])
-
-
-;;; @ string
-;;;
-
-(defmacro char-list-to-string (char-list)
- "Convert list of character CHAR-LIST to string."
- (` (mapconcat (function char-to-string)
- (, char-list)
- "")))
-
-
-;;; @ end
-;;;
-
-(provide 'emu-e19)
-
-;;; emu-e19.el ends here
+++ /dev/null
-;;; emu-e20.el --- emu API implementation for Emacs 20.1 and 20.2
-
-;; Copyright (C) 1996,1997,1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This module requires Emacs 20.1 and 20.2.
-
-;;; Code:
-
-(require 'emu-e19)
-
-(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))))
-
-
-;;; @ coding system
-;;;
-
-(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)
-
-
-;;; @ MIME charset
-;;;
-
-(defsubst encode-mime-charset-region (start end charset)
- "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)))
- (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)
- "Encode the STRING as MIME CHARSET."
- (let (cs)
- (if (and enable-multibyte-characters
- (setq cs (mime-charset-to-coding-system charset)))
- (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
- '(((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)
- ((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) . cn-gb-2312)
- ((ascii chinese-big5-1 chinese-big5-2) . cn-big5)
- ((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)
- ))
-
-
-;;; @ character
-;;;
-
-;;; @@ Mule emulating aliases
-;;;
-;;; You should not use them.
-
-(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)))
-
-
-;;; @ CCL
-;;;
-(eval-when-compile (require 'ccl))
-
-(eval-when-compile
- (defconst ccl-use-symbol-as-program
- (progn
- (define-ccl-program ew-ccl-identity-program
- '(1 ((read r0) (loop (write-read-repeat r0)))))
- (condition-case nil
- (progn
- (funcall
- (if (fboundp 'ccl-vector-program-execute-on-string)
- 'ccl-vector-program-execute-on-string
- 'ccl-execute-on-string)
- 'ew-ccl-identity-program
- (make-vector 9 nil)
- "")
- t)
- (error nil)))
- "\
-T if CCL related builtins accept symbol as CCL program.
-(20.2 with ExCCL, 20.3 or later)
-Otherwise nil (20.2 without ExCCL or former).
-
-Because emu provides functions accepting symbol as CCL program,
-user programs should not refer this variable.")
- )
-
-(eval-and-compile
- (defconst ccl-use-symbol-as-program
- (eval-when-compile ccl-use-symbol-as-program))
-
- (defun make-ccl-coding-system
- (coding-system mnemonic doc-string decoder encoder)
- "\
-Define a new CODING-SYSTEM (symbol) by CCL programs
-DECODER (symbol) and ENCODER (symbol)."
- (unless ccl-use-symbol-as-program
- (setq decoder (symbol-value decoder))
- (setq encoder (symbol-value encoder)))
- (make-coding-system coding-system 4 mnemonic doc-string
- (cons decoder encoder)))
- )
-
-(eval-when-compile
- (define-ccl-program test-ccl-eof-block
- '(1
- (read r0)
- (write "[EOF]")))
-
- (unless (coding-system-p 'test-ccl-eof-block-cs)
- (make-ccl-coding-system
- 'test-ccl-eof-block-cs ?T "CCL_EOF_BLOCK tester"
- 'test-ccl-eof-block 'test-ccl-eof-block)
- )
- )
-
-(defconst ccl-encoder-eof-block-is-broken
- (eval-when-compile
- (not (equal (encode-coding-string "" 'test-ccl-eof-block-cs)
- "[EOF]")))
- "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
-encoding.")
-
-(defconst ccl-decoder-eof-block-is-broken
- (eval-when-compile
- (not (equal (decode-coding-string "" 'test-ccl-eof-block-cs)
- "[EOF]")))
- "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
-decoding.")
-
-(defconst ccl-eof-block-is-broken
- (or ccl-encoder-eof-block-is-broken
- ccl-decoder-eof-block-is-broken))
-
-(unless ccl-use-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.
-\[Emacs 20.3 emulating function]"
- (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.
-\[Emacs 20.3 emulating function]"
- (ccl-vector-program-execute-on-string
- (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
- status string contin)))
- )
-
-
-;;; @ end
-;;;
-
-(require 'emu-20)
-
-(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
-(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
-
-(defalias 'insert-binary-file-contents-literally
- 'insert-file-contents-literally)
-
-(if (and (fboundp 'set-buffer-multibyte)
- (subrp (symbol-function 'set-buffer-multibyte)))
- (require 'emu-e20_3) ; for Emacs 20.3
- (require 'emu-e20_2) ; for Emacs 20.1 and 20.2
- )
-
-
-(provide 'emu-e20)
-
-;;; emu-e20.el ends here
+++ /dev/null
-;;; emu-e20_2.el --- emu API implementation for Emacs 20.1 and 20.2
-
-;; Copyright (C) 1996,1997,1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This module requires Emacs 20.1 and 20.2.
-
-;;; Code:
-
-;;; @ 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 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)
-
-
-;;; @ 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))))
-
-
-;;; @ end
-;;;
-
-(provide 'emu-e20_2)
-
-;;; emu-e20_2.el ends here
+++ /dev/null
-;;; emu-e20_3.el --- emu API implementation for Emacs 20.3.
-
-;; Copyright (C) 1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This module requires Emacs 20.2.91 or later.
-
-;;; Code:
-
-;;; @ 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))
-
-
-;;; @ 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
-;;;
-
-(provide 'emu-e20_3)
-
-;;; emu-e20_3.el ends here
+++ /dev/null
-;;; emu-latin1.el --- emu module for Emacs 19 and XEmacs without MULE
-
-;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Keywords: emulation, compatibility, mule, Latin-1
-
-;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-;;; @ buffer representation
-;;;
-
-(defmacro-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)
-
-
-;;; @ coding-system
-;;;
-
-(defconst *internal* nil)
-(defconst *ctext* nil)
-(defconst *noconv* nil)
-
-(defun decode-coding-string (string coding-system)
- "Decode the STRING which is encoded in CODING-SYSTEM."
- string)
-
-(defun encode-coding-string (string coding-system)
- "Encode the STRING as CODING-SYSTEM."
- 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."
- )
-
-
-;;; @@ for old MULE emulation
-;;;
-
-(defun code-convert-string (str ic oc)
- "Convert code in STRING from SOURCE code to TARGET code,
-On successful converion, 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)
-
-
-;;; @ 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)))
-
-(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
-(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
-
-(defun 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."
- (let ((emx-binary-mode t))
- ;; Returns list of absolute file name and length of data inserted.
- (insert-file-contents-literally filename visit beg end replace)))
-
-(defalias 'insert-file-contents-as-raw-text 'insert-file-contents)
-
-(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))))
-
-
-;;; @ MIME charset
-;;;
-
-(defvar charsets-mime-charset-alist
- '(((ascii) . us-ascii)))
-
-(defvar default-mime-charset 'iso-8859-1)
-
-(defun mime-charset-to-coding-system (charset)
- (if (stringp charset)
- (setq charset (intern (downcase charset)))
- )
- (if (memq charset (list 'us-ascii default-mime-charset))
- charset
- ))
-
-(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)
- "Encode the text between START and END as MIME CHARSET."
- )
-
-(defun decode-mime-charset-region (start end charset &optional lbt)
- "Decode the text between START and END as MIME CHARSET."
- (cond ((eq lbt 'CRLF)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-min))
- (while (search-forward "\r\n" nil t)
- (replace-match "\n"))
- ))
- )))
-
-(defun encode-mime-charset-string (string charset)
- "Encode the STRING as MIME CHARSET."
- 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)
-
-
-;;; @ character
-;;;
-
-(defun char-charset (char)
- "Return the character set of char CHAR."
- (if (< chr 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))
- (substring str start-column width))
-
-(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
-;;;
-
-(provide 'emu-latin1)
-
-;;; emu-latin1.el ends here
;;; Code:
-;;; @ version specific features
-;;;
-
-(cond (running-emacs-19
- (require 'emu-e19)
-
- ;; 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))
- ))))
- )
- (running-emacs-18
- (require 'emu-18)
- (defun make-overlay (beg end &optional buffer type))
- (defun overlay-put (overlay prop value))
- ))
-
-
-;;; @ 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))
-
-
-;;; @ coding system
-;;;
-
-(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)
-
-(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)
-
-
-;;; @ binary access
-;;;
-
-(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)))
-
-(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
-(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
-
-(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."
- (save-excursion
- (save-restriction
- (narrow-to-region (point)(point))
- (let ((return-val
- ;; Returns list absolute file name and length of data inserted.
- (insert-file-contents-as-binary filename visit beg end replace)))
- (goto-char (point-min))
- (while (re-search-forward "\r$" nil t)
- (replace-match ""))
- (list (car return-val) (buffer-size))))))
-
-(defun 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)))
-
-(cond
- (running-emacs-19_29-or-later
- ;; for MULE 2.3 based on Emacs 19.34.
- (defun write-region-as-binary (start end filename
- &optional append visit lockname)
- "Like `write-region', q.v., but don't code conversion."
- (as-binary-output-file
- (write-region 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."
- (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 lockname))))
- )
- (t
- ;; for MULE 2.3 based on Emacs 19.28.
- (defun write-region-as-binary (start end filename
- &optional append visit lockname)
- "Like `write-region', q.v., but don't code conversion."
- (as-binary-output-file
- (write-region start end filename append visit)))
-
- (defun write-region-as-raw-text-CRLF (start end filename
- &optional append visit lockname)
- "Like `write-region', q.v., but don't code conversion."
- (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))))
- ))
-
-
-;;; @ MIME charset
-;;;
-
-(defun encode-mime-charset-region (start end charset)
- "Encode the text between START and END as MIME CHARSET."
- (let ((cs (mime-charset-to-coding-system charset)))
- (if cs
- (code-convert start end *internal* cs)
- )))
-
-(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))
- newline)
- (if cs
- (code-convert start end cs *internal*)
- (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
- (progn
- (if (setq newline (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")))))
- (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)
- "Encode the STRING as MIME CHARSET."
- (let ((cs (mime-charset-to-coding-system charset)))
- (if cs
- (code-convert-string string *internal* 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))
- newline)
- (if cs
- (decode-coding-string string cs)
- (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
- (progn
- (if (setq newline (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")))))
- (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
- (running-emacs-19_29-or-later
- ;; 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
-;;;
-
-(require 'cyrillic)
-
-(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)
- (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.")
-
-(defun detect-mime-charset-region (start end)
- "Return MIME charset for region between START and END."
- (charsets-to-mime-charset
- (cons lc-ascii (find-charset-region start end))))
-
-
-;;; @ 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)
-
-(or (fboundp 'truncate-string)
- ;; 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)
+(require 'poem)
;;; @ regulation
dest))
-;;; @ CCL
-;;;
-(eval-when-compile (require 'ccl))
-
-(defconst ccl-use-symbol-as-program nil
- "t if CCL related builtins accept symbol as CCL program.
-(20.2 with ExCCL, 20.3 or later)
-Otherwise nil (20.2 without ExCCL or former).
-
-Because emu provides functions accepting symbol as CCL program,
-user programs should not refer this variable.")
-
-(defun make-ccl-coding-system
- (coding-system mnemonic doc-string decoder encoder)
- "Define a new CODING-SYSTEM (symbol) by CCL programs
-DECODER (symbol) and ENCODER (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)))
-
-(eval-when-compile
- (define-ccl-program test-ccl-eof-block
- '(1
- (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)
- )
-
-(defconst ccl-encoder-eof-block-is-broken
- (eval-when-compile
- (not (equal (encode-coding-string "" 'test-ccl-eof-block-cs)
- "[EOF]")))
- "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
-encoding.")
-
-(defconst ccl-decoder-eof-block-is-broken
- (eval-when-compile
- (not (equal (decode-coding-string "" 'test-ccl-eof-block-cs)
- "[EOF]")))
- "t if CCL_EOF_BLOCK is not executed when coding system encounts EOF on
-decoding.")
-
-(defconst ccl-eof-block-is-broken
- (or ccl-encoder-eof-block-is-broken
- ccl-decoder-eof-block-is-broken))
-
-(defun ccl-execute (ccl-prog reg)
- "Execute CCL-PROG with registers initialized by REGISTERS.
-If CCL-PROG is symbol, it is dereferenced.
-\[Emacs 20.3 emulating function]"
- (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.
-\[Emacs 20.3 emulating function]"
- (exec-ccl-string
- (if (symbolp ccl-prog) (symbol-value ccl-prog) ccl-prog)
- status string))
-
-
;;; @ end
;;;
+++ /dev/null
-;;; emu-nemacs.el --- emu API implementation for NEmacs
-
-;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Keywords: emulation, compatibility, NEmacs, 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(require 'emu-18)
-
-
-;;; @ 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)
-
-
-;;; @ coding system
-;;;
-
-(defconst *noconv* 0)
-(defconst *sjis* 1)
-(defconst *junet* 2)
-(defconst *ctext* 2)
-(defconst *internal* 3)
-(defconst *euc-japan* 3)
-
-(defun decode-coding-string (string coding-system)
- "Decode the STRING which is encoded in CODING-SYSTEM.
-\[emu-nemacs.el; EMACS 20 emulating function]"
- (if (eq coding-system 3)
- string
- (convert-string-kanji-code string coding-system 3)))
-
-(defun encode-coding-string (string coding-system)
- "Encode the STRING to CODING-SYSTEM.
-\[emu-nemacs.el; EMACS 20 emulating function]"
- (if (eq coding-system 3)
- string
- (convert-string-kanji-code string 3 coding-system)))
-
-(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]"
- (if (/= ic oc)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end coding-system 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]"
- (if (/= ic oc)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end 3 coding-system)))
- ))
-
-(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-japan*
- ))
-
-(defalias 'set-buffer-file-coding-system 'set-kanji-fileio-code)
-
-
-;;; @@ for old MULE emulation
-;;;
-
-(defun code-convert-string (str ic oc)
- "Convert code in STRING from SOURCE code to TARGET code,
-On successful converion, returns the result string,
-else returns nil. [emu-nemacs.el; Mule emulating function]"
- (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. [emu-nemacs.el; Mule emulating function]"
- (if (/= ic oc)
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (convert-region-kanji-code beg end ic oc)))
- ))
-
-
-;;; @ 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)
- (,@ 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 beg end replace)))
-
-(fset 'insert-binary-file-contents 'insert-file-contents-as-binary)
-
-(defun 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.
-\[emu-nemacs.el]"
- (as-binary-input-file
- ;; Returns list absolute file name and length of data inserted.
- (insert-file-contents-literally filename visit beg end replace)))
-
-(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.
-\[emu-nemacs.el]"
- (as-binary-input-file
- ;; Returns list 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 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))))
-
-
-;;; @ MIME charset
-;;;
-
-(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)
- ))
-
-(defun mime-charset-to-coding-system (charset)
- (if (stringp charset)
- (setq charset (intern (downcase charset)))
- )
- (cdr (assq charset mime-charset-coding-system-alist)))
-
-(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)
- "Encode the text between START and END as MIME CHARSET.
-\[emu-nemacs.el]"
- (let ((cs (mime-charset-to-coding-system charset)))
- (and (numberp cs)
- (or (= cs 3)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (convert-region-kanji-code start end 3 cs))))
- )))
-
-(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 (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")
- (dos . "\r\n") (mac . "\r"))))))
- (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)
- "Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
- (let ((cs (mime-charset-to-coding-system charset)))
- (if cs
- (convert-string-kanji-code string 3 cs)
- 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)
- *noconv*)))
- (write-region start end filename)))
-
-
-;;; @ 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."
- (` (+ (, 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-columns 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-columns 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)
-
-
-;;; @ text property emulation
-;;;
-
-(defvar emu:available-face-attribute-alist
- '(
- ;;(bold . inversed-region)
- (italic . underlined-region)
- (underline . underlined-region)
- ))
-
-;; by YAMATE Keiichirou 1994/10/28
-(defun attribute-add-narrow-attribute (attr from to)
- (or (consp (symbol-value attr))
- (set attr (list 1)))
- (let* ((attr-value (symbol-value attr))
- (len (car attr-value))
- (posfrom 1)
- posto)
- (while (and (< posfrom len)
- (> from (nth posfrom attr-value)))
- (setq posfrom (1+ posfrom)))
- (setq posto posfrom)
- (while (and (< posto len)
- (> to (nth posto attr-value)))
- (setq posto (1+ posto)))
- (if (= posto posfrom)
- (if (= (% posto 2) 1)
- (if (and (< to len)
- (= to (nth posto attr-value)))
- (set-marker (nth posto attr-value) from)
- (setcdr (nthcdr (1- posfrom) attr-value)
- (cons (set-marker-type (set-marker (make-marker)
- from)
- 'point-type)
- (cons (set-marker-type (set-marker (make-marker)
- to)
- nil)
- (nthcdr posto attr-value))))
- (setcar attr-value (+ len 2))))
- (if (= (% posfrom 2) 0)
- (setq posfrom (1- posfrom))
- (set-marker (nth posfrom attr-value) from))
- (if (= (% posto 2) 0)
- nil
- (setq posto (1- posto))
- (set-marker (nth posto attr-value) to))
- (setcdr (nthcdr posfrom attr-value)
- (nthcdr posto attr-value)))))
-
-(defalias 'make-overlay 'cons)
-
-(defun overlay-put (overlay prop value)
- (let ((ret (and (eq prop 'face)
- (assq value emu:available-face-attribute-alist)
- )))
- (if ret
- (attribute-add-narrow-attribute (cdr ret)
- (car overlay)(cdr overlay))
- )))
-
-
-;;; @ end
-;;;
-
-(provide 'emu-nemacs)
-
-;;; emu-nemacs.el ends here
+++ /dev/null
-;;; emu-x20.el --- emu API implementation for XEmacs with mule
-
-;; Copyright (C) 1994,1995,1996,1997,1998 MORIOKA Tomohiko
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Keywords: emulation, compatibility, 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This module requires XEmacs 20.3-b5 or later with mule.
-
-;;; Code:
-
-(require 'emu-20)
-
-
-;;; @ 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))
-
-;; 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))
-
-(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 '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)))
-
-
-;;; @ CCL
-;;;
-
-(defun make-ccl-coding-system (name mnemonic doc-string decoder encoder)
- (make-coding-system
- name 'ccl doc-string
- (list 'mnemonic (char-to-string mnemonic)
- 'decode (symbol-value decoder)
- 'encode (symbol-value encoder))))
-
-
-;;; @ without code-conversion
-;;;
-
-(define-obsolete-function-alias 'insert-binary-file-contents
- 'insert-file-contents-as-binary)
-
-(defun 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."
- (let ((coding-system-for-read 'binary))
- ;; Returns list absolute file name and length of data inserted.
- (insert-file-contents-literally filename visit beg end replace)))
-
-
-;;; @ MIME charset
-;;;
-
-(defun encode-mime-charset-region (start end charset)
- "Encode the text between START and END as MIME CHARSET."
- (let ((cs (mime-charset-to-coding-system charset)))
- (if cs
- (encode-coding-region start end cs)
- )))
-
-(defcustom mime-charset-decoder-alist
- '((iso-2022-jp . decode-mime-charset-region-with-iso646-unification)
- (iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification)
- (x-ctext . decode-mime-charset-region-with-iso646-unification)
- (hz-gb-2312 . decode-mime-charset-region-for-hz)
- (t . decode-mime-charset-region-default))
- "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)
- )))
-
-(defcustom mime-iso646-character-unification-alist
- `,(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."
- :group 'i18n
- :type 'integer)
-
-(defun decode-mime-charset-region-with-iso646-unification (start end charset
- lbt)
- (decode-mime-charset-region-default start end charset lbt)
- (if (<= (- end start) mime-character-unification-limit-size)
- (save-excursion
- (let ((rest mime-iso646-character-unification-alist))
- (while rest
- (let ((pair (car rest)))
- (goto-char (point-min))
- (while (search-forward (car pair) nil t)
- (let ((str (cdr pair)))
- (put-text-property 0 (length str)
- 'face mime-unified-character-face str)
- (replace-match str 'fixed-case 'literal)
- )
- ))
- (setq rest (cdr rest)))))
- ))
-
-(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)))
-
-(defsubst encode-mime-charset-string (string charset)
- "Encode the STRING as MIME CHARSET."
- (let ((cs (mime-charset-to-coding-system charset)))
- (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
- '(((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)
- ((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) . cn-gb-2312)
- ((ascii chinese-big5-1 chinese-big5-2) . cn-big5)
- ((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)
- ))
-
-
-;;; @ 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 (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))
-
-;;; @@ Mule emulating aliases
-;;;
-;;; You should not use them.
-
-;;(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)
- (char-to-string (int-char chr)))
- (char-category-list character)
- ""))
-
-
-;;; @ string
-;;;
-
-(defun string-to-int-list (str)
- (mapcar #'char-int str))
-
-(defalias 'looking-at-as-unibyte 'looking-at)
-
-
-;;; @ end
-;;;
-
-(provide 'emu-x20)
-
-;;; emu-x20.el ends here
+++ /dev/null
-;;; emu-xemacs.el --- emu API implementation for XEmacs
-
-;; Copyright (C) 1995 Free Software Foundation, Inc.
-;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko
-
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; Version:
-;; $Id: emu-xemacs.el,v 7.19 1997/04/05 06:50:48 morioka Exp $
-;; Keywords: emulation, compatibility, XEmacs
-
-;; This file is part of XEmacs.
-
-;; 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., 59 Temple Place - Suite 330, Boston, MA
-;; 02111-1307, USA.
-
-;;; Code:
-
-;;; @ face
-;;;
-
-(or (fboundp 'face-list)
- (defalias '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 'overlay-put 'set-extent-property)
- (defalias 'overlay-buffer 'extent-buffer)
- (defun move-overlay (extent start end &optional buffer)
- (set-extent-endpoints extent start end)
- )
- ))
-
-
-;;; @ visible/invisible
-;;;
-
-(defmacro enable-invisible ())
-
-(defmacro end-of-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))))
-
-
-;;; @ mouse
-;;;
-
-(defvar mouse-button-1 'button1)
-(defvar mouse-button-2 'button2)
-(defvar mouse-button-3 'button3)
-
-
-;;; @ dired
-;;;
-
-(or (fboundp 'dired-other-frame)
- (defun 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)))
- )
-
-
-;;; @ string
-;;;
-
-(defmacro char-list-to-string (char-list)
- "Convert list of character CHAR-LIST to string. [emu-xemacs.el]"
- `(mapconcat #'char-to-string ,char-list ""))
-
-
-;;; @@ 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). [emu-xemacs.el]"
- (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)))))
- )
-
-
-;;; @ end
-;;;
-
-(provide 'emu-xemacs)
-
-;;; emu-xemacs.el ends here
;;; Code:
-(defmacro defun-maybe (name &rest everything-else)
- (or (and (fboundp name)
- (not (get name 'defun-maybe))
- )
- (` (or (fboundp (quote (, name)))
- (progn
- (defun (, name) (,@ everything-else))
- (put (quote (, name)) 'defun-maybe t)
- ))
- )))
-
-(defmacro defsubst-maybe (name &rest everything-else)
- (or (and (fboundp name)
- (not (get name 'defsubst-maybe))
- )
- (` (or (fboundp (quote (, name)))
- (progn
- (defsubst (, name) (,@ everything-else))
- (put (quote (, name)) 'defsubst-maybe t)
- ))
- )))
-
-(defmacro defmacro-maybe (name &rest everything-else)
- (or (and (fboundp name)
- (not (get name 'defmacro-maybe))
- )
- (` (or (fboundp (quote (, name)))
- (progn
- (defmacro (, name) (,@ everything-else))
- (put (quote (, name)) 'defmacro-maybe t)
- ))
- )))
-
-(put 'defun-maybe 'lisp-indent-function 'defun)
-(put 'defsubst-maybe 'lisp-indent-function 'defun)
-(put 'defmacro-maybe 'lisp-indent-function 'defun)
-
-(defmacro defconst-maybe (name &rest everything-else)
- (or (and (boundp name)
- (not (get name 'defconst-maybe))
- )
- (` (or (boundp (quote (, name)))
- (progn
- (defconst (, name) (,@ everything-else))
- (put (quote (, name)) 'defconst-maybe t)
- ))
- )))
-
-
-(defconst-maybe emacs-major-version (string-to-int emacs-version))
-(defconst-maybe emacs-minor-version
- (string-to-int
- (substring emacs-version
- (string-match (format "%d\\." emacs-major-version)
- emacs-version))))
+(require 'poe)
(defvar running-emacs-18 (<= emacs-major-version 18))
-(defvar running-xemacs (string-match "XEmacs" emacs-version))
+(defvar running-xemacs (featurep 'xemacs))
(defvar running-mule-merged-emacs (and (not (boundp 'MULE))
(not running-xemacs) (featurep 'mule)))
(cond (running-xemacs
;; for XEmacs
- (require 'emu-xemacs)
- (if (featurep 'mule)
- ;; for XEmacs with MULE
- (require 'emu-x20)
- ;; for XEmacs without MULE
- (require 'emu-latin1)
- ))
- (running-mule-merged-emacs
- ;; for Emacs 20.1 and 20.2
- (require 'emu-e20)
+ (defvar mouse-button-1 'button1)
+ (defvar mouse-button-2 'button2)
+ (defvar mouse-button-3 'button3)
)
- ((boundp 'MULE)
- ;; for MULE 1.* and 2.*
- (require 'emu-mule)
+ ((>= 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-put)
+ (defalias 'tl:overlay-buffer 'overlay-buffer)
+ (make-obsolete 'tl:overlay-buffer 'overlay-buffer)
+ )
+
+(require 'poem)
+(require 'mcharset)
+
+(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)
+ (char-to-string (int-char chr)))
+ (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
- (require 'emu-nemacs)
+
+ ;; 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 converion, returns the result string,
+else returns nil. [emu-nemacs.el; Mule emulating function]"
+ (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. [emu-nemacs.el; Mule emulating function]"
+ (if (/= ic oc)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (convert-region-kanji-code beg end ic oc)))
+ ))
)
(t
- ;; for Emacs 19
- (require 'emu-e19)
- (require 'emu-latin1)
+ ;; 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 converion, 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)
))
-;;; @ MIME charset
-;;;
-
-(defun charsets-to-mime-charset (charsets)
- "Return MIME charset from list of charset CHARSETS.
-This function refers variable `charsets-mime-charset-alist'
-and `default-mime-charset'."
- (if charsets
- (or (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)))))
- default-mime-charset)))
-
-
-;;; @ Emacs 19 emulation
+;;; @ Mule emulating aliases
;;;
+;;; You should not use it.
-(defun-maybe minibuffer-prompt-width ()
- "Return the display width of the minibuffer prompt."
- (save-excursion
- (set-buffer (window-buffer (minibuffer-window)))
- (current-column)))
+(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."))
-;;; @ Emacs 19.29 emulation
+;;; @ without code-conversion
;;;
-(defvar path-separator ":"
- "Character used to separate concatenated paths.")
-
-(defun-maybe buffer-substring-no-properties (start end)
- "Return the characters of part of the buffer, without the text properties.
-The two arguments START and END are character positions;
-they can be in either order. [Emacs 19.29 emulating function]"
- (let ((string (buffer-substring start end)))
- (set-text-properties 0 (length string) nil string)
- string))
-
-(defun-maybe match-string (num &optional string)
- "Return string of text matched by last search.
-NUM specifies which parenthesized expression in the last regexp.
- Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
-Zero means the entire text matched by the whole regexp or whole string.
-STRING should be given if the last search was by `string-match' on STRING.
-\[Emacs 19.29 emulating function]"
- (if (match-beginning num)
- (if string
- (substring string (match-beginning num) (match-end num))
- (buffer-substring (match-beginning num) (match-end num)))))
-
-(or running-emacs-19_29-or-later
- running-xemacs
- ;; for Emacs 19.28 or earlier
- (fboundp 'si:read-string)
- (progn
- (fset 'si:read-string (symbol-function 'read-string))
-
- (defun read-string (prompt &optional initial-input history)
- "Read a string from the minibuffer, prompting with string PROMPT.
-If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
-The third arg HISTORY, is dummy for compatibility. [emu.el]
-See `read-from-minibuffer' for details of HISTORY argument."
- (si:read-string prompt initial-input))
- ))
-
-
-;;; @ Emacs 19.30 emulation
-;;;
+(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary)
+(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary)
-;; This function was imported Emacs 19.30.
-(defun-maybe add-to-list (list-var element)
- "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
-If you want to use `add-to-list' on a variable that is not defined
-until a certain package is loaded, you should put the call to `add-to-list'
-into a hook function that will be run only after loading the package.
-\[Emacs 19.30 emulating function]"
- (or (member element (symbol-value list-var))
- (set list-var (cons element (symbol-value list-var)))))
-
-(cond ((fboundp 'insert-file-contents-literally)
- )
- ((boundp 'file-name-handler-alist)
- (defun insert-file-contents-literally
- (filename &optional visit beg end replace)
- "Like `insert-file-contents', q.v., but only reads in the file.
+(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.
-\[Emacs 19.30 emulating function]"
- (let (file-name-handler-alist)
- (insert-file-contents filename visit beg end replace)))
- )
- (t
- (defalias 'insert-file-contents-literally 'insert-file-contents)
- ))
-
-
-;;; @ Emacs 19.31 emulation
-;;;
-
-(defun-maybe buffer-live-p (object)
- "Return non-nil if OBJECT is a buffer which has not been killed.
-Value is nil if OBJECT is not a buffer or if it has been killed.
-\[Emacs 19.31 emulating function]"
- (and object
- (get-buffer object)
- (buffer-name (get-buffer object))))
-
-;; This macro was imported Emacs 19.33.
-(defmacro-maybe save-selected-window (&rest body)
- "Execute BODY, then select the window that was selected before BODY.
-\[Emacs 19.31 emulating function]"
- (list 'let
- '((save-selected-window-window (selected-window)))
- (list 'unwind-protect
- (cons 'progn body)
- (list 'select-window 'save-selected-window-window))))
-
-
-;;; @ Emacs 20.1 emulation
-;;;
-
-;; This macro was imported Emacs 20.2.
-(defmacro-maybe when (cond &rest body)
- "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
- (list 'if cond (cons 'progn body)))
-
-(defmacro-maybe save-current-buffer (&rest body)
- "Save the current buffer; execute BODY; restore the current buffer.
-Executes BODY just like `progn'."
- (` (let ((orig-buffer (current-buffer)))
- (unwind-protect
- (progn (,@ body))
- (set-buffer orig-buffer)))))
-
-;; This macro was imported Emacs 20.2.
-(defmacro-maybe with-current-buffer (buffer &rest body)
- "Execute the forms in BODY with BUFFER as the current buffer.
-The value returned is the value of the last form in BODY.
-See also `with-temp-buffer'."
- (` (save-current-buffer
- (set-buffer (, buffer))
- (,@ body))))
-
-;; This macro was imported Emacs 20.2.
-(defmacro-maybe with-temp-file (file &rest forms)
- "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
-The value of the last form in FORMS is returned, like `progn'.
-See also `with-temp-buffer'."
- (let ((temp-file (make-symbol "temp-file"))
- (temp-buffer (make-symbol "temp-buffer")))
- (` (let (((, temp-file) (, file))
- ((, temp-buffer)
- (get-buffer-create (generate-new-buffer-name " *temp file*"))))
- (unwind-protect
- (prog1
- (with-current-buffer (, temp-buffer)
- (,@ forms))
- (with-current-buffer (, temp-buffer)
- (widen)
- (write-region (point-min) (point-max) (, temp-file) nil 0)))
- (and (buffer-name (, temp-buffer))
- (kill-buffer (, temp-buffer))))))))
-
-;; This macro was imported Emacs 20.2.
-(defmacro-maybe with-temp-buffer (&rest forms)
- "Create a temporary buffer, and evaluate FORMS there like `progn'.
-See also `with-temp-file' and `with-output-to-string'."
- (let ((temp-buffer (make-symbol "temp-buffer")))
- (` (let (((, temp-buffer)
- (get-buffer-create (generate-new-buffer-name " *temp*"))))
- (unwind-protect
- (with-current-buffer (, temp-buffer)
- (,@ forms))
- (and (buffer-name (, temp-buffer))
- (kill-buffer (, temp-buffer))))))))
-
-;; This function was imported Emacs 20.3.
-(defun-maybe last (x &optional n)
- "Return the last link of the list X. Its car is the last element.
-If X is nil, return nil.
-If N is non-nil, return the Nth-to-last link of X.
-If N is bigger than the length of X, return X."
- (if n
- (let ((m 0) (p x))
- (while (consp p)
- (setq m (1+ m) p (cdr p)))
- (if (<= n 0) p
- (if (< n m) (nthcdr (- m n) x) x)))
- (while (cdr x)
- (setq x (cdr x)))
- x))
-
-;; This function was imported Emacs 20.3. (cl function)
-(defun-maybe butlast (x &optional n)
- "Returns a copy of LIST with the last N elements removed."
- (if (and n (<= n 0)) x
- (nbutlast (copy-sequence x) n)))
-
-;; This function was imported Emacs 20.3. (cl function)
-(defun-maybe nbutlast (x &optional n)
- "Modifies LIST to remove the last N elements."
- (let ((m (length x)))
- (or n (setq n 1))
- (and (< n m)
- (progn
- (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
- x))))
-
-;; This function was imported from XEmacs 21.
-(defun-maybe split-string (string &optional pattern)
- "Return a list of substrings of STRING which are separated by PATTERN.
-If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
- (or pattern
- (setq pattern "[ \f\t\n\r\v]+"))
- ;; The FSF version of this function takes care not to cons in case
- ;; of infloop. Maybe we should synch?
- (let (parts (start 0))
- (while (string-match pattern string start)
- (setq parts (cons (substring string start (match-beginning 0)) parts)
- start (match-end 0)))
- (nreverse (cons (substring string start) parts))))
-
-
-;;; @ Emacs 20.3 emulation
-;;;
-
-(defmacro-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)
-
-(defmacro-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)
-
-
-;;; @ XEmacs emulation
-;;;
-
-(defun-maybe functionp (obj)
- "Returns t if OBJ is a function, nil otherwise.
-\[XEmacs emulating function]"
- (or (subrp obj)
- (byte-code-function-p obj)
- (and (symbolp obj)(fboundp obj))
- (and (consp obj)(eq (car obj) 'lambda))
- ))
-
-(defun-maybe point-at-eol (&optional arg buffer)
- "Return the character position of the last character on the current line.
-With argument N not nil or 1, move forward N - 1 lines first.
-If scan reaches end of buffer, return that position.
-This function does not move point. [XEmacs emulating function]"
- (save-excursion
- (if buffer
- (set-buffer buffer)
- )
- (if arg
- (forward-line (1- arg))
- )
- (end-of-line)
- (point)))
-
-
-;;; @ for XEmacs 20
-;;;
-
-(or (fboundp 'char-int)
- (fset 'char-int (symbol-function 'identity))
- )
-(or (fboundp 'int-char)
- (fset 'int-char (symbol-function 'identity))
- )
-(or (fboundp 'char-or-char-int-p)
- (fset 'char-or-char-int-p (symbol-function 'integerp))
- )
+\[emu-nemacs.el]"
+ (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
(or
(catch 'tag
(let ((rest default-load-path)
+ (pat (concat "^"
+ (expand-file-name (concat ".*/" elisp-prefix) prefix)
+ "/?$"))
dir)
(while (setq dir (car rest))
- (if (string-match
- (` (, (concat "^"
- (expand-file-name (concat ".*/" elisp-prefix) prefix)
- "/?$")))
- dir)
+ (if (string-match pat dir)
(if (or allow-version-specific
(not (string-match (format "%d\\.%d"
emacs-major-version
--- /dev/null
+;;; mcharset.el --- MIME charset API
+
+;; Copyright (C) 1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poe)
+
+(cond ((featurep 'mule)
+ (cond ((featurep 'xemacs)
+ (require 'mcs-xm)
+ )
+ ((>= emacs-major-version 20)
+ (require 'mcs-e20)
+ )
+ (t
+ ;; for MULE 1.* and 2.*
+ (require 'mcs-om)
+ ))
+ )
+ ((boundp 'NEMACS)
+ ;; for Nemacs and Nepoch
+ (require 'mcs-nemacs)
+ )
+ (t
+ (require 'mcs-ltn1)
+ ))
+
+
+(defun charsets-to-mime-charset (charsets)
+ "Return MIME charset from list of charset CHARSETS.
+This function refers variable `charsets-mime-charset-alist'
+and `default-mime-charset'."
+ (if charsets
+ (or (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)))))
+ default-mime-charset)))
+
+
+;;; @ end
+;;;
+
+(provide 'mcharset)
+
+;;; mcharset.el ends here
--- /dev/null
+;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule
+
+;; Copyright (C) 1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
+;; or later.
+
+;;; Code:
+
+(require 'poem)
+(require 'custom)
+(eval-when-compile (require 'wid-edit))
+
+
+;;; @ MIME charset
+;;;
+
+(defcustom mime-charset-coding-system-alist
+ `,(let ((rest
+ '((us-ascii . raw-text)
+ (gb2312 . cn-gb-2312)
+ (iso-2022-jp-2 . iso-2022-7bit-ss2)
+ (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)))
+
+(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)))
+ )
+ (let ((ret (assq charset mime-charset-coding-system-alist)))
+ (if ret
+ (setq charset (cdr ret))
+ ))
+ (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 (find-coding-system charset)
+ charset
+ ))
+
+(defsubst mime-charset-list ()
+ "Return a list of all existing MIME-charset."
+ (nconc (mapcar (function car) mime-charset-coding-system-alist)
+ (coding-system-list)))
+
+
+(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-ctext
+ "Default value of MIME-charset.
+It is used when MIME-charset is not specified.
+It must be symbol."
+ :group 'i18n
+ :type 'mime-charset)
+
+(defsubst detect-mime-charset-region (start end)
+ "Return MIME charset for region between START and END."
+ (charsets-to-mime-charset (find-charset-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
+;;;
+
+(provide 'mcs-20)
+
+;;; mcs-20.el ends here
--- /dev/null
+;;; mcs-e20.el --- MIME charset implementation for Emacs 20.1 and 20.2
+
+;; Copyright (C) 1996,1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module requires Emacs 20.1 and 20.2.
+
+;;; Code:
+
+(defsubst encode-mime-charset-region (start end charset)
+ "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)))
+ (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)
+ "Encode the STRING as MIME CHARSET."
+ (let (cs)
+ (if (and enable-multibyte-characters
+ (setq cs (mime-charset-to-coding-system charset)))
+ (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
+ '(((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)
+ ((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) . cn-gb-2312)
+ ((ascii chinese-big5-1 chinese-big5-2) . cn-big5)
+ ((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)
+ ))
+
+
+;;; @ end
+;;;
+
+(require 'mcs-20)
+
+(provide 'mcs-e20)
+
+;;; mcs-e20.el ends here
--- /dev/null
+;;; mcs-ltn1.el --- MIME charset implementation for Emacs 19
+;;; and XEmacs without MULE
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(defvar charsets-mime-charset-alist
+ '(((ascii) . us-ascii)))
+
+(defvar default-mime-charset 'iso-8859-1)
+
+(defun mime-charset-to-coding-system (charset)
+ (if (stringp charset)
+ (setq charset (intern (downcase charset)))
+ )
+ (if (memq charset (list 'us-ascii default-mime-charset))
+ charset
+ ))
+
+(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)
+ "Encode the text between START and END as MIME CHARSET."
+ )
+
+(defun decode-mime-charset-region (start end charset &optional lbt)
+ "Decode the text between START and END as MIME CHARSET."
+ (cond ((eq lbt 'CRLF)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n"))
+ ))
+ )))
+
+(defun encode-mime-charset-string (string charset)
+ "Encode the STRING as MIME CHARSET."
+ 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
+;;;
+
+(provide 'mcs-ltn1)
+
+;;; mcs-ltn1.el ends here
--- /dev/null
+;;; mcs-nemacs.el --- MIME charset implementation for Nemacs
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, 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)
+ ))
+
+(defun mime-charset-to-coding-system (charset)
+ (if (stringp charset)
+ (setq charset (intern (downcase charset)))
+ )
+ (cdr (assq charset mime-charset-coding-system-alist)))
+
+(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)
+ "Encode the text between START and END as MIME CHARSET.
+\[emu-nemacs.el]"
+ (let ((cs (mime-charset-to-coding-system charset)))
+ (and (numberp cs)
+ (or (= cs 3)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (convert-region-kanji-code start end 3 cs))))
+ )))
+
+(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 (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")
+ (dos . "\r\n") (mac . "\r"))))))
+ (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)
+ "Encode the STRING as MIME CHARSET. [emu-nemacs.el]"
+ (let ((cs (mime-charset-to-coding-system charset)))
+ (if cs
+ (convert-string-kanji-code string 3 cs)
+ 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
+;;;
+
+(provide 'mcs-nemacs)
+
+;;; mcs-nemacs.el ends here
--- /dev/null
+;;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poem)
+
+(defun encode-mime-charset-region (start end charset)
+ "Encode the text between START and END as MIME CHARSET."
+ (let ((cs (mime-charset-to-coding-system charset)))
+ (if cs
+ (code-convert start end *internal* cs)
+ )))
+
+(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))
+ newline)
+ (if cs
+ (code-convert start end cs *internal*)
+ (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
+ (progn
+ (if (setq newline (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")))))
+ (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)
+ "Encode the STRING as MIME CHARSET."
+ (let ((cs (mime-charset-to-coding-system charset)))
+ (if cs
+ (code-convert-string string *internal* 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))
+ newline)
+ (if cs
+ (decode-coding-string string cs)
+ (if (and lbt (setq cs (mime-charset-to-coding-system charset)))
+ (progn
+ (if (setq newline (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r")))))
+ (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
+ (running-emacs-19_29-or-later
+ ;; 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
+;;;
+
+(require 'cyrillic)
+
+(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)
+ (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.")
+
+(defun detect-mime-charset-region (start end)
+ "Return MIME charset for region between START and END."
+ (charsets-to-mime-charset
+ (cons lc-ascii (find-charset-region start end))))
+
+
+;;; @ end
+;;;
+
+(provide 'mcs-om)
+
+;;; mcs-om.el ends here
--- /dev/null
+;;; mcs-xm.el --- MIME charset implementation for XEmacs-mule
+
+;; Copyright (C) 1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
+;; or later.
+
+;;; Code:
+
+(require 'mcs-20)
+
+
+(defun encode-mime-charset-region (start end charset)
+ "Encode the text between START and END as MIME CHARSET."
+ (let ((cs (mime-charset-to-coding-system charset)))
+ (if cs
+ (encode-coding-region start end cs)
+ )))
+
+
+(defcustom mime-charset-decoder-alist
+ '((iso-2022-jp . decode-mime-charset-region-with-iso646-unification)
+ (iso-2022-jp-2 . decode-mime-charset-region-with-iso646-unification)
+ (x-ctext . decode-mime-charset-region-with-iso646-unification)
+ (hz-gb-2312 . decode-mime-charset-region-for-hz)
+ (t . decode-mime-charset-region-default))
+ "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)
+ )))
+
+(defcustom mime-iso646-character-unification-alist
+ `,(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."
+ :group 'i18n
+ :type 'integer)
+
+(defun decode-mime-charset-region-with-iso646-unification (start end charset
+ lbt)
+ (decode-mime-charset-region-default start end charset lbt)
+ (if (<= (- end start) mime-character-unification-limit-size)
+ (save-excursion
+ (let ((rest mime-iso646-character-unification-alist))
+ (while rest
+ (let ((pair (car rest)))
+ (goto-char (point-min))
+ (while (search-forward (car pair) nil t)
+ (let ((str (cdr pair)))
+ (put-text-property 0 (length str)
+ 'face mime-unified-character-face str)
+ (replace-match str 'fixed-case 'literal)
+ )
+ ))
+ (setq rest (cdr rest)))))
+ ))
+
+(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)))
+
+(defsubst encode-mime-charset-string (string charset)
+ "Encode the STRING as MIME CHARSET."
+ (let ((cs (mime-charset-to-coding-system charset)))
+ (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
+ '(((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)
+ ((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) . cn-gb-2312)
+ ((ascii chinese-big5-1 chinese-big5-2) . cn-big5)
+ ((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)
+ ))
+
+
+;;; @ end
+;;;
+
+(provide 'mcs-xm)
+
+;;; mcs-xm.el ends here
--- /dev/null
+;;; pccl-20.el --- Portable CCL utility for Emacs 20 and XEmacs-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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poem)
+
+(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
+
+ (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.
+\[Emacs 20.3 emulating function]"
+ (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.
+\[Emacs 20.3 emulating function]"
+ (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."
+ (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."
+ (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."
+ (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."
+ (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
+;;;
+
+(provide 'pccl-20)
+
+;;; pccl-20.el ends here
--- /dev/null
+;;; pccl-om.el --- Portable CCL utility for Mule 1.* and Mule 2.*
+
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998 Tanaka Akira
+
+;; Author: Tanaka Akira <akr@jaist.ac.jp>
+;; Shuhei KOBAYASHI <shuhei-k@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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poem)
+
+(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.
+\[Emacs 20.3 emulating function]"
+ (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.
+\[Emacs 20.3 emulating function]"
+ (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 (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."
+ (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."
+ (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."
+ (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
+;;;
+
+(provide 'pccl-om)
+
+;;; pccl-om.el ends here
--- /dev/null
+;;; pccl.el --- Portable CCL utility for Mule 1.* and 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(if (featurep 'mule)
+ (if (>= emacs-major-version 20)
+ ;; for Emacs 20 and XEmacs-mule
+ (require 'pccl-20)
+ ;; for MULE 1.* and 2.*
+ (require 'pccl-om)
+ ))
+
+
+;;; @ end
+;;;
+
+(provide 'pccl)
+
+;;; pccl.el ends here
--- /dev/null
+;;; poe-18.el --- poe API implementation for Emacs 18.*
+
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(autoload '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)
+
+(defvar data-directory exec-directory)
+
+
+;;; @ for EMACS 18.55
+;;;
+
+(defvar buffer-undo-list nil)
+
+
+;;; @ hook
+;;;
+
+;; These function are imported from EMACS 19.28.
+(defun add-hook (hook function &optional append)
+ "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.
+
+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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (or (boundp hook)
+ (set 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))
+ ))
+ (or (if (consp function)
+ ;; Clever way to tell whether a given lambda-expression
+ ;; is equal to anything in the hook.
+ (let ((tail (assoc (cdr function) (symbol-value hook))))
+ (equal function tail)
+ )
+ (memq function (symbol-value hook))
+ )
+ (set hook
+ (if append
+ (nconc (symbol-value hook) (list function))
+ (cons function (symbol-value hook))
+ ))
+ ))
+
+(defun remove-hook (hook function)
+ "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'.
+\[poe-18.el; EMACS 19 emulating function]"
+ (if (or (not (boundp hook)) ;unbound symbol, or
+ (null (symbol-value hook)) ;value is nil, or
+ (null function)) ;function is nil, then
+ nil ;Do nothing.
+ (let ((hook-value (symbol-value hook)))
+ (if (consp hook-value)
+ (setq hook-value (delete function hook-value))
+ (if (equal hook-value function)
+ (setq hook-value nil)
+ ))
+ (set hook hook-value)
+ )))
+
+
+;;; @ list
+;;;
+
+(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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (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'.
+\[poe-18.el; EMACS 19 emulating function]"
+ (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))
+ )
+ (rplacd rest (cdr rrest))
+ list)))
+
+
+;;; @ function
+;;;
+
+(defun defalias (sym newdef)
+ "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.
+Associates the function with the current load file, if any.
+\[poe-18.el; EMACS 19 emulating function]"
+ (fset sym newdef)
+ )
+
+(defun byte-code-function-p (exp)
+ "T if OBJECT is a byte-compiled function object.
+\[poe-18.el; EMACS 19 emulating function]"
+ (and (consp exp)
+ (let* ((rest (cdr (cdr exp))) 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))
+ ))
+ )))
+
+(defmacro-maybe defsubst (name arglist &rest body)
+ "Define an inline function. The syntax is just like that of `defun'."
+ (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."
+ (interactive "aMake function obsolete: \nxObsoletion replacement: ")
+ (let ((handler (get fn 'byte-compile)))
+ (if (eq 'byte-compile-obsolete handler)
+ (setcar (get fn 'byte-obsolete-info) new)
+ (put fn 'byte-obsolete-info (cons new handler))
+ (put fn 'byte-compile 'byte-compile-obsolete)))
+ fn)
+
+
+;;; @ file
+;;;
+
+(defun make-directory-internal (dirname)
+ "Create a directory. One argument, a file name string.
+\[poe-18.el; EMACS 19 emulating function]"
+ (if (file-exists-p dirname)
+ (error "Creating directory: %s is already exist" dirname)
+ (if (not (= (call-process "mkdir" nil nil nil dirname) 0))
+ (error "Creating directory: no such file or directory, %s" dirname)
+ )))
+
+(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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (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)
+ ))
+
+;; Imported from files.el of EMACS 19.33.
+(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)))
+
+;; Imported from files.el of 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)))))
+
+(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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (si:directory-files directory full match)
+ )
+
+
+;;; @ mark
+;;;
+
+(or (fboundp 'si:mark)
+ (fset 'si:mark (symbol-function 'mark)))
+(defun mark (&optional force)
+ (si:mark)
+ )
+
+
+;;; @ mode-line
+;;;
+
+;;; Imported from Emacs 19.30.
+(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.
+\[poe-18.el; Emacs 19 emulating function]"
+ (if all (save-excursion (set-buffer (other-buffer))))
+ (set-buffer-modified-p (buffer-modified-p)))
+
+
+;;; @ overlay
+;;;
+
+(cond ((boundp 'NEMACS)
+ (defvar emu:available-face-attribute-alist
+ '(
+ ;;(bold . inversed-region)
+ (italic . underlined-region)
+ (underline . underlined-region)
+ ))
+
+ ;; by YAMATE Keiichirou 1994/10/28
+ (defun attribute-add-narrow-attribute (attr from to)
+ (or (consp (symbol-value attr))
+ (set attr (list 1)))
+ (let* ((attr-value (symbol-value attr))
+ (len (car attr-value))
+ (posfrom 1)
+ posto)
+ (while (and (< posfrom len)
+ (> from (nth posfrom attr-value)))
+ (setq posfrom (1+ posfrom)))
+ (setq posto posfrom)
+ (while (and (< posto len)
+ (> to (nth posto attr-value)))
+ (setq posto (1+ posto)))
+ (if (= posto posfrom)
+ (if (= (% posto 2) 1)
+ (if (and (< to len)
+ (= to (nth posto attr-value)))
+ (set-marker (nth posto attr-value) from)
+ (setcdr (nthcdr (1- posfrom) attr-value)
+ (cons (set-marker-type (set-marker (make-marker)
+ from)
+ 'point-type)
+ (cons (set-marker-type
+ (set-marker (make-marker)
+ to)
+ nil)
+ (nthcdr posto attr-value))))
+ (setcar attr-value (+ len 2))))
+ (if (= (% posfrom 2) 0)
+ (setq posfrom (1- posfrom))
+ (set-marker (nth posfrom attr-value) from))
+ (if (= (% posto 2) 0)
+ nil
+ (setq posto (1- posto))
+ (set-marker (nth posto attr-value) to))
+ (setcdr (nthcdr posfrom attr-value)
+ (nthcdr posto attr-value)))))
+
+ (defalias 'make-overlay 'cons)
+
+ (defun overlay-put (overlay prop value)
+ (let ((ret (and (eq prop 'face)
+ (assq value emu:available-face-attribute-alist)
+ )))
+ (if ret
+ (attribute-add-narrow-attribute (cdr ret)
+ (car overlay)(cdr overlay))
+ )))
+ )
+ (t
+ (defun make-overlay (beg end &optional buffer type))
+ (defun overlay-put (overlay prop value))
+ ))
+
+(defun overlay-buffer (overlay))
+
+
+;;; @ text property
+;;;
+
+(defun set-text-properties (start end properties &optional object))
+
+(defun remove-text-properties (start end properties &optional object))
+
+
+;;; @@ visible/invisible
+;;;
+
+(defmacro enable-invisible ()
+ (`
+ (progn
+ (make-local-variable 'original-selective-display)
+ (setq original-selective-display selective-display)
+ (setq selective-display t)
+ )))
+
+(defmacro end-of-invisible ()
+ (` (setq selective-display
+ (if (boundp 'original-selective-display)
+ original-selective-display))
+ ))
+
+(defun invisible-region (start end)
+ (let ((buffer-read-only nil) ;Okay even if write protected.
+ (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 ?\^M t)
+ (set-buffer-modified-p modp)
+ )))
+
+(defun visible-region (start end)
+ (let ((buffer-read-only nil) ;Okay even if write protected.
+ (modp (buffer-modified-p)))
+ (unwind-protect
+ (subst-char-in-region start end ?\^M ?\n t)
+ (set-buffer-modified-p modp)
+ )))
+
+(defun invisible-p (pos)
+ (save-excursion
+ (goto-char pos)
+ (eq (following-char) ?\^M)
+ ))
+
+(defun next-visible-point (pos)
+ (save-excursion
+ (goto-char pos)
+ (end-of-line)
+ (if (eq (following-char) ?\n)
+ (forward-char)
+ )
+ (point)
+ ))
+
+
+;;; @ string
+;;;
+
+(defun char-list-to-string (char-list)
+ "Convert list of character CHAR-LIST to string. [poe-18.el]"
+ (mapconcat (function char-to-string) char-list "")
+ )
+
+
+;;; @ buffer
+;;;
+
+(defun-maybe 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))
+
+
+;;; @ end
+;;;
+
+(provide 'poe-18)
+
+;;; poe-18.el ends here
--- /dev/null
+;;; poe-19.el --- poe API implementation for Emacs 19.*
+
+;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+
+;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+;;; @ face
+;;;
+
+(defun-maybe find-face (face)
+ (car (memq face (face-list)))
+ )
+
+
+;;; @ visible/invisible
+;;;
+
+(defmacro enable-invisible ())
+
+(defmacro end-of-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)
+ (save-excursion
+ (goto-char (next-single-property-change pos 'invisible))
+ (if (eq (following-char) ?\n)
+ (forward-char)
+ )
+ (point)))
+
+
+;;; @ string
+;;;
+
+(defmacro char-list-to-string (char-list)
+ "Convert list of character CHAR-LIST to string."
+ (` (mapconcat (function char-to-string)
+ (, char-list)
+ "")))
+
+
+;;; @ end
+;;;
+
+(provide 'poe-19)
+
+;;; poe-19.el ends here
--- /dev/null
+;;; poe-xemacs.el --- poe API 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: 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., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Code:
+
+;;; @ face
+;;;
+
+(or (fboundp 'face-list)
+ (defalias '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 'overlay-put 'set-extent-property)
+ (defalias 'overlay-buffer 'extent-buffer)
+ (defun move-overlay (extent start end &optional buffer)
+ (set-extent-endpoints extent start end)
+ )
+ ))
+
+
+;;; @ visible/invisible
+;;;
+
+(defmacro enable-invisible ())
+
+(defmacro end-of-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))))
+
+
+;;; @ dired
+;;;
+
+(or (fboundp 'dired-other-frame)
+ (defun 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)))
+ )
+
+
+;;; @ string
+;;;
+
+(defmacro char-list-to-string (char-list)
+ "Convert list of character CHAR-LIST to string. [poe-xemacs.el]"
+ `(mapconcat #'char-to-string ,char-list ""))
+
+
+;;; @@ 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). [poe-xemacs.el]"
+ (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
+;;;
+
+(or (fboundp 'line-beginning-position)
+ (defalias 'line-beginning-position 'point-at-bol))
+
+(or (fboundp 'line-end-position)
+ (defalias 'line-end-position 'point-at-eol))
+
+
+;;; @ end
+;;;
+
+(provide 'poe-xemacs)
+
+;;; poe-xemacs.el ends here
--- /dev/null
+;;; poe.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 APEL (A Portable Emacs Library).
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(defmacro defun-maybe (name &rest everything-else)
+ (or (and (fboundp name)
+ (not (get name 'defun-maybe))
+ )
+ (` (or (fboundp (quote (, name)))
+ (progn
+ (defun (, name) (,@ everything-else))
+ (put (quote (, name)) 'defun-maybe t)
+ ))
+ )))
+
+(defmacro defsubst-maybe (name &rest everything-else)
+ (or (and (fboundp name)
+ (not (get name 'defsubst-maybe))
+ )
+ (` (or (fboundp (quote (, name)))
+ (progn
+ (defsubst (, name) (,@ everything-else))
+ (put (quote (, name)) 'defsubst-maybe t)
+ ))
+ )))
+
+(defmacro defmacro-maybe (name &rest everything-else)
+ (or (and (fboundp name)
+ (not (get name 'defmacro-maybe))
+ )
+ (` (or (fboundp (quote (, name)))
+ (progn
+ (defmacro (, name) (,@ everything-else))
+ (put (quote (, name)) 'defmacro-maybe t)
+ ))
+ )))
+
+(put 'defun-maybe 'lisp-indent-function 'defun)
+(put 'defsubst-maybe 'lisp-indent-function 'defun)
+(put 'defmacro-maybe 'lisp-indent-function 'defun)
+
+(defmacro defconst-maybe (name &rest everything-else)
+ (or (and (boundp name)
+ (not (get name 'defconst-maybe))
+ )
+ (` (or (boundp (quote (, name)))
+ (progn
+ (defconst (, name) (,@ everything-else))
+ (put (quote (, name)) 'defconst-maybe t)
+ ))
+ )))
+
+(defconst-maybe emacs-major-version (string-to-int emacs-version))
+(defconst-maybe emacs-minor-version
+ (string-to-int
+ (substring emacs-version
+ (string-match (format "%d\\." emacs-major-version)
+ emacs-version))))
+
+(cond ((featurep 'xemacs)
+ (require 'poe-xemacs)
+ )
+ ((string-match "XEmacs" emacs-version)
+ (provide 'xemacs)
+ (require 'poe-xemacs)
+ )
+ ((>= emacs-major-version 19)
+ (require 'poe-19)
+ )
+ (t
+ (require 'poe-18)
+ ))
+
+
+;;; @ Emacs 19 emulation
+;;;
+
+(defun-maybe minibuffer-prompt-width ()
+ "Return the display width of the minibuffer prompt."
+ (save-excursion
+ (set-buffer (window-buffer (minibuffer-window)))
+ (current-column)))
+
+
+;;; @ Emacs 19.29 emulation
+;;;
+
+(defvar path-separator ":"
+ "Character used to separate concatenated paths.")
+
+(defun-maybe buffer-substring-no-properties (start end)
+ "Return the characters of part of the buffer, without the text properties.
+The two arguments START and END are character positions;
+they can be in either order. [Emacs 19.29 emulating function]"
+ (let ((string (buffer-substring start end)))
+ (set-text-properties 0 (length string) nil string)
+ string))
+
+(defun-maybe match-string (num &optional string)
+ "Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING.
+\[Emacs 19.29 emulating function]"
+ (if (match-beginning num)
+ (if string
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num)))))
+
+(or (featurep 'xemacs)
+ (>= emacs-major-version 20)
+ (and (= emacs-major-version 19)
+ (>= emacs-minor-version 29))
+ ;; for Emacs 19.28 or earlier
+ (fboundp 'si:read-string)
+ (progn
+ (fset 'si:read-string (symbol-function 'read-string))
+
+ (defun read-string (prompt &optional initial-input history)
+ "Read a string from the minibuffer, prompting with string PROMPT.
+If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
+The third arg HISTORY, is dummy for compatibility. [emu.el]
+See `read-from-minibuffer' for details of HISTORY argument."
+ (si:read-string prompt initial-input))
+ ))
+
+
+;;; @ Emacs 19.30 emulation
+;;;
+
+;; This function was imported Emacs 19.30.
+(defun-maybe add-to-list (list-var element)
+ "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
+If you want to use `add-to-list' on a variable that is not defined
+until a certain package is loaded, you should put the call to `add-to-list'
+into a hook function that will be run only after loading the package.
+\[Emacs 19.30 emulating function]"
+ (or (member element (symbol-value list-var))
+ (set list-var (cons element (symbol-value list-var)))))
+
+(cond ((fboundp 'insert-file-contents-literally))
+ ((boundp 'file-name-handler-alist)
+ (defun insert-file-contents-literally
+ (filename &optional visit beg end replace)
+ "Like `insert-file-contents', q.v., but only reads in the file.
+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.
+\[Emacs 19.30 emulating function]"
+ (let (file-name-handler-alist)
+ (insert-file-contents filename visit beg end replace)))
+ )
+ (t
+ (defalias 'insert-file-contents-literally 'insert-file-contents)
+ ))
+
+
+;;; @ Emacs 19.31 emulation
+;;;
+
+(defun-maybe buffer-live-p (object)
+ "Return non-nil if OBJECT is a buffer which has not been killed.
+Value is nil if OBJECT is not a buffer or if it has been killed.
+\[Emacs 19.31 emulating function]"
+ (and object
+ (get-buffer object)
+ (buffer-name (get-buffer object))))
+
+;; This macro was imported Emacs 19.33.
+(defmacro-maybe save-selected-window (&rest body)
+ "Execute BODY, then select the window that was selected before BODY.
+\[Emacs 19.31 emulating function]"
+ (list 'let
+ '((save-selected-window-window (selected-window)))
+ (list 'unwind-protect
+ (cons 'progn body)
+ (list 'select-window 'save-selected-window-window))))
+
+
+;;; @ Emacs 20.1 emulation
+;;;
+
+;; This macro was imported Emacs 20.2.
+(defmacro-maybe when (cond &rest body)
+ "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
+ (list 'if cond (cons 'progn body)))
+
+;; This macro was imported Emacs 20.3.
+(defmacro-maybe unless (cond &rest body)
+ "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
+ (cons 'if (cons cond (cons nil body))))
+
+(defmacro-maybe save-current-buffer (&rest body)
+ "Save the current buffer; execute BODY; restore the current buffer.
+Executes BODY just like `progn'."
+ (` (let ((orig-buffer (current-buffer)))
+ (unwind-protect
+ (progn (,@ body))
+ (set-buffer orig-buffer)))))
+
+;; This macro was imported Emacs 20.2.
+(defmacro-maybe with-current-buffer (buffer &rest body)
+ "Execute the forms in BODY with BUFFER as the current buffer.
+The value returned is the value of the last form in BODY.
+See also `with-temp-buffer'."
+ (` (save-current-buffer
+ (set-buffer (, buffer))
+ (,@ body))))
+
+;; This macro was imported Emacs 20.2.
+(defmacro-maybe with-temp-file (file &rest forms)
+ "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
+The value of the last form in FORMS is returned, like `progn'.
+See also `with-temp-buffer'."
+ (let ((temp-file (make-symbol "temp-file"))
+ (temp-buffer (make-symbol "temp-buffer")))
+ (` (let (((, temp-file) (, file))
+ ((, temp-buffer)
+ (get-buffer-create (generate-new-buffer-name " *temp file*"))))
+ (unwind-protect
+ (prog1
+ (with-current-buffer (, temp-buffer)
+ (,@ forms))
+ (with-current-buffer (, temp-buffer)
+ (widen)
+ (write-region (point-min) (point-max) (, temp-file) nil 0)))
+ (and (buffer-name (, temp-buffer))
+ (kill-buffer (, temp-buffer))))))))
+
+;; This macro was imported Emacs 20.2.
+(defmacro-maybe with-temp-buffer (&rest forms)
+ "Create a temporary buffer, and evaluate FORMS there like `progn'.
+See also `with-temp-file' and `with-output-to-string'."
+ (let ((temp-buffer (make-symbol "temp-buffer")))
+ (` (let (((, temp-buffer)
+ (get-buffer-create (generate-new-buffer-name " *temp*"))))
+ (unwind-protect
+ (with-current-buffer (, temp-buffer)
+ (,@ forms))
+ (and (buffer-name (, temp-buffer))
+ (kill-buffer (, temp-buffer))))))))
+
+;; This function was imported Emacs 20.3.
+(defun-maybe last (x &optional n)
+ "Return the last link of the list X. Its car is the last element.
+If X is nil, return nil.
+If N is non-nil, return the Nth-to-last link of X.
+If N is bigger than the length of X, return X."
+ (if n
+ (let ((m 0) (p x))
+ (while (consp p)
+ (setq m (1+ m) p (cdr p)))
+ (if (<= n 0) p
+ (if (< n m) (nthcdr (- m n) x) x)))
+ (while (cdr x)
+ (setq x (cdr x)))
+ x))
+
+;; This function was imported Emacs 20.3. (cl function)
+(defun-maybe butlast (x &optional n)
+ "Returns a copy of LIST with the last N elements removed."
+ (if (and n (<= n 0)) x
+ (nbutlast (copy-sequence x) n)))
+
+;; This function was imported Emacs 20.3. (cl function)
+(defun-maybe nbutlast (x &optional n)
+ "Modifies LIST to remove the last N elements."
+ (let ((m (length x)))
+ (or n (setq n 1))
+ (and (< n m)
+ (progn
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+ x))))
+
+;; This function was imported from XEmacs 21.
+(defun-maybe split-string (string &optional pattern)
+ "Return a list of substrings of STRING which are separated by PATTERN.
+If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
+ (or pattern
+ (setq pattern "[ \f\t\n\r\v]+"))
+ ;; The FSF version of this function takes care not to cons in case
+ ;; of infloop. Maybe we should synch?
+ (let (parts (start 0))
+ (while (string-match pattern string start)
+ (setq parts (cons (substring string start (match-beginning 0)) parts)
+ start (match-end 0)))
+ (nreverse (cons (substring string start) parts))))
+
+
+;;; @ Emacs 20.3 emulation
+;;;
+
+(defun-maybe line-beginning-position (&optional n)
+ "Return the character position of the first character on the current line.
+With argument N not nil or 1, move forward N - 1 lines first.
+If scan reaches end of buffer, return that position.
+This function does not move point."
+ (save-excursion
+ (if n
+ (forward-line (1- n))
+ )
+ (beginning-of-line)
+ (point)))
+
+(defun-maybe line-end-position (&optional n)
+ "Return the character position of the last character on the current line.
+With argument N not nil or 1, move forward N - 1 lines first.
+If scan reaches end of buffer, return that position.
+This function does not move point."
+ (save-excursion
+ (if n
+ (forward-line (1- n))
+ )
+ (end-of-line)
+ (point)))
+
+
+;;; @ XEmacs emulation
+;;;
+
+(defun-maybe point-at-bol (&optional n buffer)
+ "Return the character position of the first character on the current line.
+With argument N not nil or 1, move forward N - 1 lines first.
+If scan reaches end of buffer, return that position.
+This function does not move point. [XEmacs emulating function]"
+ (save-excursion
+ (if buffer
+ (set-buffer buffer)
+ )
+ (line-beginning-position n)
+ ))
+
+(defun-maybe point-at-eol (&optional n buffer)
+ "Return the character position of the last character on the current line.
+With argument N not nil or 1, move forward N - 1 lines first.
+If scan reaches end of buffer, return that position.
+This function does not move point. [XEmacs emulating function]"
+ (save-excursion
+ (if buffer
+ (set-buffer buffer)
+ )
+ (line-end-position n)
+ ))
+
+(defun-maybe functionp (obj)
+ "Returns t if OBJ is a function, nil otherwise.
+\[XEmacs emulating function]"
+ (or (subrp obj)
+ (byte-code-function-p obj)
+ (and (symbolp obj)(fboundp obj))
+ (and (consp obj)(eq (car obj) 'lambda))
+ ))
+
+
+;;; @ end
+;;;
+
+(provide 'poe)
+
+;;; poe.el ends here
--- /dev/null
+;;; poem-20.el --- poem implementation for Emacs 20 and XEmacs-mule
+
+;; Copyright (C) 1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule)
+;; or later.
+
+;;; Code:
+
+;;; @ 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))
+ (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 ((coding-system-for-read 'binary)
+ 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 (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 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)))
+
+
+;;; @ end
+;;;
+
+(provide 'poem-20)
+
+;;; poem-20.el ends here
--- /dev/null
+;;; poem-e20.el --- poem implementation for XEmacs-mule
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, 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))))
+
+
+;;; @ coding system
+;;;
+
+(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 'poem-20)
+
+(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
+ )
+
+(provide 'poem-e20)
+
+;;; poem-e20.el ends here
--- /dev/null
+;;; poem-e20_2.el --- poem implementation for Emacs 20.1 and 20.2
+
+;; Copyright (C) 1996,1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, 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)
+
+
+;;; @ 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))))
+
+
+;;; @ end
+;;;
+
+(provide 'poem-e20_2)
+
+;;; poem-e20_2.el ends here
--- /dev/null
+;;; poem-e20_3.el --- poem implementation for Emacs 20.3.
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module requires Emacs 20.2.91 or later.
+
+;;; Code:
+
+;;; @ 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))
+
+
+;;; @ 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
+;;;
+
+(provide 'poem-e20_3)
+
+;;; poem-e20_3.el ends here
--- /dev/null
+;;; poem-ltn1.el --- poem implementation for Emacs 19 and XEmacs without MULE
+
+;; Copyright (C) 1995,1996,1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; 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 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)
+
+
+;;; @ coding-system
+;;;
+
+(defun decode-coding-string (string coding-system)
+ "Decode the STRING which is encoded in CODING-SYSTEM."
+ string)
+
+(defun encode-coding-string (string coding-system)
+ "Encode the STRING as CODING-SYSTEM."
+ 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)
+
+
+;;; @ character
+;;;
+
+(defun char-charset (char)
+ "Return the character set of char CHAR."
+ (if (< chr 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))
+ (substring str start-column width))
+
+(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
+;;;
+
+(provide 'poem-ltn1)
+
+;;; poem-ltn1.el ends here
--- /dev/null
+;;; poem-nemacs.el --- poem implementation for Nemacs
+
+;; Copyright (C) 1995,1996,1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, 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)
+
+
+;;; @ 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)
+ (,@ 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 beg end replace)))
+
+(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.
+\[emu-nemacs.el]"
+ (as-binary-input-file
+ ;; Returns list 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 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))))
+
+
+;;; @ 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."
+ (` (+ (, 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-columns 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-columns 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
+;;;
+
+(provide 'poem-nemacs)
+
+;;; poem-nemacs.el ends here
--- /dev/null
+;;; poem-om.el --- poem implementation for Mule 1.* and Mule 2.*
+
+;; Copyright (C) 1995,1996,1997,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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poe)
+
+
+;;; @ version specific features
+;;;
+
+(cond ((= 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))
+
+
+;;; @ coding system
+;;;
+
+(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)
+
+
+;;; @ without code-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)
+
+(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)))
+
+(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."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point)(point))
+ (let ((return-val
+ ;; Returns list absolute file name and length of data inserted.
+ (insert-file-contents-as-binary filename visit beg end replace)))
+ (goto-char (point-min))
+ (while (re-search-forward "\r$" nil t)
+ (replace-match ""))
+ (list (car return-val) (buffer-size))))))
+
+(defun 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)))
+
+(cond
+ (running-emacs-19_29-or-later
+ ;; for MULE 2.3 based on Emacs 19.34.
+ (defun write-region-as-binary (start end filename
+ &optional append visit lockname)
+ "Like `write-region', q.v., but don't code conversion."
+ (as-binary-output-file
+ (write-region 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."
+ (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 lockname))))
+ )
+ (t
+ ;; for MULE 2.3 based on Emacs 19.28.
+ (defun write-region-as-binary (start end filename
+ &optional append visit lockname)
+ "Like `write-region', q.v., but don't code conversion."
+ (as-binary-output-file
+ (write-region start end filename append visit)))
+
+ (defun write-region-as-raw-text-CRLF (start end filename
+ &optional append visit lockname)
+ "Like `write-region', q.v., but don't code conversion."
+ (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))))
+ ))
+
+
+;;; @ 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)
+
+(or (fboundp 'truncate-string)
+ ;; 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)
+
+
+;;; @ end
+;;;
+
+(provide 'poem-om)
+
+;;; poem-om.el ends here
--- /dev/null
+;;; poem-xm.el --- poem implementation for XEmacs-mule
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poem-20)
+
+
+;;; @ 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))
+
+;; 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))
+
+(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 '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)))
+
+
+;;; @ 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 (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))
+
+
+;;; @ string
+;;;
+
+(defun string-to-int-list (str)
+ (mapcar #'char-int str))
+
+(defalias 'looking-at-as-unibyte 'looking-at)
+
+
+;;; @ end
+;;;
+
+(provide 'poem-xm)
+
+;;; poem-xm.el ends here
--- /dev/null
+;;; poem.el --- Portable Outfit for Emacsen: about MULE API
+
+;; 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(require 'poe)
+
+(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
+;;;
+
+(defmacro-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)
+
+(defmacro-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)
+
+
+;;; @ XEmacs 20 emulation
+;;;
+
+(or (fboundp 'char-int)
+ (fset 'char-int (symbol-function 'identity)))
+
+(or (fboundp 'int-char)
+ (fset 'int-char (symbol-function 'identity)))
+
+(or (fboundp 'char-or-char-int-p)
+ (fset 'char-or-char-int-p (symbol-function 'integerp)))
+
+
+;;; @ end
+;;;
+
+(provide 'poem)
+
+;;; poem.el ends here
projects / elisp / apel.git / commitdiff