X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mel-b-ccl.el;h=32bd8c800a966c58f98beb542807bc6918888ee2;hb=0f0317cf179760a10043565f80f31853a6161bff;hp=02fd3e36f27eb5648e6cd55ebab48d458a24f4bb;hpb=41fe6bdf8523a73c43e73612b5df85caa5622081;p=elisp%2Fflim.git

diff --git a/mel-b-ccl.el b/mel-b-ccl.el
index 02fd3e3..32bd8c8 100644
--- a/mel-b-ccl.el
+++ b/mel-b-ccl.el
@@ -1,6 +1,6 @@
-;;; mel-b-ccl.el: CCL based encoder/decoder of Base64
+;;; mel-b-ccl.el --- Base64 encoder/decoder using CCL.
 
-;; Copyright (C) 1998 Tanaka Akira
+;; Copyright (C) 1998,1999 Tanaka Akira
 
 ;; Author: Tanaka Akira <akr@jaist.ac.jp>
 ;; Created: 1998/9/17
@@ -19,7 +19,7 @@
 ;; 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
+;; along with this program; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
@@ -151,133 +151,147 @@ abcdefghijklmnopqrstuvwxyz\
 
 (if-broken ccl-cascading-read
     (define-ccl-program mel-ccl-decode-b
-      `(1
-	(loop
-	 (loop
-	  (read-branch
-	   r1
-	   ,@(mapcar
-	      (lambda (v)
-		(cond
-		 ((or (eq v nil) (eq v t)) '(repeat))
-		 (t `((r0 = ,(lsh v 2)) (break)))))
-	      mel-ccl-256-to-64-table)))
-	 (loop
-	  (read-branch
-	   r1
-	   ,@(mapcar
-	      (lambda (v)
-		(cond
-		 ((or (eq v nil) (eq v t)) '(repeat))
-		 ((= (lsh v -4) 0) `((write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))
-		 (t `((r0 |= ,(lsh v -4)) (write r0) (r0 = ,(lsh (logand v 15) 4)) (break)))))
-	      mel-ccl-256-to-64-table)))
-	 (loop
-	  (read-branch
-	   r1
-	   ,@(mapcar
-	      (lambda (v)
-		(cond
-		 ((eq v nil) '(repeat))
-		 ((eq v t) '(end))
-		 ((= (lsh v -2) 0) `((write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))
-		 (t `((r0 |= ,(lsh v -2)) (write r0) (r0 = ,(lsh (logand v 3) 6)) (break)))))
-	      mel-ccl-256-to-64-table)))
-	 (loop
-	  (read-branch
-	   r1
-	   ,@(mapcar
-	      (lambda (v)
-		(cond
-		 ((eq v nil) '(repeat))
-		 ((eq v t) '(end))
-		 (t `((r0 |= ,v) (write r0) (break)))))
-	      mel-ccl-256-to-64-table)))
-	 (repeat))))
+      (` (1
+	  (loop
+	   (loop
+	    (read-branch
+	     r1
+	     (,@ (mapcar
+		  (lambda (v)
+		    (cond
+		     ((or (eq v nil) (eq v t)) '(repeat))
+		     (t (` ((r0 = (, (lsh v 2))) (break))))))
+		  mel-ccl-256-to-64-table))))
+	   (loop
+	    (read-branch
+	     r1
+	     (,@ (mapcar
+		  (lambda (v)
+		    (cond
+		     ((or (eq v nil) (eq v t)) '(repeat))
+		     ((= (lsh v -4) 0)
+		      (` ((write r0)
+			  (r0 = (, (lsh (logand v 15) 4)))
+			  (break))))
+		     (t 
+		      (` ((r0 |= (, (lsh v -4))) 
+			  (write r0) 
+			  (r0 = (, (lsh (logand v 15) 4))) 
+			  (break))))))
+		  mel-ccl-256-to-64-table))))
+	   (loop
+	    (read-branch
+	     r1
+	     (,@ (mapcar
+		  (lambda (v)
+		    (cond
+		     ((eq v nil) '(repeat))
+		     ((eq v t) '(end))
+		     ((= (lsh v -2) 0)
+		      (` ((write r0) 
+			  (r0 = (, (lsh (logand v 3) 6)))
+			  (break))))
+		     (t
+		      (` ((r0 |= (, (lsh v -2)))
+			  (write r0) 
+			  (r0 = (, (lsh (logand v 3) 6)))
+			  (break))))))
+		  mel-ccl-256-to-64-table))))
+	   (loop
+	    (read-branch
+	     r1
+	     (,@ (mapcar
+		  (lambda (v)
+		    (cond
+		     ((eq v nil) '(repeat))
+		     ((eq v t) '(end))
+		     (t (` ((r0 |= (, v)) (write r0) (break))))))
+		  mel-ccl-256-to-64-table))))
+	   (repeat)))))
   (define-ccl-program mel-ccl-decode-b
-    `(1
-      (loop
-       (read r0 r1 r2 r3)
-       (r4 = r0 ,mel-ccl-decode-b-0-table)
-       (r5 = r1 ,mel-ccl-decode-b-1-table)
-       (r4 |= r5)
-       (r5 = r2 ,mel-ccl-decode-b-2-table)
-       (r4 |= r5)
-       (r5 = r3 ,mel-ccl-decode-b-3-table)
-       (r4 |= r5)
-       (if (r4 & ,(lognot (1- (lsh 1 24))))
-	   ((loop
-	     (if (r4 & ,(lsh 1 24))
-		 ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
-		  (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
-		  (r5 = r3 ,mel-ccl-decode-b-3-table)
-		  (r4 |= r5)
-		  (repeat))
-	       (break)))
-	    (loop
-	     (if (r4 & ,(lsh 1 25))
-		 ((r1 = r2) (r2 = r3) (read r3)
-		  (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
-		  (r5 = r3 ,mel-ccl-decode-b-3-table)
-		  (r4 |= r5)
-		  (repeat))
-	       (break)))
-	    (loop
-	     (if (r2 != ?=)
-		 (if (r4 & ,(lsh 1 26))
-		     ((r2 = r3) (read r3)
-		      (r4 >>= 1) (r4 &= ,(logior (lsh 7 24)))
-		      (r5 = r3 ,mel-ccl-decode-b-3-table)
-		      (r4 |= r5)
-		      (repeat))
-		   ((r6 = 0)
-		    (break)))
-	       ((r6 = 1)
-		(break))))
-	    (loop
-	     (if (r3 != ?=)
-		 (if (r4 & ,(lsh 1 27))
-		     ((read r3)
-		      (r4 = r3 ,mel-ccl-decode-b-3-table)
-		      (repeat))
-		   (break))
-	       ((r6 |= 2)
-		(break))))
-	    (r4 = r0 ,mel-ccl-decode-b-0-table)
-	    (r5 = r1 ,mel-ccl-decode-b-1-table)
-	    (r4 |= r5)
-	    (branch
-	     r6
-	     ;; BBBB
-	     ((r5 = r2 ,mel-ccl-decode-b-2-table)
-	      (r4 |= r5)
-	      (r5 = r3 ,mel-ccl-decode-b-3-table)
-	      (r4 |= r5)
-	      (r4 >8= 0)
-	      (write r7)
-	      (r4 >8= 0)
-	      (write r7)
-	      (write-repeat r4))
-	     ;; error: BB=B 
-	     ((write (r4 & 255))
-	      (end))
-	     ;; BBB=
-	     ((r5 = r2 ,mel-ccl-decode-b-2-table)
+    (` (1
+	(loop
+	 (read r0 r1 r2 r3)
+	 (r4 = r0 (, mel-ccl-decode-b-0-table))
+	 (r5 = r1 (, mel-ccl-decode-b-1-table))
+	 (r4 |= r5)
+	 (r5 = r2 (, mel-ccl-decode-b-2-table))
+	 (r4 |= r5)
+	 (r5 = r3 (, mel-ccl-decode-b-3-table))
+	 (r4 |= r5)
+	 (if (r4 & (, (lognot (1- (lsh 1 24)))))
+	     ((loop
+	       (if (r4 & (, (lsh 1 24)))
+		   ((r0 = r1) (r1 = r2) (r2 = r3) (read r3)
+		    (r4 >>= 1) (r4 &= (, (logior (lsh 7 24))))
+		    (r5 = r3 (, mel-ccl-decode-b-3-table))
+		    (r4 |= r5)
+		    (repeat))
+		 (break)))
+	      (loop
+	       (if (r4 & (, (lsh 1 25)))
+		   ((r1 = r2) (r2 = r3) (read r3)
+		    (r4 >>= 1) (r4 &= (, (logior (lsh 7 24))))
+		    (r5 = r3 (, mel-ccl-decode-b-3-table))
+		    (r4 |= r5)
+		    (repeat))
+		 (break)))
+	      (loop
+	       (if (r2 != ?=)
+		   (if (r4 & (, (lsh 1 26)))
+		       ((r2 = r3) (read r3)
+			(r4 >>= 1) (r4 &= (, (logior (lsh 7 24))))
+			(r5 = r3 (, mel-ccl-decode-b-3-table))
+			(r4 |= r5)
+			(repeat))
+		     ((r6 = 0)
+		      (break)))
+		 ((r6 = 1)
+		  (break))))
+	      (loop
+	       (if (r3 != ?=)
+		   (if (r4 & (, (lsh 1 27)))
+		       ((read r3)
+			(r4 = r3 (, mel-ccl-decode-b-3-table))
+			(repeat))
+		     (break))
+		 ((r6 |= 2)
+		  (break))))
+	      (r4 = r0 (, mel-ccl-decode-b-0-table))
+	      (r5 = r1 (, mel-ccl-decode-b-1-table))
 	      (r4 |= r5)
-	      (r4 >8= 0)
-	      (write r7)
-	      (write (r4 & 255))
-	      (end)			; Excessive (end) is workaround for XEmacs 21.0.
+	      (branch
+	       r6
+	       ;; BBBB
+	       ((r5 = r2 (, mel-ccl-decode-b-2-table))
+		(r4 |= r5)
+		(r5 = r3 (, mel-ccl-decode-b-3-table))
+		(r4 |= r5)
+		(r4 >8= 0)
+		(write r7)
+		(r4 >8= 0)
+		(write r7)
+		(write-repeat r4))
+	       ;; error: BB=B 
+	       ((write (r4 & 255))
+		(end))
+	       ;; BBB=
+	       ((r5 = r2 (, mel-ccl-decode-b-2-table))
+		(r4 |= r5)
+		(r4 >8= 0)
+		(write r7)
+		(write (r4 & 255))
+		(end)			; Excessive (end) is workaround for XEmacs 21.0.
 					; Without this, "AAA=" is converted to "^@^@^@".
-	      (end))
-	     ;; BB==
-	     ((write (r4 & 255))
-	      (end))))
-	 ((r4 >8= 0)
-	  (write r7)
-	  (r4 >8= 0)
-	  (write r7)
-	  (write-repeat r4))))))
+		(end))
+	       ;; BB==
+	       ((write (r4 & 255))
+		(end))))
+	   ((r4 >8= 0)
+	    (write r7)
+	    (r4 >8= 0)
+	    (write r7)
+	    (write-repeat r4)))))))
   )
 
 (eval-when-compile
@@ -286,78 +300,81 @@ abcdefghijklmnopqrstuvwxyz\
 ;; is not executed.
 (defun mel-ccl-encode-base64-generic
   (&optional quantums-per-line output-crlf terminate-with-newline)
-  `(2
-    ((r3 = 0)
-     (loop
-      (r2 = 0)
-      (read-branch
-       r1
-       ,@(mapcar
-          (lambda (r1)
-            `((write ,(nth (lsh r1 -2) mel-ccl-64-to-256-table))
-              (r0 = ,(logand r1 3))))
-          mel-ccl-256-table))
-      (r2 = 1)
-      (read-branch
-       r1
-       ,@(mapcar
-          (lambda (r1)
-            `((write r0 ,(vconcat
-                          (mapcar
-                           (lambda (r0)
-                             (nth (logior (lsh r0 4)
-                                          (lsh r1 -4))
-                                  mel-ccl-64-to-256-table))
-                           mel-ccl-4-table)))
-              (r0 = ,(logand r1 15))))
-          mel-ccl-256-table))
-      (r2 = 2)
-      (read-branch
-       r1
-       ,@(mapcar
-          (lambda (r1)
-            `((write r0 ,(vconcat
-                          (mapcar
-                           (lambda (r0)
-                             (nth (logior (lsh r0 2)
-                                          (lsh r1 -6))
-                                  mel-ccl-64-to-256-table))
-                           mel-ccl-16-table)))))
-          mel-ccl-256-table))
-      (r1 &= 63)
-      (write r1 ,(vconcat
-                  (mapcar
-                   (lambda (r1)
-                     (nth r1 mel-ccl-64-to-256-table))
-                   mel-ccl-64-table)))
-      (r3 += 1)
-      ,@(when quantums-per-line
-	  `((if (r3 == ,quantums-per-line)
-		((write ,(if output-crlf "\r\n" "\n"))
-		 (r3 = 0)))))
-      (repeat)))
-    (branch
-     r2
-     ,(if terminate-with-newline
-	  `(if (r3 > 0) (write ,(if output-crlf "\r\n" "\n")))
-	`(r0 = 0))
-     ((write r0 ,(vconcat
-                  (mapcar
-                   (lambda (r0)
-                     (nth (lsh r0 4) mel-ccl-64-to-256-table))
-                   mel-ccl-4-table)))
-      (write ,(if terminate-with-newline
-		  (if output-crlf "==\r\n" "==\n")
-		"==")))
-     ((write r0 ,(vconcat
-                  (mapcar
-                   (lambda (r0)
-                     (nth (lsh r0 2) mel-ccl-64-to-256-table))
-                   mel-ccl-16-table)))
-      (write ,(if terminate-with-newline
-		  (if output-crlf "=\r\n" "=\n")
-		"="))))
-    ))
+  (` (2
+      ((r3 = 0)
+       (r2 = 0)
+       (read r1)
+       (loop
+	(branch
+	 r1
+	 (,@ (mapcar
+	      (lambda (r1)
+		(` ((write (, (nth (lsh r1 -2) mel-ccl-64-to-256-table)))
+		    (r0 = (, (logand r1 3))))))
+	      mel-ccl-256-table)))
+	(r2 = 1)
+	(read-branch
+	 r1
+	 (,@ (mapcar
+	      (lambda (r1)
+		(` ((write r0 (, (vconcat
+				  (mapcar
+				   (lambda (r0)
+				     (nth (logior (lsh r0 4)
+						  (lsh r1 -4))
+					  mel-ccl-64-to-256-table))
+				   mel-ccl-4-table))))
+		    (r0 = (, (logand r1 15))))))
+	      mel-ccl-256-table)))
+	(r2 = 2)
+	(read-branch
+	 r1
+	 (,@ (mapcar
+	      (lambda (r1)
+		(` ((write r0 (, (vconcat
+				  (mapcar
+				   (lambda (r0)
+				     (nth (logior (lsh r0 2)
+						  (lsh r1 -6))
+					  mel-ccl-64-to-256-table))
+				   mel-ccl-16-table)))))))
+	      mel-ccl-256-table)))
+	(r1 &= 63)
+	(write r1 (, (vconcat
+		      (mapcar
+		       (lambda (r1)
+			 (nth r1 mel-ccl-64-to-256-table))
+		       mel-ccl-64-table))))
+	(r3 += 1)
+	(r2 = 0)
+	(read r1)
+	(,@ (when quantums-per-line
+	      (` ((if (r3 == (, quantums-per-line))
+		      ((write (, (if output-crlf "\r\n" "\n")))
+		       (r3 = 0)))))))
+	(repeat)))
+      (branch
+       r2
+       (, (if terminate-with-newline
+	      (` (if (r3 > 0) (write (, (if output-crlf "\r\n" "\n")))))
+	    (` (r0 = 0))))
+       ((write r0 (, (vconcat
+		      (mapcar
+		       (lambda (r0)
+			 (nth (lsh r0 4) mel-ccl-64-to-256-table))
+		       mel-ccl-4-table))))
+	(write (, (if terminate-with-newline
+		      (if output-crlf "==\r\n" "==\n")
+		    "=="))))
+       ((write r0 (, (vconcat
+		      (mapcar
+		       (lambda (r0)
+			 (nth (lsh r0 2) mel-ccl-64-to-256-table))
+		       mel-ccl-16-table))))
+	(write (, (if terminate-with-newline
+		      (if output-crlf "=\r\n" "=\n")
+		    "=")))))
+      )))
 )
 
 (define-ccl-program mel-ccl-encode-b
@@ -398,18 +415,24 @@ abcdefghijklmnopqrstuvwxyz\
 
 (unless-broken ccl-execute-eof-block-on-decoding-some
 
-  (defun base64-ccl-encode-string (string)
+  (defun base64-ccl-encode-string (string &optional no-line-break)
     "Encode STRING with base64 encoding."
-    (decode-coding-string string 'mel-ccl-base64-lf-rev))
+    (if no-line-break
+	(decode-coding-string string 'mel-ccl-b-rev)
+      (decode-coding-string string 'mel-ccl-base64-lf-rev)))
+  (defalias-maybe 'base64-encode-string 'base64-ccl-encode-string)
 
-  (defun base64-ccl-encode-region (start end)
+  (defun base64-ccl-encode-region (start end &optional no-line-break)
     "Encode region from START to END with base64 encoding."
-    (interactive "r")
-    (decode-coding-region start end 'mel-ccl-base64-lf-rev))
+    (interactive "*r")
+    (if no-line-break
+	(decode-coding-region start end 'mel-ccl-b-rev)
+      (decode-coding-region start end 'mel-ccl-base64-lf-rev)))
+  (defalias-maybe 'base64-encode-region 'base64-ccl-encode-region)
 
   (defun base64-ccl-insert-encoded-file (filename)
     "Encode contents of file FILENAME to base64, and insert the result."
-    (interactive (list (read-file-name "Insert encoded file: ")))
+    (interactive "*fInsert encoded file: ")
     (insert-file-contents-as-coding-system 'mel-ccl-base64-lf-rev filename))
 
   (mel-define-method-function (mime-encode-string string (nil "base64"))
@@ -427,17 +450,17 @@ abcdefghijklmnopqrstuvwxyz\
 (defun base64-ccl-decode-string (string)
   "Decode base64 encoded STRING"
   (encode-coding-string string 'mel-ccl-b-rev))
+(defalias-maybe 'base64-decode-string 'base64-ccl-decode-string)
 
 (defun base64-ccl-decode-region (start end)
   "Decode base64 encoded the region from START to END."
-  (interactive "r")
+  (interactive "*r")
   (encode-coding-region start end 'mel-ccl-b-rev))
+(defalias-maybe 'base64-decode-region 'base64-ccl-decode-region)
 
 (defun base64-ccl-write-decoded-region (start end filename)
   "Decode the region from START to END and write out to FILENAME."
-  (interactive
-    (list (region-beginning) (region-end)
-          (read-file-name "Write decoded region to file: ")))
+  (interactive "*r\nFWrite decoded region to file: ")
   (write-region-as-coding-system 'mel-ccl-b-rev start end filename))
 
 (mel-define-method-function (mime-decode-string string (nil "base64"))
@@ -449,8 +472,9 @@ abcdefghijklmnopqrstuvwxyz\
  'base64-ccl-write-decoded-region)
 
 (mel-define-method encoded-text-decode-string (string (nil "B"))
-  (if (and (string-match B-encoded-text-regexp string)
-	   (string= string (match-string 0 string)))
+  (if (string-match (eval-when-compile
+		      (concat "\\`" B-encoded-text-regexp "\\'"))
+		    string)
       (base64-ccl-decode-string string)
     (error "Invalid encoded-text %s" string)))
 
@@ -460,4 +484,4 @@ abcdefghijklmnopqrstuvwxyz\
 
 (provide 'mel-b-ccl)
 
-;;; mel-b-ccl.el ends here
+;;; mel-b-ccl.el ends here.