mel-b.el

   1 ;;;
   2 ;;; mel-b.el: Base64 encoder/decoder for GNU Emacs
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995,1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;;; Created: 1995/6/24
  10 ;;; Version:
  11 ;;;     $Id: mel-b.el,v 3.2 1996/01/09 18:25:22 morioka Exp $
  12 ;;; Keywords: MIME, Base64
  13 ;;;
  14 ;;; This file is part of MEL (MIME Encoding Library).
  15 ;;;
  16 ;;; This program is free software; you can redistribute it and/or
  17 ;;; modify it under the terms of the GNU General Public License as
  18 ;;; published by the Free Software Foundation; either version 2, or
  19 ;;; (at your option) any later version.
  20 ;;;
  21 ;;; This program is distributed in the hope that it will be useful,
  22 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 ;;; General Public License for more details.
  25 ;;;
  26 ;;; You should have received a copy of the GNU General Public License
  27 ;;; along with This program.  If not, write to the Free Software
  28 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  29 ;;;
  30 ;;; Code:
  31
  32
  33 ;;; @ variables
  34 ;;;
  35
  36 (defvar base64-external-encoder '("mmencode")
  37   "*list of base64 encoder program name and its arguments.")
  38
  39 (defvar base64-external-decoder '("mmencode" "-u")
  40   "*list of base64 decoder program name and its arguments.")
  41
  42 (defvar base64-internal-encoding-limit 1000
  43   "*limit size to use internal base64 encoder.
  44 If size of input to encode is larger than this limit,
  45 external encoder is called.")
  46
  47 (defvar base64-internal-decoding-limit 1000
  48   "*limit size to use internal base64 decoder.
  49 If size of input to decode is larger than this limit,
  50 external decoder is called.")
  51
  52
  53 ;;; @ internal base64 decoder/encoder
  54 ;;;     based on base64 decoder by Enami Tsugutomo
  55
  56 ;;; @@ convert from/to base64 char
  57 ;;;
  58
  59 (defun base64-num-to-char (n)
  60   (cond ((eq n nil) ?=)
  61         ((< n 26) (+ ?A n))
  62         ((< n 52) (+ ?a (- n 26)))
  63         ((< n 62) (+ ?0 (- n 52)))
  64         ((= n 62) ?+)
  65         ((= n 63) ?/)
  66         (t (error "not a base64 integer %d" n))))
  67
  68 (defun base64-char-to-num (c)
  69   (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
  70         ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
  71         ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
  72         ((= c ?+) 62)
  73         ((= c ?/) 63)
  74         ((= c ?=) nil)
  75         (t (error "not a base64 character %c" c))))
  76
  77
  78 ;;; @@ encode/decode one base64 unit
  79 ;;;
  80
  81 (defun base64-mask (i n) (logand i (1- (ash 1 n))))
  82
  83 (defun base64-encode-1 (a &optional b &optional c)
  84   (cons (ash a -2)
  85         (cons (logior (ash (base64-mask a 2) (- 6 2))
  86                       (if b (ash b -4) 0))
  87               (if b
  88                   (cons (logior (ash (base64-mask b 4) (- 6 4))
  89                                 (if c (ash c -6) 0))
  90                         (if c
  91                             (cons (base64-mask c (- 6 0))
  92                                   nil)))))))
  93
  94 (defun base64-decode-1 (a b &optional c &optional d)
  95   (cons (logior (ash a 2) (ash b (- 2 6)))
  96         (if c (cons (logior (ash (base64-mask b 4) 4)
  97                             (base64-mask (ash c (- 4 6)) 4))
  98                     (if d (cons (logior (ash (base64-mask c 2) 6) d)
  99                                 nil))))))
 100
 101 (defun base64-encode-chars (a &optional b &optional c)
 102   (mapcar (function base64-num-to-char) (base64-encode-1 a b c)))
 103
 104 (defun base64-decode-chars (&rest args)
 105   (apply (function base64-decode-1)
 106          (mapcar (function base64-char-to-num) args)
 107          ))
 108
 109
 110 ;;; @@ encode/decode base64 string
 111 ;;;
 112
 113 (defun base64-encode-string (string)
 114   (let ((len (length string))
 115         (b 0)(e 57)
 116         dest)
 117     (while (< e len)
 118       (setq dest
 119             (concat dest
 120                     (mapconcat
 121                      (function
 122                       (lambda (pack)
 123                         (mapconcat (function char-to-string)
 124                                    (apply (function base64-encode-chars) pack)
 125                                    "")
 126                         ))
 127                      (pack-sequence (substring string b e) 3)
 128                      "")
 129                     "\n"))
 130       (setq b e
 131             e (+ e 57)
 132             )
 133       )
 134     (let* ((es (mapconcat
 135                 (function
 136                  (lambda (pack)
 137                    (mapconcat (function char-to-string)
 138                               (apply (function base64-encode-chars) pack)
 139                               "")
 140                    ))
 141                 (pack-sequence (substring string b) 3)
 142                 ""))
 143            (m (mod (length es) 4))
 144            )
 145       (concat dest es (cond ((= m 3) "=")
 146                             ((= m 2) "==")
 147                             ))
 148       )))
 149
 150 (defun base64-decode-string (string)
 151   (mapconcat (function
 152               (lambda (pack)
 153                 (mapconcat (function char-to-string)
 154                            (apply (function base64-decode-chars) pack)
 155                            "")
 156                 ))
 157              (pack-sequence string 4)
 158              ""))
 159
 160
 161 ;;; @ encode/decode base64 region
 162 ;;;
 163
 164 (defun base64-internal-encode-region (beg end)
 165   (save-excursion
 166     (save-restriction
 167       (narrow-to-region beg end)
 168       (let ((str (buffer-substring beg end)))
 169         (delete-region beg end)
 170         (insert (base64-encode-string str))
 171         )
 172       (or (bolp)
 173           (insert "\n")
 174           )
 175       )))
 176
 177 (defun base64-internal-decode-region (beg end)
 178   (save-excursion
 179     (save-restriction
 180       (narrow-to-region beg end)
 181       (goto-char (point-min))
 182       (while (search-forward "\n" nil t)
 183         (replace-match "")
 184         )
 185       (let ((str (buffer-substring (point-min)(point-max))))
 186         (delete-region (point-min)(point-max))
 187         (insert (base64-decode-string str))
 188         ))))
 189
 190 (cond ((boundp 'MULE)
 191        (define-program-coding-system
 192          nil (car base64-external-encoder) *noconv*)
 193        (define-program-coding-system
 194          nil (car base64-external-decoder) *noconv*)
 195        )
 196       ((boundp 'NEMACS)
 197        (define-program-kanji-code
 198          nil (car base64-external-encoder) 0)
 199        (define-program-kanji-code
 200          nil (car base64-external-decoder) 0)
 201        ))
 202
 203 (defun base64-external-encode-region (beg end)
 204   (save-excursion
 205     (save-restriction
 206       (narrow-to-region beg end)
 207       (let ((selective-display nil) ;Disable ^M to nl translation.
 208             (mc-flag nil)      ;Mule
 209             (kanji-flag nil))  ;NEmacs
 210         (apply (function call-process-region)
 211                beg end (car base64-external-encoder)
 212                t t nil (cdr base64-external-encoder))
 213         )
 214       ;; for OS/2
 215       ;;   regularize line break code
 216       (goto-char (point-min))
 217       (while (re-search-forward "\r$" nil t)
 218         (replace-match "")
 219         )
 220       )))
 221
 222 (defun base64-external-decode-region (beg end)
 223   (save-excursion
 224     (let ((selective-display nil) ;Disable ^M to nl translation.
 225           (mc-flag nil)      ;Mule
 226           (kanji-flag nil))  ;NEmacs
 227       (apply (function call-process-region)
 228              beg end (car base64-external-decoder)
 229              t t nil (cdr base64-external-decoder))
 230       )))
 231
 232 (defun base64-encode-region (beg end)
 233   (interactive "r")
 234   (if (and base64-internal-encoding-limit
 235            (> (- end beg) base64-internal-encoding-limit))
 236       (base64-external-encode-region beg end)
 237     (base64-internal-encode-region beg end)
 238     ))
 239
 240 (defun base64-decode-region (beg end)
 241   (interactive "r")
 242   (if (and base64-internal-decoding-limit
 243            (> (- end beg) base64-internal-decoding-limit))
 244       (base64-external-decode-region beg end)
 245     (base64-internal-decode-region beg end)
 246     ))
 247
 248
 249 ;;; @ etc
 250 ;;;
 251
 252 (defun base64-encoded-length (string)
 253   (let ((len (length string)))
 254     (* (+ (/ len 3)
 255           (if (= (mod len 3) 0) 0 1)
 256           ) 4)
 257     ))
 258
 259 (defun pack-sequence (seq size)
 260   "Split sequence SEQ into SIZE elements packs,
 261 and return list of packs. [mel-b; tl-seq function]"
 262   (let ((len (length seq)) (p 0) obj
 263         unit (i 0)
 264         dest)
 265     (while (< p len)
 266       (setq obj (elt seq p))
 267       (setq unit (cons obj unit))
 268       (setq i (1+ i))
 269       (if (= i size)
 270           (progn
 271             (setq dest (cons (reverse unit) dest))
 272             (setq unit nil)
 273             (setq i 0)
 274             ))
 275       (setq p (1+ p))
 276       )
 277     (if unit
 278         (setq dest (cons (reverse unit) dest))
 279       )
 280     (reverse dest)
 281     ))
 282
 283
 284 ;;; @ end
 285 ;;;
 286
 287 (provide 'mel-b)