mel-b.el

   1 ;;; mel-b.el: Base64 encoder/decoder for GNU Emacs
   2
   3 ;; Copyright (C) 1992,1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
   6 ;;         MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;; Created: 1995/6/24
   9 ;; Version: $Id: mel-b.el,v 6.3 1997/04/30 17:17:42 morioka Exp $
  10 ;; Keywords: MIME, Base64
  11
  12 ;; This file is part of MEL (MIME Encoding Library).
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Code:
  30
  31 (require 'emu)
  32
  33
  34 ;;; @ variables
  35 ;;;
  36
  37 (defvar base64-external-encoder '("mmencode")
  38   "*list of base64 encoder program name and its arguments.")
  39
  40 (defvar base64-external-decoder '("mmencode" "-u")
  41   "*list of base64 decoder program name and its arguments.")
  42
  43 (defvar base64-internal-encoding-limit 1000
  44   "*limit size to use internal base64 encoder.
  45 If size of input to encode is larger than this limit,
  46 external encoder is called.")
  47
  48 (defvar base64-internal-decoding-limit 1000
  49   "*limit size to use internal base64 decoder.
  50 If size of input to decode is larger than this limit,
  51 external decoder is called.")
  52
  53
  54 ;;; @ internal base64 decoder/encoder
  55 ;;;     based on base64 decoder by Enami Tsugutomo
  56
  57 ;;; @@ convert from/to base64 char
  58 ;;;
  59
  60 (defun base64-num-to-char (n)
  61   (cond ((eq n nil) ?=)
  62         ((< n 26) (+ ?A n))
  63         ((< n 52) (+ ?a (- n 26)))
  64         ((< n 62) (+ ?0 (- n 52)))
  65         ((= n 62) ?+)
  66         ((= n 63) ?/)
  67         (t (error "not a base64 integer %d" n))))
  68
  69 (defun base64-char-to-num (c)
  70   (cond ((and (<= ?A c) (<= c ?Z)) (- c ?A))
  71         ((and (<= ?a c) (<= c ?z)) (+ (- c ?a) 26))
  72         ((and (<= ?0 c) (<= c ?9)) (+ (- c ?0) 52))
  73         ((= c ?+) 62)
  74         ((= c ?/) 63)
  75         ((= c ?=) nil)
  76         (t (error "not a base64 character %c" c))))
  77
  78
  79 ;;; @@ encode/decode one base64 unit
  80 ;;;
  81
  82 (defun base64-encode-1 (pack)
  83   (let ((a (car pack))
  84         (b (nth 1 pack))
  85         (c (nth 2 pack)))
  86     (concat
  87      (char-to-string (base64-num-to-char (ash a -2)))
  88      (if b
  89          (concat
  90           (char-to-string
  91            (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4))))
  92           (if c
  93               (concat
  94                (char-to-string
  95                 (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6))))
  96                (char-to-string (base64-num-to-char (logand c 63)))
  97                )
  98             (concat (char-to-string
  99                      (base64-num-to-char (ash (logand b 15) 2))) "=")
 100             ))
 101        (concat (char-to-string
 102                 (base64-num-to-char (ash (logand a 3) 4))) "==")
 103        ))))
 104
 105 (defun base64-decode-1 (pack)
 106   (let ((a (base64-char-to-num (car pack)))
 107         (b (base64-char-to-num (nth 1 pack)))
 108         (c (nth 2 pack))
 109         (d (nth 3 pack)))
 110     (concat (char-to-string (logior (ash a 2) (ash b -4)))
 111             (if (and c (setq c (base64-char-to-num c)))
 112                 (concat (char-to-string
 113                          (logior (ash (logand b 15) 4) (ash c -2)))
 114                         (if (and d (setq d (base64-char-to-num d)))
 115                             (char-to-string (logior (ash (logand c 3) 6) d))
 116                           ))))))
 117
 118
 119 ;;; @@ base64 encoder/decoder for string
 120 ;;;
 121
 122 (defun base64-encode-string (string)
 123   "Encode STRING to base64, and return the result."
 124   (let ((len (length string))
 125         (b 0)(e 57)
 126         dest)
 127     (while (< e len)
 128       (setq dest
 129             (concat dest
 130                     (mapconcat
 131                      (function base64-encode-1)
 132                      (pack-sequence (substring string b e) 3)
 133                      "")
 134                     "\n"))
 135       (setq b e
 136             e (+ e 57)
 137             )
 138       )
 139     (let* ((es (mapconcat
 140                 (function base64-encode-1)
 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   "Decode STRING which is encoded in base64, and return the result."
 152   (mapconcat (function base64-decode-1)
 153              (pack-sequence string 4)
 154              ""))
 155
 156
 157 ;;; @ base64 encoder/decoder for region
 158 ;;;
 159
 160 (defun base64-internal-encode-region (beg end)
 161   (save-excursion
 162     (save-restriction
 163       (narrow-to-region beg end)
 164       (let ((str (buffer-substring beg end)))
 165         (delete-region beg end)
 166         (insert (base64-encode-string str))
 167         )
 168       (or (bolp)
 169           (insert "\n")
 170           )
 171       )))
 172
 173 (defun base64-internal-decode-region (beg end)
 174   (save-excursion
 175     (save-restriction
 176       (narrow-to-region beg end)
 177       (goto-char (point-min))
 178       (while (looking-at ".*\n")
 179         (condition-case err
 180             (replace-match
 181              (base64-decode-string
 182               (buffer-substring (match-beginning 0) (1- (match-end 0))))
 183              t t)
 184           (error
 185            (prog1
 186                (message (nth 1 err))
 187              (replace-match "")))))
 188       (if (looking-at ".*$")
 189           (condition-case err
 190               (replace-match
 191                (base64-decode-string
 192                 (buffer-substring (match-beginning 0) (match-end 0)))
 193                t t)
 194             (error
 195              (prog1
 196                  (message (nth 1 err))
 197                (replace-match "")))
 198             ))
 199       )))
 200
 201 (defun base64-external-encode-region (beg end)
 202   (save-excursion
 203     (save-restriction
 204       (narrow-to-region beg end)
 205       (as-binary-process (apply (function call-process-region)
 206                                 beg end (car base64-external-encoder)
 207                                 t t nil (cdr base64-external-encoder))
 208                          )
 209       ;; for OS/2
 210       ;;   regularize line break code
 211       (goto-char (point-min))
 212       (while (re-search-forward "\r$" nil t)
 213         (replace-match "")
 214         )
 215       )))
 216
 217 (defun base64-external-decode-region (beg end)
 218   (save-excursion
 219     (as-binary-process (apply (function call-process-region)
 220                               beg end (car base64-external-decoder)
 221                               t t nil (cdr base64-external-decoder))
 222                        )))
 223
 224 (defun base64-encode-region (start end)
 225   "Encode current region by base64.
 226 START and END are buffer positions.
 227 This function calls internal base64 encoder if size of region is
 228 smaller than `base64-internal-encoding-limit', otherwise it calls
 229 external base64 encoder specified by `base64-external-encoder'.  In
 230 this case, you must install the program (maybe mmencode included in
 231 metamail or XEmacs package)."
 232   (interactive "r")
 233   (if (and base64-internal-encoding-limit
 234            (> (- end start) base64-internal-encoding-limit))
 235       (base64-external-encode-region start end)
 236     (base64-internal-encode-region start end)
 237     ))
 238
 239 (defun base64-decode-region (start end)
 240   "Decode current region by base64.
 241 START and END are buffer positions.
 242 This function calls internal base64 decoder if size of region is
 243 smaller than `base64-internal-decoding-limit', otherwise it calls
 244 external base64 decoder specified by `base64-external-decoder'.  In
 245 this case, you must install the program (maybe mmencode included in
 246 metamail or XEmacs package)."
 247   (interactive "r")
 248   (if (and base64-internal-decoding-limit
 249            (> (- end start) base64-internal-decoding-limit))
 250       (base64-external-decode-region start end)
 251     (base64-internal-decode-region start end)
 252     ))
 253
 254
 255 ;;; @ base64 encoder/decoder for file
 256 ;;;
 257
 258 (defun base64-insert-encoded-file (filename)
 259   "Encode contents of file FILENAME to base64, and insert the result.
 260 It calls external base64 encoder specified by
 261 `base64-external-encoder'.  So you must install the program (maybe
 262 mmencode included in metamail or XEmacs package)."
 263   (interactive (list (read-file-name "Insert encoded file: ")))
 264   (apply (function call-process) (car base64-external-encoder)
 265          filename t nil (cdr base64-external-encoder))
 266   )
 267
 268
 269 ;;; @ etc
 270 ;;;
 271
 272 (defun base64-encoded-length (string)
 273   (let ((len (length string)))
 274     (* (+ (/ len 3)
 275           (if (= (mod len 3) 0) 0 1)
 276           ) 4)
 277     ))
 278
 279 (defun pack-sequence (seq size)
 280   "Split sequence SEQ into SIZE elements packs,
 281 and return list of packs. [mel-b; tl-seq function]"
 282   (let ((len (length seq)) (p 0) obj
 283         unit (i 0)
 284         dest)
 285     (while (< p len)
 286       (setq obj (elt seq p))
 287       (setq unit (cons obj unit))
 288       (setq i (1+ i))
 289       (if (= i size)
 290           (progn
 291             (setq dest (cons (reverse unit) dest))
 292             (setq unit nil)
 293             (setq i 0)
 294             ))
 295       (setq p (1+ p))
 296       )
 297     (if unit
 298         (setq dest (cons (reverse unit) dest))
 299       )
 300     (reverse dest)
 301     ))
 302
 303
 304 ;;; @ end
 305 ;;;
 306
 307 (provide 'mel-b)
 308
 309 ;;; mel-b.el ends here.