mel-b.el

   1 ;;;
   2 ;;; $Id: mel-b.el,v 2.0 1995/10/25 02:40:49 morioka Exp $
   3 ;;;
   4
   5 ;;; @ variables
   6 ;;;
   7
   8 (defvar base64-external-encoder '("mmencode")
   9   "*list of base64 encoder program name and its arguments.")
  10
  11 (defvar base64-external-decoder '("mmencode" "-u")
  12   "*list of base64 decoder program name and its arguments.")
  13
  14 (defvar base64-internal-encoding-limit 1000
  15   "*limit size to use internal base64 encoder.
  16 If size of input to encode is larger than this limit,
  17 external encoder is called.")
  18
  19 (defvar base64-internal-decoding-limit 1000
  20   "*limit size to use internal base64 decoder.
  21 If size of input to decode is larger than this limit,
  22 external decoder is called.")
  23
  24
  25 ;;; @ internal base64 decoder/encoder
  26 ;;;     based on base64 decoder by Enami Tsugutomo
  27
  28 ;;; @@ convert from/to base64 char
  29 ;;;
  30
  31 (defun base64-num-to-char (n)
  32   (cond ((eq n nil) ?=)
  33         ((< n 26) (+ ?A n))
  34         ((< n 52) (+ ?a (- n 26)))
  35         ((< n 62) (+ ?0 (- n 52)))
  36         ((= n 62) ?+)
  37         ((= n 63) ?/)
  38         (t (error "not a base64 integer %d" n))))
  39
  40 (defun base64-char-to-num (c)
  41   (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
  42         ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
  43         ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
  44         ((= c ?+) 62)
  45         ((= c ?/) 63)
  46         ((= c ?=) nil)
  47         (t (error "not a base64 character %c" c))))
  48
  49
  50 ;;; @@ encode/decode one base64 unit
  51 ;;;
  52
  53 (defun base64-mask (i n) (logand i (1- (ash 1 n))))
  54
  55 (defun base64-encode-1 (a &optional b &optional c)
  56   (cons (ash a -2)
  57         (cons (logior (ash (base64-mask a 2) (- 6 2))
  58                       (if b (ash b -4) 0))
  59               (if b
  60                   (cons (logior (ash (base64-mask b 4) (- 6 4))
  61                                 (if c (ash c -6) 0))
  62                         (if c
  63                             (cons (base64-mask c (- 6 0))
  64                                   nil)))))))
  65
  66 (defun base64-decode-1 (a b &optional c &optional d)
  67   (cons (logior (ash a 2) (ash b (- 2 6)))
  68         (if c (cons (logior (ash (base64-mask b 4) 4)
  69                             (base64-mask (ash c (- 4 6)) 4))
  70                     (if d (cons (logior (ash (base64-mask c 2) 6) d)
  71                                 nil))))))
  72
  73 (defun base64-encode-chars (a &optional b &optional c)
  74   (mapcar (function base64-num-to-char) (base64-encode-1 a b c)))
  75
  76 (defun base64-decode-chars (&rest args)
  77   (apply (function base64-decode-1)
  78          (mapcar (function base64-char-to-num) args)
  79          ))
  80
  81
  82 ;;; @@ encode/decode base64 string
  83 ;;;
  84
  85 (defun base64-encode-string (string)
  86   (let* ((es (mapconcat
  87               (function
  88                (lambda (pack)
  89                  (mapconcat (function char-to-string)
  90                             (apply (function base64-encode-chars) pack)
  91                             "")
  92                  ))
  93               (pack-sequence string 3)
  94               ""))
  95          (m (mod (length es) 4))
  96          )
  97     (concat es (cond ((= m 3) "=")
  98                      ((= m 2) "==")
  99                      ))
 100     ))
 101
 102 (defun base64-decode-string (string)
 103   (mapconcat (function
 104               (lambda (pack)
 105                 (mapconcat (function char-to-string)
 106                            (apply (function base64-decode-chars) pack)
 107                            "")
 108                 ))
 109              (pack-sequence string 4)
 110              ""))
 111
 112
 113 ;;; @ encode/decode base64 region
 114 ;;;
 115
 116 (defun base64-internal-decode-region (beg end)
 117   (save-excursion
 118     (save-restriction
 119       (narrow-to-region beg end)
 120       (goto-char (point-min))
 121       (while (search-forward "\n" nil t)
 122         (replace-match "")
 123         )
 124       (let ((str (buffer-substring (point-min)(point-max))))
 125         (delete-region (point-min)(point-max))
 126         (insert (base64-decode-string str))
 127         ))))
 128
 129 (defun base64-internal-encode-region (beg end)
 130   (save-excursion
 131     (let* ((str (base64-encode-string (buffer-substring beg end)))
 132            (len (length str))
 133            (i 0)
 134            (j (if (>= len 76)
 135                   76
 136                 len))
 137            )
 138       (delete-region beg end)
 139       (goto-char beg)
 140       (while (< j len)
 141         (insert (substring str i j))
 142         (insert "\n")
 143         (setq i j)
 144         (setq j (+ i 76))
 145         )
 146       (insert (substring str i))
 147       )))
 148
 149 (cond ((boundp 'MULE)
 150        (define-program-coding-system
 151          nil (car base64-external-encoder) *noconv*)
 152        (define-program-coding-system
 153          nil (car base64-external-decoder) *noconv*)
 154        )
 155       ((boundp 'NEMACS)
 156        (define-program-kanji-code
 157          nil (car base64-external-encoder) 0)
 158        (define-program-kanji-code
 159          nil (car base64-external-decoder) 0)
 160        ))
 161
 162 (defun base64-external-encode-region (beg end)
 163   (save-excursion
 164     (let ((selective-display nil) ;Disable ^M to nl translation.
 165           (mc-flag nil)      ;Mule
 166           (kanji-flag nil))  ;NEmacs
 167       (apply (function call-process-region)
 168              beg end (car base64-external-encoder)
 169              t t nil (cdr base64-external-encoder))
 170       )))
 171
 172 (defun base64-external-decode-region (beg end)
 173   (save-excursion
 174     (let ((selective-display nil) ;Disable ^M to nl translation.
 175           (mc-flag nil)      ;Mule
 176           (kanji-flag nil))  ;NEmacs
 177       (apply (function call-process-region)
 178              beg end (car base64-external-decoder)
 179              t t nil (cdr base64-external-decoder))
 180       )))
 181
 182 (defun base64-encode-region (beg end)
 183   (interactive "r")
 184   (if (and base64-internal-encoding-limit
 185            (> (- end beg) base64-internal-encoding-limit))
 186       (base64-external-encode-region beg end)
 187     (base64-internal-encode-region beg end)
 188     ))
 189
 190 (defun base64-decode-region (beg end)
 191   (interactive "r")
 192   (if (and base64-internal-decoding-limit
 193            (> (- end beg) base64-internal-decoding-limit))
 194       (base64-external-decode-region beg end)
 195     (base64-internal-decode-region beg end)
 196     ))
 197
 198
 199 ;;; @ etc
 200 ;;;
 201
 202 (defun base64-encoded-length (string)
 203   (let ((len (length string)))
 204     (* (+ (/ len 3)
 205           (if (= (mod len 3) 0) 0 1)
 206           ) 4)
 207     ))
 208
 209 (defun pack-sequence (seq size)
 210   "Split sequence SEQ into SIZE elements packs,
 211 and return list of packs. [mel-b; tl-seq function]"
 212   (let ((len (length seq)) (p 0) obj
 213         unit (i 0)
 214         dest)
 215     (while (< p len)
 216       (setq obj (elt seq p))
 217       (setq unit (cons obj unit))
 218       (setq i (1+ i))
 219       (if (= i size)
 220           (progn
 221             (setq dest (cons (reverse unit) dest))
 222             (setq unit nil)
 223             (setq i 0)
 224             ))
 225       (setq p (1+ p))
 226       )
 227     (if unit
 228         (setq dest (cons (reverse unit) dest))
 229       )
 230     (reverse dest)
 231     ))
 232
 233 (provide 'mel-b)