From e47c19a9f98b560818385fb4fd7dca6b14f36767 Mon Sep 17 00:00:00 2001 From: morioka Date: Sat, 27 Feb 1999 05:50:43 +0000 Subject: [PATCH] Merge apel-mcs-2-9_12_2. --- APEL-MK | 70 +++++++++++++++++++++++----------- ChangeLog | 117 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- Makefile | 5 ++- README.en | 2 +- README.ja | 2 +- install.el | 78 +++++++++++++++++++++----------------- mcharset.el | 37 +++++++++--------- mcs-20.el | 73 ++++++++++++++++++++++++++--------- mcs-e20.el | 89 ++++++++++++++++++++++++++++--------------- mcs-ltn1.el | 51 ++++++++++++++++++------- mcs-nemacs.el | 36 ++++++++++++------ mcs-om.el | 81 ++++++++++++++++++++++++++++----------- mcs-xm.el | 18 ++++----- pccl-20.el | 8 ++-- pccl.el | 12 +++--- 15 files changed, 484 insertions(+), 195 deletions(-) diff --git a/APEL-MK b/APEL-MK index 09ea4c2..4942f76 100644 --- a/APEL-MK +++ b/APEL-MK @@ -4,6 +4,14 @@ ;;; Code: +(defun install-just-print-p () + (let ((flag (getenv "MAKEFLAGS")) + case-fold-search) + (princ (format "%s\n" flag)) + (if flag + (string-match "^\\(\\(--[^ ]+ \\)+-\\|[^ =-]\\)*n" flag) + ))) + (defun config-apel () (let (prefix lisp-dir version-specific-lisp-dir) (and (setq prefix (car command-line-args-left)) @@ -41,9 +49,10 @@ (defun install-apel () (compile-apel) - (install-elisp-modules emu-modules "." EMU_DIR) - (install-elisp-modules apel-modules "." APEL_DIR) - ) + (let ((just-print (install-just-print-p))) + (install-elisp-modules emu-modules "." EMU_DIR just-print) + (install-elisp-modules apel-modules "." APEL_DIR just-print) + )) (defun config-apel-package () (let (package-dir) @@ -62,25 +71,44 @@ (config-apel-package) (load "EMU-ELS") - (compile-elisp-modules emu-modules ".") - (compile-elisp-modules apel-modules ".") - - (let ((dir (expand-file-name APEL_PREFIX - (expand-file-name "lisp" - PACKAGEDIR)))) - (install-elisp-modules emu-modules "." dir) - (install-elisp-modules apel-modules "." dir) + (let ((just-print (install-just-print-p))) + (compile-elisp-modules emu-modules ".") + (compile-elisp-modules apel-modules ".") - (setq autoload-package-name "apel") - (add-to-list 'command-line-args-left dir) - (batch-update-directory) - - (add-to-list 'command-line-args-left dir) - (Custom-make-dependencies) - - (byte-compile-file (expand-file-name "auto-autoloads.el" dir)) - (byte-compile-file (expand-file-name "custom-load.el" dir)) - )) + (let ((dir (expand-file-name APEL_PREFIX + (expand-file-name "lisp" + PACKAGEDIR)))) + (install-elisp-modules emu-modules "." dir just-print) + (install-elisp-modules apel-modules "." dir just-print) + + (if just-print + (progn + (princ (format "Updating autoloads in directory %s..\n\n" dir)) + + (princ (format "Processing %s\n" dir)) + (princ "Generating custom-load.el...\n\n") + + (princ (format "Compiling %s...\n" + (expand-file-name "auto-autoloads.el" dir))) + (princ (format "Wrote %s\n" + (expand-file-name "auto-autoloads.elc" dir))) + + (princ (format "Compiling %s...\n" + (expand-file-name "custom-load.el" dir))) + (princ (format "Wrote %s\n" + (expand-file-name "custom-load.elc" dir))) + ) + (setq autoload-package-name "apel") + (add-to-list 'command-line-args-left dir) + (batch-update-directory) + + (add-to-list 'command-line-args-left dir) + (Custom-make-dependencies) + + (byte-compile-file (expand-file-name "auto-autoloads.el" dir)) + (byte-compile-file (expand-file-name "custom-load.el" dir)) + ) + ))) (defun what-where-apel () (config-apel) diff --git a/ChangeLog b/ChangeLog index e5a0db7..f810b27 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,118 @@ +1999-02-26 MORIOKA Tomohiko + + * APEL-MK (install-just-print-p): Modify for special option of GNU + make. + +1999-02-26 MORIOKA Tomohiko + + * APEL-MK (install-just-print-p): New function. + (install-apel): Use `install-just-print-p'. + (install-apel-package): Likewise. + +1999-02-25 MORIOKA Tomohiko + + * Makefile (install): Add voodoo comment `# $(MAKE)'. + (install-package): Likewise. + + * APEL-MK (install-apel): Run installer with `just-print' mode if + environment variable "MAKEFLAGS" matches "^[^ =]*n" option. + (install-apel-package): Likewise. + +1999-02-21 Mikio Nakajima + + * install.el (install-file): New optional argument JUST-PRINT. + (install-files): Likewise. + (install-elisp-module): Likewise. + (install-elisp-modules): Likewise. + +1999-02-18 Keiichi Suzuki + + * mcs-e20.el (coding-system-get): New function. + (mime-charset-list): Fix for Emacs 20.2. + +1999-02-14 Katsumi Yamaoka + + * mcs-om.el (default-mime-charset-for-write): Delete the remaining + arguments for `defcustom'. + +1999-02-13 Tanaka Akira + + * mcs-e20.el (charsets-mime-charset-alist): Don't set up + `iso-2022-int-1' in default. + +1999-02-11 Tanaka Akira + + * README.en, README.ja, pccl.el: pccl does not support Mule 1.x. + + * pccl-20.el: Update broken facility message with Emacs version + it fixes. + +1999-02-07 MORIOKA Tomohiko + + * install.el (install-prefix): Modify for Meadow. + +1999-01-26 MORIOKA Tomohiko + + * mcs-20.el (mime-charset-to-coding-system-default-method): New + user option. + (mime-charset-to-coding-system): Call + `mime-charset-to-coding-system-default-method' if suitable + coding-system is not found. + +1999-01-21 Keiichi Suzuki + + * mcs-xm.el (encode-mime-charset-region): Add new optional + argument `lbt'. + (encode-mime-charset-string): Ditto. + + * mcs-nemacs.el (lbt-to-string): New inline function. + (encode-mime-charset-region): Add new optional argument `lbt'. + (encode-mime-charset-string): Ditto. + + * mcs-ltn1.el (lbt-to-string): New inline function. + (encode-mime-charset-region): Add new optional argument `lbt'. + (encode-mime-charset-string): Ditto. + (decode-mime-charset-region): Use `lbt-to-string'. + + * mcs-e20.el (encode-mime-charset-region): Add new optional + argument `lbt'. + (encode-mime-charset-string): Ditto. + + * mcs-om.el (lbt-to-string): New inline function. + (encode-mime-charset-region): Add new optional argument `lbt'. + (encode-mime-charset-string): Ditto. + (decode-mime-charset-region): Use `lbt-to-string'. + (decode-mime-charset-string): Ditto. + +1998-12-24 MORIOKA Tomohiko + + * mcs-om.el (default-mime-charset-for-write): New variable. + (detect-mime-charset-region): Return + `default-mime-charset-for-write' if suitable mime-charset is not + found. + + * mcs-20.el (detect-mime-charset-region): Don't call + `default-mime-charset-detect-method-for-write' if suitable + mime-charset is found. + + * mcharset.el (charsets-to-mime-charset): Return nil if suitable + mime-charset is not found; abolish optional argument `default'. + +1998-12-23 MORIOKA Tomohiko + + * mcs-xm.el (charsets-mime-charset-alist): Don't set up + `iso-2022-int-1' in default. + + * mcs-20.el (default-mime-charset-for-write): New user option. + (default-mime-charset-detect-method-for-write): New user option. + (detect-mime-charset-region): Refer + `default-mime-charset-detect-method-for-write' or + `default-mime-charset-for-write' if suitable mime-charset is not + found. + + * mcharset.el (charsets-to-mime-charset): Add new optional + argument `default'. + 1999-02-26 Katsumi Yamaoka * poem-nemacs.el (find-file-noselect-as-coding-system): Bind @@ -1299,7 +1414,7 @@ 1998-04-27 MORIOKA Tomohiko * calist.el (ctree-find-calist): Renamed from - 'ctree-match-calist-all. + 'ctree-match-calist-all. 1998-04-25 MORIOKA Tomohiko diff --git a/Makefile b/Makefile index 61bef7a..0922973 100644 --- a/Makefile +++ b/Makefile @@ -23,11 +23,12 @@ elc: install: $(EMACS) $(FLAGS) -f install-apel $(PREFIX) $(LISPDIR) \ - $(VERSION_SPECIFIC_LISPDIR) + $(VERSION_SPECIFIC_LISPDIR) # $(MAKE) install-package: - $(XEMACS) $(FLAGS) -f install-apel-package $(PACKAGEDIR) + $(XEMACS) $(FLAGS) -f install-apel-package $(PACKAGEDIR) \ + # $(MAKE) what-where: diff --git a/README.en b/README.en index cede2ed..c4447ea 100644 --- a/README.en +++ b/README.en @@ -38,7 +38,7 @@ What's APEL? broken.el --- provide information of broken facilities of Emacs. pccl.el --- utility to write portable CCL program - pccl-om.el --- for MULE 1.*, 2.* + pccl-om.el --- for MULE 2.* pccl-20.el --- for Emacs 20/XEmacs-21-MULE alist.el: utility for Association-list diff --git a/README.ja b/README.ja index 510557e..0fec542 100644 --- a/README.ja +++ b/README.ja @@ -38,7 +38,7 @@ APEL とは？ broken.el --- Emacs の壊れている機能の情報を提供する pccl.el --- 移植可能な CCL プログラムを書くためのユーティリティー - pccl-om.el --- MULE 1.*, 2.* 用 + pccl-om.el --- MULE 2.* 用 pccl-20.el --- Emacs 20/XEmacs-21-MULE 用 alist.el: 連想リストのためのユーティリティー diff --git a/install.el b/install.el index c83d260..f2f131e 100644 --- a/install.el +++ b/install.el @@ -1,10 +1,9 @@ ;;; install.el --- Emacs Lisp package install utility -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996,1997,1998,1999 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1996/08/18 -;; Version: $Id: install.el,v 4.2 1997/11/06 15:52:08 morioka Exp $ ;; Keywords: install, byte-compile, directory detection ;; This file is part of APEL (A Portable Emacs Library). @@ -57,35 +56,37 @@ (defvar install-overwritten-file-modes (+ (* 64 6)(* 8 4) 4)) -(defun install-file (file src dest &optional move overwrite) - (let ((src-file (expand-file-name file src))) - (if (file-exists-p src-file) - (let ((full-path (expand-file-name file dest))) - (if (and (file-exists-p full-path) overwrite) - (delete-file full-path) - ) - (copy-file src-file full-path t t) - (if move - (catch 'tag - (while (and (file-exists-p src-file) - (file-writable-p src-file)) - (condition-case err - (progn - (delete-file src-file) - (throw 'tag nil) - ) - (error (princ (format "%s\n" (nth 1 err)))) - )))) - (princ (format "%s -> %s\n" file dest)) - )) - )) +(defun install-file (file src dest &optional move overwrite just-print) + (if just-print + (princ (format "%s -> %s\n" file dest)) + (let ((src-file (expand-file-name file src))) + (if (file-exists-p src-file) + (let ((full-path (expand-file-name file dest))) + (if (and (file-exists-p full-path) overwrite) + (delete-file full-path) + ) + (copy-file src-file full-path t t) + (if move + (catch 'tag + (while (and (file-exists-p src-file) + (file-writable-p src-file)) + (condition-case err + (progn + (delete-file src-file) + (throw 'tag nil) + ) + (error (princ (format "%s\n" (nth 1 err)))) + )))) + (princ (format "%s -> %s\n" file dest)) + )) + ))) -(defun install-files (files src dest &optional move overwrite) +(defun install-files (files src dest &optional move overwrite just-print) (or (file-exists-p dest) (make-directory dest t) ) (mapcar (function (lambda (file) - (install-file file src dest move overwrite) + (install-file file src dest move overwrite just-print) )) files)) @@ -93,23 +94,29 @@ ;;; @@ install Emacs Lisp files ;;; -(defun install-elisp-module (module src dest) +(defun install-elisp-module (module src dest &optional just-print) (let (el-file elc-file) (let ((name (symbol-name module))) (setq el-file (concat name ".el")) (setq elc-file (concat name ".elc")) ) (let ((src-file (expand-file-name el-file src))) - (if (file-exists-p src-file) + (if (not (file-exists-p src-file)) + nil + (if just-print + (princ (format "%s -> %s\n" el-file dest)) (let ((full-path (expand-file-name el-file dest))) (if (file-exists-p full-path) - (delete-file full-path) + (delete-file full-path) ) (copy-file src-file full-path t t) (princ (format "%s -> %s\n" el-file dest)) - )) + ))) (setq src-file (expand-file-name elc-file src)) - (if (file-exists-p src-file) + (if (not (file-exists-p src-file)) + nil + (if just-print + (princ (format "%s -> %s\n" elc-file dest)) (let ((full-path (expand-file-name elc-file dest))) (if (file-exists-p full-path) (delete-file full-path) @@ -125,15 +132,15 @@ (error (princ (format "%s\n" (nth 1 err)))) ))) (princ (format "%s -> %s\n" elc-file dest)) - )) + ))) ))) -(defun install-elisp-modules (modules src dest) +(defun install-elisp-modules (modules src dest &optional just-print) (or (file-exists-p dest) (make-directory dest t) ) (mapcar (function (lambda (module) - (install-elisp-module module src dest) + (install-elisp-module module src dest just-print) )) modules)) @@ -142,7 +149,8 @@ ;;; (defvar install-prefix - (if (or running-emacs-18 running-xemacs) + (if (or running-emacs-18 running-xemacs + (string= system-configuration-options "NT")) ; for Meadow (expand-file-name "../../.." exec-directory) (expand-file-name "../../../.." data-directory) )) ; install to shared directory (maybe "/usr/local") diff --git a/mcharset.el b/mcharset.el index 5ce2108..3b02f6c 100644 --- a/mcharset.el +++ b/mcharset.el @@ -49,26 +49,25 @@ (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'." +Return nil if suitable mime-charset is not found." (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))) + (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))) + )))) ;;; @ end diff --git a/mcs-20.el b/mcs-20.el index e608ac3..4cc58d8 100644 --- a/mcs-20.el +++ b/mcs-20.el @@ -1,6 +1,6 @@ ;;; mcs-20.el --- MIME charset implementation for Emacs 20 and XEmacs/mule -;; Copyright (C) 1997,1998 Free Software Foundation, Inc. +;; Copyright (C) 1997,1998,1999 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Keywords: emulation, compatibility, Mule @@ -61,6 +61,14 @@ MIME CHARSET and CODING-SYSTEM must be symbol." :group 'i18n :type '(repeat (cons symbol coding-system))) +(defcustom mime-charset-to-coding-system-default-method + nil + "Function called when suitable coding-system is not found from MIME-charset. +It must be nil or function. +If it is a function, interface must be (CHARSET LBT CODING-SYSTEM)." + :group 'i18n + :type '(choice function (const nil))) + (defsubst mime-charset-to-coding-system (charset &optional lbt) "Return coding-system corresponding with CHARSET. CHARSET is a symbol whose name is MIME charset. @@ -69,20 +77,24 @@ 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 - )) + (let ((cs (assq charset mime-charset-coding-system-alist))) + (setq cs + (if cs + (cdr cs) + charset)) + (if lbt + (setq cs (intern (format "%s-%s" cs + (cond ((eq lbt 'CRLF) 'dos) + ((eq lbt 'LF) 'unix) + ((eq lbt 'CR) 'mac) + (t lbt))))) + ) + (if (find-coding-system cs) + cs + (if mime-charset-to-coding-system-default-method + (funcall mime-charset-to-coding-system-default-method + charset lbt cs) + )))) (defvar widget-mime-charset-prompt-value-history nil "History of input to `widget-mime-charset-prompt-value'.") @@ -123,9 +135,36 @@ It must be symbol." :group 'i18n :type 'mime-charset) -(defsubst detect-mime-charset-region (start end) +(defcustom default-mime-charset-for-write + (if (find-coding-system 'utf-8) + 'utf-8 + default-mime-charset) + "Default value of MIME-charset for encoding. +It may be used when suitable MIME-charset is not found. +It must be symbol." + :group 'i18n + :type 'mime-charset) + +(defcustom default-mime-charset-detect-method-for-write + nil + "Function called when suitable MIME-charset is not found to encode. +It must be nil or function. +If it is nil, variable `default-mime-charset-for-write' is used. +If it is a function, interface must be (TYPE CHARSETS &rest ARGS). +CHARSETS is list of charset. +If TYPE is 'region, ARGS has START and END." + :group 'i18n + :type '(choice function (const nil))) + +(defun detect-mime-charset-region (start end) "Return MIME charset for region between START and END." - (charsets-to-mime-charset (find-charset-region start end))) + (let ((charsets (find-charset-region start end))) + (or (charsets-to-mime-charset charsets) + (if default-mime-charset-detect-method-for-write + (funcall default-mime-charset-detect-method-for-write + 'region charsets start end) + default-mime-charset-for-write) + ))) (defun write-region-as-mime-charset (charset start end filename &optional append visit lockname) diff --git a/mcs-e20.el b/mcs-e20.el index f46d491..824582f 100644 --- a/mcs-e20.el +++ b/mcs-e20.el @@ -28,11 +28,11 @@ ;;; Code: -(defsubst encode-mime-charset-region (start end charset) +(defsubst encode-mime-charset-region (start end charset &optional lbt) "Encode the text between START and END as MIME CHARSET." (let (cs) (if (and enable-multibyte-characters - (setq cs (mime-charset-to-coding-system charset))) + (setq cs (mime-charset-to-coding-system charset lbt))) (encode-coding-region start end cs) ))) @@ -45,11 +45,11 @@ ))) -(defsubst encode-mime-charset-string (string charset) +(defsubst encode-mime-charset-string (string charset &optional lbt) "Encode the STRING as MIME CHARSET." (let (cs) (if (and enable-multibyte-characters - (setq cs (mime-charset-to-coding-system charset))) + (setq cs (mime-charset-to-coding-system charset lbt))) (encode-coding-string string cs) string))) @@ -85,45 +85,72 @@ 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) +; ((ascii latin-iso8859-1 greek-iso8859-7 +; latin-jisx0201 japanese-jisx0208-1978 +; chinese-gb2312 japanese-jisx0208 +; korean-ksc5601 japanese-jisx0212 +; chinese-cns11643-1 chinese-cns11643-2) . iso-2022-int-1) +; ((ascii latin-iso8859-1 latin-iso8859-2 +; cyrillic-iso8859-5 greek-iso8859-7 +; latin-jisx0201 japanese-jisx0208-1978 +; chinese-gb2312 japanese-jisx0208 +; korean-ksc5601 japanese-jisx0212 +; chinese-cns11643-1 chinese-cns11643-2 +; chinese-cns11643-3 chinese-cns11643-4 +; chinese-cns11643-5 chinese-cns11643-6 +; chinese-cns11643-7) . iso-2022-int-1) )) +(defun-maybe coding-system-get (coding-system prop) + "Extract a value from CODING-SYSTEM's property list for property PROP." + (plist-get (coding-system-plist coding-system) prop) + ) (defun coding-system-to-mime-charset (coding-system) "Convert CODING-SYSTEM to a MIME-charset. Return nil if corresponding MIME-charset is not found." (or (car (rassq coding-system mime-charset-coding-system-alist)) - (coding-system-get coding-system 'mime-charset))) + (coding-system-get coding-system 'mime-charset) + )) -(defun mime-charset-list () +(defun-maybe-cond mime-charset-list () "Return a list of all existing MIME-charset." - (let ((dest (mapcar (function car) mime-charset-coding-system-alist)) - (rest coding-system-list) - cs) - (while rest - (setq cs (car rest)) - (unless (rassq cs mime-charset-coding-system-alist) - (if (setq cs (coding-system-get cs 'mime-charset)) + ((boundp 'coding-system-list) + (let ((dest (mapcar (function car) mime-charset-coding-system-alist)) + (rest coding-system-list) + cs) + (while rest + (setq cs (car rest)) + (unless (rassq cs mime-charset-coding-system-alist) + (if (setq cs (coding-system-get cs 'mime-charset)) + (or (rassq cs mime-charset-coding-system-alist) + (memq cs dest) + (setq dest (cons cs dest)) + ))) + (setq rest (cdr rest))) + dest)) + (t + (let ((dest (mapcar (function car) mime-charset-coding-system-alist)) + (rest (coding-system-list)) + cs) + (while rest + (setq cs (car rest)) + (unless (rassq cs mime-charset-coding-system-alist) + (when (setq cs (or (coding-system-get cs 'mime-charset) + (and + (setq cs (aref + (coding-system-get cs 'coding-spec) + 2)) + (string-match "(MIME:[ \t]*\\([^,)]+\\)" cs) + (match-string 1 cs)))) + (setq cs (intern (downcase cs))) (or (rassq cs mime-charset-coding-system-alist) - (memq cs dest) + (memq cs dest) (setq dest (cons cs dest)) ))) - (setq rest (cdr rest))) - dest)) - + (setq rest (cdr rest))) + dest) + )) ;;; @ end ;;; diff --git a/mcs-ltn1.el b/mcs-ltn1.el index 2fed09a..643bb2a 100644 --- a/mcs-ltn1.el +++ b/mcs-ltn1.el @@ -30,6 +30,14 @@ (defvar default-mime-charset 'iso-8859-1) +(defsubst lbt-to-string (lbt) + (cdr (assq lbt '((nil . nil) + (CRLF . "\r\n") + (CR . "\r") + (dos . "\r\n") + (mac . "\r")))) + ) + (defun mime-charset-to-coding-system (charset) (if (stringp charset) (setq charset (intern (downcase charset))) @@ -46,25 +54,40 @@ default-mime-charset 'us-ascii)) -(defun encode-mime-charset-region (start end charset) +(defun encode-mime-charset-region (start end charset &optional lbt) "Encode the text between START and END as MIME CHARSET." - ) + (let ((newline (lbt-to-string lbt))) + (if newline + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match newline)) + ))) + )) (defun decode-mime-charset-region (start end charset &optional lbt) "Decode the text between START and END as MIME CHARSET." - (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) + (let ((newline (lbt-to-string lbt))) + (if newline + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward newline nil t) + (replace-match "\n")) + ))) + )) + +(defun encode-mime-charset-string (string charset &optional lbt) "Encode the STRING as MIME CHARSET." - string) + (if lbt + (with-temp-buffer + (insert string) + (encode-mime-charset-region (point-min)(point-max) charset lbt) + (buffer-string)) + string)) (defun decode-mime-charset-string (string charset &optional lbt) "Decode the STRING as MIME CHARSET." diff --git a/mcs-nemacs.el b/mcs-nemacs.el index c32fd6f..388db8a 100644 --- a/mcs-nemacs.el +++ b/mcs-nemacs.el @@ -34,6 +34,14 @@ (shift_jis . 1) )) +(defsubst lbt-to-string (lbt) + (cdr (assq lbt '((nil . nil) + (CRLF . "\r\n") + (CR . "\r") + (dos . "\r\n") + (mac . "\r")))) + ) + (defun mime-charset-to-coding-system (charset) (if (stringp charset) (setq charset (intern (downcase charset))) @@ -51,24 +59,30 @@ default-mime-charset 'us-ascii)) -(defun encode-mime-charset-region (start end charset) +(defun encode-mime-charset-region (start end charset &optional lbt) "Encode the text between START and END as MIME CHARSET. \[emu-nemacs.el]" - (let ((cs (mime-charset-to-coding-system charset))) + (let ((cs (mime-charset-to-coding-system charset)) + (nl (lbt-to-string lbt))) (and (numberp cs) (or (= cs 3) (save-excursion (save-restriction (narrow-to-region start end) - (convert-region-kanji-code start end 3 cs)))) - ))) + (convert-region-kanji-code start end 3 cs) + (if nl + (progn + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match nl))) + ))) + )))) (defun decode-mime-charset-region (start end charset &optional lbt) "Decode the text between START and END as MIME CHARSET. \[emu-nemacs.el]" (let ((cs (mime-charset-to-coding-system charset)) - (nl (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r") - (dos . "\r\n") (mac . "\r")))))) + (nl (lbt-to-string lbt))) (and (numberp cs) (or (= cs 3) (save-excursion @@ -83,12 +97,12 @@ ))) )))) -(defun encode-mime-charset-string (string charset) +(defun encode-mime-charset-string (string charset &optional lbt) "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))) + (with-temp-buffer + (insert string) + (encode-mime-charset-region (point-min)(point-max) charset lbt) + (buffer-string))) (defun decode-mime-charset-string (string charset &optional lbt) "Decode the STRING as MIME CHARSET. [emu-nemacs.el]" diff --git a/mcs-om.el b/mcs-om.el index 9c8c05e..6f469d8 100644 --- a/mcs-om.el +++ b/mcs-om.el @@ -26,22 +26,38 @@ (require 'poem) -(defun encode-mime-charset-region (start end charset) +(defsubst lbt-to-string (lbt) + (cdr (assq lbt '((nil . nil) + (CRLF . "\r\n") + (CR . "\r") + (dos . "\r\n") + (mac . "\r")))) + ) + +(defun encode-mime-charset-region (start end charset &optional lbt) "Encode the text between START and END as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) + (let ((cs (mime-charset-to-coding-system charset lbt))) (if cs (code-convert start end *internal* cs) - ))) + (if (and lbt (setq cs (mime-charset-to-coding-system charset))) + (let ((newline (lbt-to-string lbt))) + (save-excursion + (save-restriction + (narrow-to-region start end) + (code-convert (point-min) (point-max) *internal* cs) + (if newline + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match newline)))))))))) (defun decode-mime-charset-region (start end charset &optional lbt) "Decode the text between START and END as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset lbt)) - newline) + (let ((cs (mime-charset-to-coding-system charset lbt))) (if cs (code-convert start end cs *internal*) (if (and lbt (setq cs (mime-charset-to-coding-system charset))) - (progn - (if (setq newline (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r"))))) + (let ((newline (lbt-to-string lbt))) + (if newline (save-excursion (save-restriction (narrow-to-region start end) @@ -51,29 +67,39 @@ (code-convert (point-min) (point-max) cs *internal*)) (code-convert start end cs *internal*))))))) -(defun encode-mime-charset-string (string charset) +(defun encode-mime-charset-string (string charset &optional lbt) "Encode the STRING as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) + (let ((cs (mime-charset-to-coding-system charset lbt))) (if cs (code-convert-string string *internal* cs) - string))) + (if (and lbt (setq cs (mime-charset-to-coding-system charset))) + (let ((newline (lbt-to-string lbt))) + (if newline + (with-temp-buffer + (insert string) + (code-convert (point-min) (point-max) *internal* cs) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match newline)) + (buffer-string)) + (decode-coding-string string cs))) + string)))) (defun decode-mime-charset-string (string charset &optional lbt) "Decode the STRING which is encoded in MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset lbt)) - newline) + (let ((cs (mime-charset-to-coding-system charset lbt))) (if cs (decode-coding-string string cs) (if (and lbt (setq cs (mime-charset-to-coding-system charset))) - (progn - (if (setq newline (cdr (assq lbt '((CRLF . "\r\n") (CR . "\r"))))) + (let ((newline (lbt-to-string lbt))) + (if newline (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (search-forward newline nil t) - (replace-match "\n")) - (code-convert (point-min) (point-max) cs *internal*) - (buffer-string)) + (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)))) @@ -119,6 +145,10 @@ )) (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))) ) @@ -191,10 +221,17 @@ It is used when MIME-charset is not specified. It must be symbol.") +(defvar default-mime-charset-for-write + default-mime-charset + "Default value of MIME-charset for encoding. +It is used when suitable MIME-charset is not found. +It must be symbol.") + (defun detect-mime-charset-region (start end) "Return MIME charset for region between START and END." - (charsets-to-mime-charset - (cons lc-ascii (find-charset-region start end)))) + (or (charsets-to-mime-charset + (cons lc-ascii (find-charset-region start end))) + default-mime-charset-for-write)) ;;; @ end diff --git a/mcs-xm.el b/mcs-xm.el index fdc565d..5caf854 100644 --- a/mcs-xm.el +++ b/mcs-xm.el @@ -32,9 +32,9 @@ (require 'mcs-20) -(defun encode-mime-charset-region (start end charset) +(defun encode-mime-charset-region (start end charset &optional lbt) "Encode the text between START and END as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) + (let ((cs (mime-charset-to-coding-system charset lbt))) (if cs (encode-coding-region start end cs) ))) @@ -125,9 +125,9 @@ (assq t mime-charset-decoder-alist))))) (funcall func start end charset lbt))) -(defsubst encode-mime-charset-string (string charset) +(defsubst encode-mime-charset-string (string charset &optional lbt) "Encode the STRING as MIME CHARSET." - (let ((cs (mime-charset-to-coding-system charset))) + (let ((cs (mime-charset-to-coding-system charset lbt))) (if cs (encode-coding-string string cs) string))) @@ -169,11 +169,11 @@ 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 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) )) diff --git a/pccl-20.el b/pccl-20.el index ea672f3..3782b7c 100644 --- a/pccl-20.el +++ b/pccl-20.el @@ -114,19 +114,19 @@ If CCL-PROG is symbol, it is dereferenced. ) (broken-facility ccl-execute-eof-block-on-encoding-null - "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input." + "Emacs forgets executing CCL_EOF_BLOCK with encoding on empty input. (Fixed on Emacs 20.4)" (equal (encode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]")) (broken-facility ccl-execute-eof-block-on-encoding-some - "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input." + "Emacs forgets executing CCL_EOF_BLOCK with encoding on non-empty input. (Fixed on Emacs 20.3)" (equal (encode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]")) (broken-facility ccl-execute-eof-block-on-decoding-null - "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input." + "Emacs forgets executing CCL_EOF_BLOCK with decoding on empty input. (Fixed on Emacs 20.4)" (equal (decode-coding-string "" 'test-ccl-eof-block-cs) "[EOF]")) (broken-facility ccl-execute-eof-block-on-decoding-some - "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input." + "Emacs forgets executing CCL_EOF_BLOCK with decoding on non-empty input. (Fixed on Emacs 20.4)" (equal (decode-coding-string "a" 'test-ccl-eof-block-cs) "a[EOF]")) (broken-facility ccl-execute-eof-block-on-encoding diff --git a/pccl.el b/pccl.el index b7ba56f..9397b9a 100644 --- a/pccl.el +++ b/pccl.el @@ -1,4 +1,4 @@ -;;; pccl.el --- Portable CCL utility for Mule 1.* and Mule 2.* +;;; pccl.el --- Portable CCL utility for Mule 2.* ;; Copyright (C) 1998 Free Software Foundation, Inc. @@ -26,14 +26,12 @@ (require 'broken) -;; The condition for non-XEmacs mule t may be wrong. -;; But I don't know exact version which introduce CCL on mule. (broken-facility ccl-usable - "Emacs has CCL." + "Emacs has not CCL." (and (featurep 'mule) (if (featurep 'xemacs) (>= emacs-major-version 21) - t))) + (>= emacs-major-version 19)))) (unless-broken ccl-usable (require 'ccl) @@ -42,12 +40,12 @@ (if (featurep 'mule) (if (featurep 'xemacs) (if (>= emacs-major-version 21) - ;; for XEmacs-21-mule + ;; for XEmacs 21 with mule (require 'pccl-20)) (if (>= emacs-major-version 20) ;; for Emacs 20 (require 'pccl-20) - ;; for MULE 1.* and 2.* + ;; for Mule 2.* (require 'pccl-om)))) (defadvice define-ccl-program -- 1.7.10.4