From: morioka Date: Mon, 21 Sep 1998 16:29:01 +0000 (+0000) Subject: Merge poe. X-Git-Tag: apel-9_0~8 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=0df64d3b6ef5ae5212fd59ee13dd5f044b378ba6;p=elisp%2Fapel.git Merge poe. --- diff --git a/ChangeLog b/ChangeLog index df48025..a3f8209 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,278 @@ +1998-09-20 MORIOKA Tomohiko + + * mcs-xm.el (charsets-mime-charset-alist): Comment out invalid + definition for iso-2022-int-1. + +1998-09-19 Tanaka Akira + + * 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 + + * pccl.el (apel-broken-facility): New function. + (apel-broken-p): New function. + +1998-09-18 Tanaka Akira + + * pccl.el: Fix author. + +1998-09-17 Katsumi Yamaoka + + * pccl-om.el (make-ccl-coding-system): Enclose with + `eval-and-compile'. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * 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 + + * EMU-ELS: New implementation. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * mcharset.el, emu.el: Move function `charsets-to-mime-charset' + from emu.el to mcharset.el. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * poe-18.el (make-obsolete): New function. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * emu.el, emu-20.el: Move constant `*noconv*' from emu-20.el to + emu.el. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * poe.el, emu.el: Move function `point-at-bol' and `point-at-eol' + from emu.el to poe.el. + +1998-09-17 MORIOKA Tomohiko + + * emu.el (point-at-bol): New function. + (point-at-eol): Use `line-end-position'. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * poe.el, emu.el: Move function `functionp' from emu.el to poe.el. + +1998-09-17 MORIOKA Tomohiko + + * 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 + + * 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 + + * 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 * emu-x20.el (make-ccl-coding-system): New function. diff --git a/EMU-ELS b/EMU-ELS index 17d9275..b021714 100644 --- a/EMU-ELS +++ b/EMU-ELS @@ -4,49 +4,69 @@ ;;; 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 diff --git a/Makefile b/Makefile index b7294c3..db7f739 100644 --- a/Makefile +++ b/Makefile @@ -18,7 +18,6 @@ PACKAGEDIR = NONE elc: - -rm emu*.elc $(EMACS) $(FLAGS) -f compile-apel install: diff --git a/broken.el b/broken.el new file mode 100644 index 0000000..553f6bd --- /dev/null +++ b/broken.el @@ -0,0 +1,89 @@ +;;; broken.el --- Emacs broken facility infomation registry. + +;; Copyright (C) 1998 Tanaka Akira + +;; Author: Tanaka Akira +;; 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 diff --git a/emu-18.el b/emu-18.el deleted file mode 100644 index 8ee121a..0000000 --- a/emu-18.el +++ /dev/null @@ -1,385 +0,0 @@ -;;; emu-18.el --- emu API implementation for Emacs 18.* - -;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; 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 `', 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 diff --git a/emu-20.el b/emu-20.el deleted file mode 100644 index b750e41..0000000 --- a/emu-20.el +++ /dev/null @@ -1,213 +0,0 @@ -;;; emu-20.el --- emu API implementation for Emacs 20 and XEmacs/mule - -;; Copyright (C) 1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; 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 diff --git a/emu-e19.el b/emu-e19.el deleted file mode 100644 index 66ca0b6..0000000 --- a/emu-e19.el +++ /dev/null @@ -1,104 +0,0 @@ -;;; emu-e19.el --- emu API implementation for Emacs 19.* - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; 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 diff --git a/emu-e20.el b/emu-e20.el deleted file mode 100644 index fe6659f..0000000 --- a/emu-e20.el +++ /dev/null @@ -1,284 +0,0 @@ -;;; 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 -;; 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 diff --git a/emu-e20_2.el b/emu-e20_2.el deleted file mode 100644 index d13f24c..0000000 --- a/emu-e20_2.el +++ /dev/null @@ -1,129 +0,0 @@ -;;; 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 -;; 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 diff --git a/emu-e20_3.el b/emu-e20_3.el deleted file mode 100644 index 15aec7e..0000000 --- a/emu-e20_3.el +++ /dev/null @@ -1,62 +0,0 @@ -;;; emu-e20_3.el --- emu API implementation for Emacs 20.3. - -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; 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 diff --git a/emu-latin1.el b/emu-latin1.el deleted file mode 100644 index 31fa9e2..0000000 --- a/emu-latin1.el +++ /dev/null @@ -1,313 +0,0 @@ -;;; 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 -;; 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 diff --git a/emu-mule.el b/emu-mule.el index 8c4eb6c..62cb5ce 100644 --- a/emu-mule.el +++ b/emu-mule.el @@ -25,468 +25,7 @@ ;;; Code: -;;; @ version specific features -;;; - -(cond (running-emacs-19 - (require 'emu-e19) - - ;; Suggested by SASAKI Osamu - ;; (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 @@ -513,74 +52,6 @@ Optional non-nil arg START-COLUMN specifies the starting column. 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 ;;; diff --git a/emu-nemacs.el b/emu-nemacs.el deleted file mode 100644 index 3b69644..0000000 --- a/emu-nemacs.el +++ /dev/null @@ -1,515 +0,0 @@ -;;; emu-nemacs.el --- emu API implementation for NEmacs - -;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; 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 diff --git a/emu-x20.el b/emu-x20.el deleted file mode 100644 index 48154f7..0000000 --- a/emu-x20.el +++ /dev/null @@ -1,331 +0,0 @@ -;;; emu-x20.el --- emu API implementation for XEmacs with mule - -;; Copyright (C) 1994,1995,1996,1997,1998 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; 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 diff --git a/emu-xemacs.el b/emu-xemacs.el deleted file mode 100644 index 7815219..0000000 --- a/emu-xemacs.el +++ /dev/null @@ -1,154 +0,0 @@ -;;; 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 -;; 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 diff --git a/emu.el b/emu.el index 2b07a12..8dc9928 100644 --- a/emu.el +++ b/emu.el @@ -24,64 +24,10 @@ ;;; 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))) @@ -102,326 +48,151 @@ (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 diff --git a/install.el b/install.el index 4995610..f5a0d4e 100644 --- a/install.el +++ b/install.el @@ -163,13 +163,12 @@ (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 diff --git a/mcharset.el b/mcharset.el new file mode 100644 index 0000000..5ce2108 --- /dev/null +++ b/mcharset.el @@ -0,0 +1,79 @@ +;;; mcharset.el --- MIME charset API + +;; Copyright (C) 1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/mcs-20.el b/mcs-20.el new file mode 100644 index 0000000..55faf50 --- /dev/null +++ b/mcs-20.el @@ -0,0 +1,149 @@ +;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule + +;; Copyright (C) 1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/mcs-e20.el b/mcs-e20.el new file mode 100644 index 0000000..c452f15 --- /dev/null +++ b/mcs-e20.el @@ -0,0 +1,112 @@ +;;; 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 +;; 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 diff --git a/mcs-ltn1.el b/mcs-ltn1.el new file mode 100644 index 0000000..2fed09a --- /dev/null +++ b/mcs-ltn1.el @@ -0,0 +1,86 @@ +;;; mcs-ltn1.el --- MIME charset implementation for Emacs 19 +;;; and XEmacs without MULE + +;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/mcs-nemacs.el b/mcs-nemacs.el new file mode 100644 index 0000000..c32fd6f --- /dev/null +++ b/mcs-nemacs.el @@ -0,0 +1,113 @@ +;;; mcs-nemacs.el --- MIME charset implementation for Nemacs + +;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/mcs-om.el b/mcs-om.el new file mode 100644 index 0000000..433262d --- /dev/null +++ b/mcs-om.el @@ -0,0 +1,203 @@ +;;; mcs-om.el --- MIME charset implementation for Mule 1.* and Mule 2.* + +;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/mcs-xm.el b/mcs-xm.el new file mode 100644 index 0000000..946cc7d --- /dev/null +++ b/mcs-xm.el @@ -0,0 +1,193 @@ +;;; mcs-xm.el --- MIME charset implementation for XEmacs-mule + +;; Copyright (C) 1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/pccl-20.el b/pccl-20.el new file mode 100644 index 0000000..18cade1 --- /dev/null +++ b/pccl-20.el @@ -0,0 +1,158 @@ +;;; 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 +;; 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 diff --git a/pccl-om.el b/pccl-om.el new file mode 100644 index 0000000..40e2080 --- /dev/null +++ b/pccl-om.el @@ -0,0 +1,123 @@ +;;; 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 +;; Shuhei KOBAYASHI +;; 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 diff --git a/pccl.el b/pccl.el new file mode 100644 index 0000000..eca8323 --- /dev/null +++ b/pccl.el @@ -0,0 +1,41 @@ +;;; pccl.el --- Portable CCL utility for Mule 1.* and Mule 2.* + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poe-18.el b/poe-18.el new file mode 100644 index 0000000..4c4a830 --- /dev/null +++ b/poe-18.el @@ -0,0 +1,454 @@ +;;; poe-18.el --- poe API implementation for Emacs 18.* + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 `', 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 diff --git a/poe-19.el b/poe-19.el new file mode 100644 index 0000000..62995e6 --- /dev/null +++ b/poe-19.el @@ -0,0 +1,84 @@ +;;; poe-19.el --- poe API implementation for Emacs 19.* + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poe-xemacs.el b/poe-xemacs.el new file mode 100644 index 0000000..475dccc --- /dev/null +++ b/poe-xemacs.el @@ -0,0 +1,152 @@ +;;; 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 +;; 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 diff --git a/poe.el b/poe.el new file mode 100644 index 0000000..90b9d66 --- /dev/null +++ b/poe.el @@ -0,0 +1,384 @@ +;;; poe.el --- Emulation module for each Emacs variants + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poem-20.el b/poem-20.el new file mode 100644 index 0000000..33acef7 --- /dev/null +++ b/poem-20.el @@ -0,0 +1,92 @@ +;;; poem-20.el --- poem implementation for Emacs 20 and XEmacs-mule + +;; Copyright (C) 1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poem-e20.el b/poem-e20.el new file mode 100644 index 0000000..32aac21 --- /dev/null +++ b/poem-e20.el @@ -0,0 +1,77 @@ +;;; poem-e20.el --- poem implementation for XEmacs-mule + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poem-e20_2.el b/poem-e20_2.el new file mode 100644 index 0000000..908a20e --- /dev/null +++ b/poem-e20_2.el @@ -0,0 +1,129 @@ +;;; 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 +;; 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 diff --git a/poem-e20_3.el b/poem-e20_3.el new file mode 100644 index 0000000..4c3b1e2 --- /dev/null +++ b/poem-e20_3.el @@ -0,0 +1,62 @@ +;;; poem-e20_3.el --- poem implementation for Emacs 20.3. + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poem-ltn1.el b/poem-ltn1.el new file mode 100644 index 0000000..e209974 --- /dev/null +++ b/poem-ltn1.el @@ -0,0 +1,223 @@ +;;; 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 +;; 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 diff --git a/poem-nemacs.el b/poem-nemacs.el new file mode 100644 index 0000000..6738d19 --- /dev/null +++ b/poem-nemacs.el @@ -0,0 +1,343 @@ +;;; poem-nemacs.el --- poem implementation for Nemacs + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poem-om.el b/poem-om.el new file mode 100644 index 0000000..5579e09 --- /dev/null +++ b/poem-om.el @@ -0,0 +1,317 @@ +;;; poem-om.el --- poem implementation for Mule 1.* and Mule 2.* + +;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 + ;; (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 diff --git a/poem-xm.el b/poem-xm.el new file mode 100644 index 0000000..1ce5eec --- /dev/null +++ b/poem-xm.el @@ -0,0 +1,128 @@ +;;; poem-xm.el --- poem implementation for XEmacs-mule + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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 diff --git a/poem.el b/poem.el new file mode 100644 index 0000000..01dad14 --- /dev/null +++ b/poem.el @@ -0,0 +1,84 @@ +;;; poem.el --- Portable Outfit for Emacsen: about MULE API + +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: MORIOKA Tomohiko +;; 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