mel-b.el

   1 ;;;
   2 ;;; $Id: mel-b.el,v 3.0 1995/11/02 04:14:51 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 ((len (length string))
  87         (b 0)(e 57)
  88         dest)
  89     (while (< e len)
  90       (setq dest
  91             (concat dest
  92                     (mapconcat
  93                      (function
  94                       (lambda (pack)
  95                         (mapconcat (function char-to-string)
  96                                    (apply (function base64-encode-chars) pack)
  97                                    "")
  98                         ))
  99                      (pack-sequence (substring string b e) 3)
 100                      "")
 101                     "\n"))
 102       (setq b e
 103             e (+ e 57)
 104             )
 105       )
 106     (let* ((es (mapconcat
 107                 (function
 108                  (lambda (pack)
 109                    (mapconcat (function char-to-string)
 110                               (apply (function base64-encode-chars) pack)
 111                               "")
 112                    ))
 113                 (pack-sequence (substring string b) 3)
 114                 ""))
 115            (m (mod (length es) 4))
 116            )
 117       (concat dest es (cond ((= m 3) "=")
 118                             ((= m 2) "==")
 119                             ))
 120       )))
 121
 122 (defun base64-decode-string (string)
 123   (mapconcat (function
 124               (lambda (pack)
 125                 (mapconcat (function char-to-string)
 126                            (apply (function base64-decode-chars) pack)
 127                            "")
 128                 ))
 129              (pack-sequence string 4)
 130              ""))
 131
 132
 133 ;;; @ encode/decode base64 region
 134 ;;;
 135
 136 (defun base64-internal-encode-region (beg end)
 137   (save-excursion
 138     (save-restriction
 139       (narrow-to-region beg end)
 140       (let ((str (buffer-substring beg end)))
 141         (delete-region beg end)
 142         (insert (base64-encode-string str))
 143         )
 144       (or (bolp)
 145           (insert "\n")
 146           )
 147       )))
 148
 149 (defun base64-internal-decode-region (beg end)
 150   (save-excursion
 151     (save-restriction
 152       (narrow-to-region beg end)
 153       (goto-char (point-min))
 154       (while (search-forward "\n" nil t)
 155         (replace-match "")
 156         )
 157       (let ((str (buffer-substring (point-min)(point-max))))
 158         (delete-region (point-min)(point-max))
 159         (insert (base64-decode-string str))
 160         ))))
 161
 162 (cond ((boundp 'MULE)
 163        (define-program-coding-system
 164          nil (car base64-external-encoder) *noconv*)
 165        (define-program-coding-system
 166          nil (car base64-external-decoder) *noconv*)
 167        )
 168       ((boundp 'NEMACS)
 169        (define-program-kanji-code
 170          nil (car base64-external-encoder) 0)
 171        (define-program-kanji-code
 172          nil (car base64-external-decoder) 0)
 173        ))
 174
 175 (defun base64-external-encode-region (beg end)
 176   (save-excursion
 177     (save-restriction
 178       (narrow-to-region beg end)
 179       (let ((selective-display nil) ;Disable ^M to nl translation.
 180             (mc-flag nil)      ;Mule
 181             (kanji-flag nil))  ;NEmacs
 182         (apply (function call-process-region)
 183                beg end (car base64-external-encoder)
 184                t t nil (cdr base64-external-encoder))
 185         )
 186       ;; for OS/2
 187       ;;   regularize line break code
 188       (goto-char (point-min))
 189       (while (re-search-forward "\r$" nil t)
 190         (replace-match "")
 191         )
 192       )))
 193
 194 (defun base64-external-decode-region (beg end)
 195   (save-excursion
 196     (let ((selective-display nil) ;Disable ^M to nl translation.
 197           (mc-flag nil)      ;Mule
 198           (kanji-flag nil))  ;NEmacs
 199       (apply (function call-process-region)
 200              beg end (car base64-external-decoder)
 201              t t nil (cdr base64-external-decoder))
 202       )))
 203
 204 (defun base64-encode-region (beg end)
 205   (interactive "r")
 206   (if (and base64-internal-encoding-limit
 207            (> (- end beg) base64-internal-encoding-limit))
 208       (base64-external-encode-region beg end)
 209     (base64-internal-encode-region beg end)
 210     ))
 211
 212 (defun base64-decode-region (beg end)
 213   (interactive "r")
 214   (if (and base64-internal-decoding-limit
 215            (> (- end beg) base64-internal-decoding-limit))
 216       (base64-external-decode-region beg end)
 217     (base64-internal-decode-region beg end)
 218     ))
 219
 220
 221 ;;; @ etc
 222 ;;;
 223
 224 (defun base64-encoded-length (string)
 225   (let ((len (length string)))
 226     (* (+ (/ len 3)
 227           (if (= (mod len 3) 0) 0 1)
 228           ) 4)
 229     ))
 230
 231 (defun pack-sequence (seq size)
 232   "Split sequence SEQ into SIZE elements packs,
 233 and return list of packs. [mel-b; tl-seq function]"
 234   (let ((len (length seq)) (p 0) obj
 235         unit (i 0)
 236         dest)
 237     (while (< p len)
 238       (setq obj (elt seq p))
 239       (setq unit (cons obj unit))
 240       (setq i (1+ i))
 241       (if (= i size)
 242           (progn
 243             (setq dest (cons (reverse unit) dest))
 244             (setq unit nil)
 245             (setq i 0)
 246             ))
 247       (setq p (1+ p))
 248       )
 249     (if unit
 250         (setq dest (cons (reverse unit) dest))
 251       )
 252     (reverse dest)
 253     ))
 254
 255 (provide 'mel-b)