X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=pccl.el;h=646bab7ba047156290938bccf51d01faea2e6fa3;hb=4a816b66bd781e2851608d7f66563a75dc4093d8;hp=30e435624b065b45b83668b775517a44d5003320;hpb=6a03d627215ab27eea876b036760dc4297e7d84a;p=elisp%2Fapel.git

diff --git a/pccl.el b/pccl.el
index 30e4356..646bab7 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,28 +26,142 @@
 
 (require 'broken)
 
-(if (featurep 'mule)
-    (if (featurep 'xemacs)
-        (if (>= emacs-major-version 21)
-            ;; for XEmacs-21-mule
-            (require 'pccl-20))
-      (if (>= emacs-major-version 20)
-          ;; for Emacs 20
-          (require 'pccl-20)
-        ;; for MULE 1.* and 2.*
-        (require 'pccl-om))))
-
 (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)
+  (require 'advice)
+
+  (if (featurep 'mule)
+      (if (featurep 'xemacs)
+          (if (>= emacs-major-version 21)
+              ;; for XEmacs 21 with mule
+              (require 'pccl-20))
+        (if (>= emacs-major-version 20)
+            ;; for Emacs 20
+            (require 'pccl-20)
+          ;; for Mule 2.*
+          (require 'pccl-om))))
+
+  (static-if (or (featurep 'xemacs) (< emacs-major-version 21))
+    (defadvice define-ccl-program
+      (before accept-long-ccl-program activate)
+      "When CCL-PROGRAM is too long, internal buffer is extended automatically."
+      (let ((try-ccl-compile t)
+	    (prog (eval (ad-get-arg 1))))
+	(ad-set-arg 1 (` '(, prog)))
+	(while try-ccl-compile
+	  (setq try-ccl-compile nil)
+	  (condition-case sig
+	      (ccl-compile prog)
+	    (args-out-of-range
+	     (if (and (eq (car (cdr sig)) ccl-program-vector)
+		      (= (car (cdr (cdr sig))) (length ccl-program-vector)))
+		 (setq ccl-program-vector
+		       (make-vector (* 2 (length ccl-program-vector)) 0)
+		       try-ccl-compile t)
+	       (signal (car sig) (cdr sig)))))))))
+
+  (static-when (and (not (featurep 'xemacs)) (< emacs-major-version 21))
+    (defun-maybe transform-make-coding-system-args (name type &optional doc-string props)
+      "For internal use only.
+Transform XEmacs style args for `make-coding-system' to Emacs style.
+Value is a list of transformed arguments."
+      (let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?")))
+	    (eol-type (plist-get props 'eol-type))
+	    properties tmp)
+	(cond
+	 ((eq eol-type 'lf) (setq eol-type 'unix))
+	 ((eq eol-type 'crlf) (setq eol-type 'dos))
+	 ((eq eol-type 'cr) (setq eol-type 'mac)))
+	(if (setq tmp (plist-get props 'post-read-conversion))
+	    (setq properties (plist-put properties 'post-read-conversion tmp)))
+	(if (setq tmp (plist-get props 'pre-write-conversion))
+	    (setq properties (plist-put properties 'pre-write-conversion tmp)))
+	(cond
+	 ((eq type 'shift-jis)
+	  `(,name 1 ,mnemonic ,doc-string () ,properties ,eol-type))
+	 ((eq type 'iso2022) ; This is not perfect.
+	  (if (plist-get props 'escape-quoted)
+	      (error "escape-quoted is not supported: %S"
+		     `(,name ,type ,doc-string ,props)))
+	  (let ((g0 (plist-get props 'charset-g0))
+		(g1 (plist-get props 'charset-g1))
+		(g2 (plist-get props 'charset-g2))
+		(g3 (plist-get props 'charset-g3))
+		(use-roman
+		 (and
+		  (eq (cadr (assoc 'latin-jisx0201
+				   (plist-get props 'input-charset-conversion)))
+		      'ascii)
+		  (eq (cadr (assoc 'ascii
+				   (plist-get props 'output-charset-conversion)))
+		      'latin-jisx0201)))
+		(use-oldjis
+		 (and
+		  (eq (cadr (assoc 'japanese-jisx0208-1978
+				   (plist-get props 'input-charset-conversion)))
+		      'japanese-jisx0208)
+		  (eq (cadr (assoc 'japanese-jisx0208
+				   (plist-get props 'output-charset-conversion)))
+		      'japanese-jisx0208-1978))))
+	    (if (charsetp g0)
+		(if (plist-get props 'force-g0-on-output)
+		    (setq g0 `(nil ,g0))
+		  (setq g0 `(,g0 t))))
+	    (if (charsetp g1)
+		(if (plist-get props 'force-g1-on-output)
+		    (setq g1 `(nil ,g1))
+		  (setq g1 `(,g1 t))))
+	    (if (charsetp g2)
+		(if (plist-get props 'force-g2-on-output)
+		    (setq g2 `(nil ,g2))
+		  (setq g2 `(,g2 t))))
+	    (if (charsetp g3)
+		(if (plist-get props 'force-g3-on-output)
+		    (setq g3 `(nil ,g3))
+		  (setq g3 `(,g3 t))))
+	    `(,name 2 ,mnemonic ,doc-string
+	      (,g0 ,g1 ,g2 ,g3
+	       ,(plist-get props 'short)
+	       ,(not (plist-get props 'no-ascii-eol))
+	       ,(not (plist-get props 'no-ascii-cntl))
+	       ,(plist-get props 'seven)
+	       t
+	       ,(not (plist-get props 'lock-shift))
+	       ,use-roman
+	       ,use-oldjis
+	       ,(plist-get props 'no-iso6429)
+	       nil nil nil nil)
+	    ,properties ,eol-type)))
+	 ((eq type 'big5)
+	  `(,name 3 ,mnemonic ,doc-string () ,properties ,eol-type))
+	 ((eq type 'ccl)
+	  `(,name 4 ,mnemonic ,doc-string
+		  (,(plist-get props 'decode) . ,(plist-get props 'encode))
+		  ,properties ,eol-type))
+	 (t
+	  (error "unsupported XEmacs style make-coding-style arguments: %S"
+		 `(,name ,type ,doc-string ,props))))))
+    (defadvice make-coding-system
+      (before ccl-compat (name type &rest ad-subr-args) activate)
+      "Emulate XEmacs style make-coding-system."
+      (when (and (symbolp type) (not (memq type '(t nil))))
+        (let ((args (apply 'transform-make-coding-system-args
+	                   name type ad-subr-args)))
+	  (setq type (cadr args)
+	        ad-subr-args (cddr args)))))))
 
 
 ;;; @ end
 ;;;
 
-(provide 'pccl)
+(require 'product)
+(product-provide (provide 'pccl) (require 'apel-ver))
 
 ;;; pccl.el ends here