mel-b.el

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