This commit was manufactured by cvs2svn to create branch 'doodle'.

[elisp/flim.git] / mel-b.el

diff --git a/mel-b.el b/mel-b.el
index 72f1e51..ad34a37 100644 (file)
--- a/mel-b.el
+++ b/mel-b.el
@@ -27,48 +27,61 @@
 ;;; Code:
 
 (require 'emu)
 ;;; Code:
 
 (require 'emu)

+(require 'mime-def)

 
 
 ;;; @ variables
 ;;;
 
 
 
 ;;; @ variables
 ;;;
 

-(defvar base64-external-encoder '("mmencode")
-  "*list of base64 encoder program name and its arguments.")
-
-(defvar base64-external-decoder '("mmencode" "-u")
-  "*list of base64 decoder program name and its arguments.")
-
-(defvar base64-external-decoder-option-to-specify-file '("-o")
-  "*list of options of base64 decoder program to specify file.")
-
-
-;;; @ internal base64 decoder/encoder
+(defgroup base64 nil
+  "Base64 encoder/decoder"
+  :group 'mime)
+
+(defcustom base64-external-encoder '("mmencode")
+  "*list of base64 encoder program name and its arguments."
+  :group 'base64
+  :type '(cons (file :tag "Command")(repeat :tag "Arguments" string)))
+
+(defcustom base64-external-decoder '("mmencode" "-u")
+  "*list of base64 decoder program name and its arguments."
+  :group 'base64
+  :type '(cons (file :tag "Command")(repeat :tag "Arguments" string)))
+
+(defcustom base64-external-decoder-option-to-specify-file '("-o")
+  "*list of options of base64 decoder program to specify file."
+  :group 'base64
+  :type '(repeat :tag "Arguments" string))
+
+(defcustom base64-internal-encoding-limit 1000
+  "*limit size to use internal base64 encoder.
+If size of input to encode is larger than this limit,
+external encoder is called."
+  :group 'base64
+  :type '(choice (const :tag "Always use internal encoder" nil)
+                (integer :tag "Size")))
+
+(defcustom base64-internal-decoding-limit (if (and (featurep 'xemacs)
+                                                  (featurep 'mule))
+                                             1000
+                                           7600)
+  "*limit size to use internal base64 decoder.
+If size of input to decode is larger than this limit,
+external decoder is called."
+  :group 'base64
+  :type '(choice (const :tag "Always use internal decoder" nil)
+                (integer :tag "Size")))
+
+
+;;; @ internal base64 encoder

 ;;;    based on base64 decoder by Enami Tsugutomo
 
 ;;;    based on base64 decoder by Enami Tsugutomo
 

-;;; @@ convert from/to base64 char
-;;;
+(eval-and-compile
+  (defconst base64-characters
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+  )

 
 

-(defun base64-num-to-char (n)
-  (cond ((eq n nil) ?=)
-       ((< n 26) (+ ?A n))
-       ((< n 52) (+ ?a (- n 26)))
-       ((< n 62) (+ ?0 (- n 52)))
-       ((= n 62) ?+)
-       ((= n 63) ?/)
-       (t (error "not a base64 integer %d" n))))
-
-(defun base64-char-to-num (c)
-  (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
-       ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
-       ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
-       ((= c ?+) 62)
-       ((= c ?/) 63)
-       ((= c ?=) nil)
-       (t (error "not a base64 character %c" c))))
-
-
-;;; @@ encode/decode one base64 unit
-;;;
+(defmacro base64-num-to-char (n)
+  `(aref base64-characters ,n))

 
 (defun base64-encode-1 (pack)
   (let ((a (car pack))
 
 (defun base64-encode-1 (pack)
   (let ((a (car pack))

@@ -93,25 +106,7 @@
                (base64-num-to-char (ash (logand a 3) 4))) "==")
        ))))
 
                (base64-num-to-char (ash (logand a 3) 4))) "==")
        ))))
 

-(defun base64-decode-unit (a b &optional c d)
-  (condition-case err
-      (concat
-       (char-to-string (logior (ash (base64-char-to-num a) 2)
-                              (ash (setq b (base64-char-to-num b)) -4)))
-       (if (and c (setq c (base64-char-to-num c)))
-          (concat (char-to-string
-                   (logior (ash (logand b 15) 4) (ash c -2)))
-                  (if (and d (setq d (base64-char-to-num d)))
-                      (char-to-string (logior (ash (logand c 3) 6) d))
-                    ))))
-    (error (message (nth 1 err))
-          "")))
-
-
-;;; @@ base64 encoder/decoder for string
-;;;
-
-(defun base64-internal-encode-string (string)
+(defun base64-encode-string (string)

   "Encode STRING to base64, and return the result."
   (let ((len (length string))
        (b 0)(e 57)
   "Encode STRING to base64, and return the result."
   (let ((len (length string))
        (b 0)(e 57)

@@ -139,67 +134,97 @@
                            ))
       )))
 
                            ))
       )))
 

-(defun base64-internal-decode-string (string)
-  (let ((len (length string))
-       (i 0)
-       dest)
-    (while (< i len)
-      (let ((a (aref string i)))
-       (setq i (1+ i))
-       (unless (eq a ?\n)
-         (let ((b (aref string i)))
-           (setq i (1+ i))
-           (cond
-            ((eq b ?\n)
-             ;; invalid
-             )
-            ((>= i len)
-             (setq dest (concat dest (base64-decode-unit a b) ))
-             )
-            (t
-             (let ((c (aref string i)))
-               (setq i (1+ i))
-               (cond
-                ((eq c ?\n)
-                 (setq dest (concat dest (base64-decode-unit a b)))
-                 )
-                ((>= i len)
-                 (setq dest (concat dest (base64-decode-unit a b c)))
-                 )
-                (t
-                 (let ((d (aref string i)))
-                   (setq i (1+ i))
-                   (setq dest
-                         (concat dest
-                                 (if (eq c ?\n)
-                                     (base64-decode-unit a b c)
-                                   (base64-decode-unit a b c d))))
-                   ))))))))))
-    dest))
-
-
-;;; @ base64 encoder/decoder for region
-;;;
-

 (defun base64-internal-encode-region (beg end)
   (save-excursion
     (save-restriction
       (narrow-to-region beg end)
       (let ((str (buffer-substring beg end)))
        (delete-region beg end)
 (defun base64-internal-encode-region (beg end)
   (save-excursion
     (save-restriction
       (narrow-to-region beg end)
       (let ((str (buffer-substring beg end)))
        (delete-region beg end)

-       (insert (base64-internal-encode-string str))
+       (insert (base64-encode-string str))

        )
       (or (bolp)
          (insert "\n")
          )
       )))
 
        )
       (or (bolp)
          (insert "\n")
          )
       )))
 

+
+;;; @ internal base64 decoder
+;;;
+
+(defconst base64-numbers
+  (eval-when-compile
+    (let ((len (length base64-characters))
+         (vec (make-vector 123 nil))
+         (i 0))
+      (while (< i len)
+       (aset vec (aref base64-characters i) i)
+       (setq i (1+ i)))
+      vec)))
+
+(defmacro base64-char-to-num (c)
+  `(aref base64-numbers ,c))
+
+(defsubst base64-internal-decode (string buffer)
+  (let* ((len (length string))
+        (i 0)
+        (j 0)
+        v1 v2 v3)
+    (catch 'tag
+      (while (< i len)
+       (when (prog1 (setq v1 (base64-char-to-num (aref string i)))
+               (setq i (1+ i)))
+         (setq v2 (base64-char-to-num (aref string i))
+               i (1+ i)
+               v3 (base64-char-to-num (aref string i))
+               i (1+ i))
+         (aset buffer j (logior (lsh v1 2)(lsh v2 -4)))
+         (setq j (1+ j))
+         (if v3
+             (let ((v4 (base64-char-to-num (aref string i))))
+               (setq i (1+ i))
+               (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2)))
+               (setq j (1+ j))
+               (if v4
+                   (aset buffer (prog1 j (setq j (1+ j)))
+                         (logior (lsh (logand v3 3) 6) v4))
+                 (throw 'tag nil)
+                 ))
+           (throw 'tag nil)
+           ))))
+    (substring buffer 0 j)
+    ))
+
+(defun base64-internal-decode-string (string)
+  (base64-internal-decode string (make-string (length string) 0)))
+
+;; (defsubst base64-decode-string! (string)
+;;   (setq string (string-as-unibyte string))
+;;   (base64-internal-decode string string))
+

 (defun base64-internal-decode-region (beg end)
   (save-excursion
 (defun base64-internal-decode-region (beg end)
   (save-excursion

-    (let ((str (buffer-substring beg end)))
+    (let ((str (string-as-unibyte (buffer-substring beg end))))

       (delete-region beg end)
       (goto-char beg)
       (delete-region beg end)
       (goto-char beg)

-      (insert (base64-internal-decode-string str)))))
+      (insert (base64-internal-decode str str)))))
+
+;; (defun base64-internal-decode-region2 (beg end)
+;;   (save-excursion
+;;     (let ((str (buffer-substring beg end)))
+;;       (delete-region beg end)
+;;       (goto-char beg)
+;;       (insert (base64-decode-string! str)))))
+
+;; (defun base64-internal-decode-region3 (beg end)
+;;   (save-excursion
+;;     (let ((str (buffer-substring beg end)))
+;;       (delete-region beg end)
+;;       (goto-char beg)
+;;       (insert (base64-internal-decode-string str)))))
+
+
+;;; @ external encoder/decoder
+;;;

 
 (defun base64-external-encode-region (beg end)
   (save-excursion
 
 (defun base64-external-encode-region (beg end)
   (save-excursion

@@ -234,62 +259,123 @@
            t t nil (cdr base64-external-decoder)))
     (buffer-string)))
 
            t t nil (cdr base64-external-decoder)))
     (buffer-string)))
 

-;;; @ base64 encoder/decoder for file
+
+;;; @ application interfaces

 ;;;
 
 ;;;
 

-(defun base64-external-insert-encoded-file (filename)
+(defun base64-encode-region (start end)
+  "Encode current region by base64.
+START and END are buffer positions.
+This function calls internal base64 encoder if size of region is
+smaller than `base64-internal-encoding-limit', otherwise it calls
+external base64 encoder specified by `base64-external-encoder'.  In
+this case, you must install the program (maybe mmencode included in
+metamail or XEmacs package)."
+  (interactive "r")
+  (if (and base64-internal-encoding-limit
+          (> (- end start) base64-internal-encoding-limit))
+      (base64-external-encode-region start end)
+    (base64-internal-encode-region start end)))
+
+(defun base64-decode-region (start end)
+  "Decode current region by base64.
+START and END are buffer positions.
+This function calls internal base64 decoder if size of region is
+smaller than `base64-internal-decoding-limit', otherwise it calls
+external base64 decoder specified by `base64-external-decoder'.  In
+this case, you must install the program (maybe mmencode included in
+metamail or XEmacs package)."
+  (interactive "r")
+  (if (and base64-internal-decoding-limit
+          (> (- end start) base64-internal-decoding-limit))
+      (base64-external-decode-region start end)
+    (base64-internal-decode-region start end)))
+
+(defun base64-decode-string (string)
+  "Decode STRING which is encoded in base64, and return the result.
+This function calls internal base64 decoder if size of STRING is
+smaller than `base64-internal-decoding-limit', otherwise it calls
+external base64 decoder specified by `base64-external-decoder'.  In
+this case, you must install the program (maybe mmencode included in
+metamail or XEmacs package)."
+  (interactive "r")
+  (if (and base64-internal-decoding-limit
+          (> (length string) base64-internal-decoding-limit))
+      (base64-external-decode-string string)
+    (base64-internal-decode-string string)))
+
+
+(mel-define-method-function (mime-encode-string string (nil "base64"))
+                           'base64-encode-string)
+(mel-define-method-function (mime-decode-string string (nil "base64"))
+                           'base64-decode-string)
+(mel-define-method-function (mime-encode-region start end (nil "base64"))
+                           'base64-encode-region)
+(mel-define-method-function (mime-decode-region start end (nil "base64"))
+                           'base64-decode-region)
+
+(mel-define-method-function (encoded-text-encode-string string (nil "B"))
+                           'base64-encode-string)
+
+(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)))
+      (base64-decode-string string)
+    (error "Invalid encoded-text %s" string)))
+
+(defun base64-insert-encoded-file (filename)

   "Encode contents of file FILENAME to base64, and insert the result.
 It calls external base64 encoder specified by
 `base64-external-encoder'.  So you must install the program (maybe
 mmencode included in metamail or XEmacs package)."
   (interactive (list (read-file-name "Insert encoded file: ")))
   "Encode contents of file FILENAME to base64, and insert the result.
 It calls external base64 encoder specified by
 `base64-external-encoder'.  So you must install the program (maybe
 mmencode included in metamail or XEmacs package)."
   (interactive (list (read-file-name "Insert encoded file: ")))

-  (apply (function call-process) (car base64-external-encoder)
-         filename t nil (cdr base64-external-encoder))
-  )
-
-(defun base64-internal-insert-encoded-file (filename)
-  "Encode contents of file FILENAME to base64, and insert the result."
-  (interactive (list (read-file-name "Insert encoded file: ")))
-  (insert
-   (base64-internal-encode-string
-    (with-temp-buffer
-      (insert-file-contents-as-binary filename)
-      (buffer-string))))
-  (or (bolp)
-      (insert "\n"))
-   )
-
-(defun base64-external-write-decoded-region (start end filename)
-  "Decode and write current region encoded by base64 into FILENAME.
-START and END are buffer positions."
-  (interactive
-   (list (region-beginning) (region-end)
-        (read-file-name "Write decoded region to file: ")))
-  (as-binary-process
-   (apply (function call-process-region)
-          start end (car base64-external-decoder)
-          nil nil nil
-          (append (cdr base64-external-decoder)
-                  base64-external-decoder-option-to-specify-file
-                  (list filename)))))
-
-(defun base64-internal-write-decoded-region (start end filename)
+  (if (and base64-internal-encoding-limit
+          (> (nth 7 (file-attributes filename))
+             base64-internal-encoding-limit))
+      (apply (function call-process) (car base64-external-encoder)
+            filename t nil (cdr base64-external-encoder))
+    (insert
+     (base64-encode-string
+      (with-temp-buffer
+       (set-buffer-multibyte nil)
+       (insert-file-contents-as-binary filename)
+       (buffer-string))))
+    (or (bolp)
+       (insert "\n"))
+     ))
+
+(mel-define-method-function (mime-insert-encoded-file filename (nil "base64"))
+                           'base64-insert-encoded-file)
+
+(defun base64-write-decoded-region (start end filename)

   "Decode and write current region encoded by base64 into FILENAME.
 START and END are buffer positions."
   (interactive
    (list (region-beginning) (region-end)
         (read-file-name "Write decoded region to file: ")))
   "Decode and write current region encoded by base64 into FILENAME.
 START and END are buffer positions."
   (interactive
    (list (region-beginning) (region-end)
         (read-file-name "Write decoded region to file: ")))

-  (let ((str (buffer-substring start end)))
-    (with-temp-buffer
-      (insert (base64-internal-decode-string str))
-      (write-region-as-binary (point-min) (point-max) filename))))
-
+  (if (and base64-internal-decoding-limit
+          (> (- end start) base64-internal-decoding-limit))
+      (as-binary-process
+       (apply (function call-process-region)
+             start end (car base64-external-decoder)
+             nil nil nil
+             (append (cdr base64-external-decoder)
+                     base64-external-decoder-option-to-specify-file
+                     (list filename))))
+    (let ((str (buffer-substring start end)))
+      (with-temp-buffer
+       (insert (base64-internal-decode-string str))
+       (write-region-as-binary (point-min) (point-max) filename)
+       ))))
+
+(mel-define-method-function
+ (mime-write-decoded-region start end filename (nil "base64"))
+ 'base64-write-decoded-region)
+
+       

 ;;; @ etc
 ;;;
 
 ;;; @ etc
 ;;;
 

-(defun base64-internal-encoded-length (string)
-  (* (/ (+ (length string) 2) 3) 4))
-

 (defun pack-sequence (seq size)
   "Split sequence SEQ into SIZE elements packs,
 and return list of packs. [mel-b; tl-seq function]"
 (defun pack-sequence (seq size)
   "Split sequence SEQ into SIZE elements packs,
 and return list of packs. [mel-b; tl-seq function]"