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 (require 'mime-def)
  31
  32
  33 ;;; @ variables
  34 ;;;
  35
  36 (defgroup base64 nil
  37   "Base64 encoder/decoder"
  38   :group 'mime)
  39
  40 (defcustom base64-external-encoder '("mmencode")
  41   "*list of base64 encoder program name and its arguments."
  42   :group 'base64
  43   :type '(cons (file :tag "Command")(repeat :tag "Arguments" string)))
  44
  45 (defcustom base64-external-decoder '("mmencode" "-u")
  46   "*list of base64 decoder program name and its arguments."
  47   :group 'base64
  48   :type '(cons (file :tag "Command")(repeat :tag "Arguments" string)))
  49
  50 (defcustom base64-external-decoder-option-to-specify-file '("-o")
  51   "*list of options of base64 decoder program to specify file."
  52   :group 'base64
  53   :type '(repeat :tag "Arguments" string))
  54
  55 (defcustom base64-internal-encoding-limit 1000
  56   "*limit size to use internal base64 encoder.
  57 If size of input to encode is larger than this limit,
  58 external encoder is called."
  59   :group 'base64
  60   :type '(choice (const :tag "Always use internal encoder" nil)
  61                  (integer :tag "Size")))
  62
  63 (defcustom base64-internal-decoding-limit 70000
  64   "*limit size to use internal base64 decoder.
  65 If size of input to decode is larger than this limit,
  66 external decoder is called."
  67   :group 'base64
  68   :type '(choice (const :tag "Always use internal decoder" nil)
  69                  (integer :tag "Size")))
  70
  71
  72 ;;; @ internal base64 encoder
  73 ;;;     based on base64 decoder by Enami Tsugutomo
  74
  75 (defconst base64-characters
  76   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  77
  78 (defmacro base64-num-to-char (n)
  79   `(aref base64-characters ,n))
  80
  81 (defun base64-encode-1 (pack)
  82   (let ((a (car pack))
  83         (b (nth 1 pack))
  84         (c (nth 2 pack)))
  85     (concat
  86      (char-to-string (base64-num-to-char (ash a -2)))
  87      (if b
  88          (concat
  89           (char-to-string
  90            (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4))))
  91           (if c
  92               (concat
  93                (char-to-string
  94                 (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6))))
  95                (char-to-string (base64-num-to-char (logand c 63)))
  96                )
  97             (concat (char-to-string
  98                      (base64-num-to-char (ash (logand b 15) 2))) "=")
  99             ))
 100        (concat (char-to-string
 101                 (base64-num-to-char (ash (logand a 3) 4))) "==")
 102        ))))
 103
 104 (defun base64-encode-string (string)
 105   "Encode STRING to base64, and return the result."
 106   (let ((len (length string))
 107         (b 0)(e 57)
 108         dest)
 109     (while (< e len)
 110       (setq dest
 111             (concat dest
 112                     (mapconcat
 113                      (function base64-encode-1)
 114                      (pack-sequence (substring string b e) 3)
 115                      "")
 116                     "\n"))
 117       (setq b e
 118             e (+ e 57)
 119             )
 120       )
 121     (let* ((es (mapconcat
 122                 (function base64-encode-1)
 123                 (pack-sequence (substring string b) 3)
 124                 ""))
 125            (m (mod (length es) 4))
 126            )
 127       (concat dest es (cond ((= m 3) "=")
 128                             ((= m 2) "==")
 129                             ))
 130       )))
 131
 132 (defun base64-internal-encode-region (beg end)
 133   (save-excursion
 134     (save-restriction
 135       (narrow-to-region beg end)
 136       (let ((str (buffer-substring beg end)))
 137         (delete-region beg end)
 138         (insert (base64-encode-string str))
 139         )
 140       (or (bolp)
 141           (insert "\n")
 142           )
 143       )))
 144
 145
 146 ;;; @ internal base64 decoder
 147 ;;;
 148
 149 (defconst base64-numbers
 150   `,(let ((len (length base64-characters))
 151           (vec (make-vector 123 nil))
 152           (i 0))
 153       (while (< i len)
 154         (aset vec (aref base64-characters i) i)
 155         (setq i (1+ i)))
 156       vec))
 157
 158 (defmacro base64-char-to-num (c)
 159   `(aref base64-numbers ,c))
 160
 161 (defsubst base64-internal-decode (string buffer)
 162   (let* ((len (length string))
 163          (i 0)
 164          (j 0)
 165          v1 v2 v3)
 166     (catch 'tag
 167       (while (< i len)
 168         (when (prog1 (setq v1 (base64-char-to-num (aref string i)))
 169                 (setq i (1+ i)))
 170           (setq v2 (base64-char-to-num (aref string i))
 171                 i (1+ i)
 172                 v3 (base64-char-to-num (aref string i))
 173                 i (1+ i))
 174           (aset buffer j (logior (lsh v1 2)(lsh v2 -4)))
 175           (setq j (1+ j))
 176           (if v3
 177               (let ((v4 (base64-char-to-num (aref string i))))
 178                 (setq i (1+ i))
 179                 (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2)))
 180                 (setq j (1+ j))
 181                 (if v4
 182                     (aset buffer (prog1 j (setq j (1+ j)))
 183                           (logior (lsh (logand v3 3) 6) v4))
 184                   (throw 'tag nil)
 185                   ))
 186             (throw 'tag nil)
 187             ))))
 188     (substring buffer 0 j)
 189     ))
 190
 191 (defun base64-internal-decode-string (string)
 192   (base64-internal-decode string (make-string (length string) 0)))
 193
 194 (defsubst base64-decode-string! (string)
 195   (base64-internal-decode string string))
 196
 197 (defun base64-internal-decode-region (beg end)
 198   (save-excursion
 199     (let ((str (buffer-substring beg end)))
 200       (delete-region beg end)
 201       (goto-char beg)
 202       (insert (base64-decode-string! str)))))
 203
 204
 205 ;;; @ external encoder/decoder
 206 ;;;
 207
 208 (defun base64-external-encode-region (beg end)
 209   (save-excursion
 210     (save-restriction
 211       (narrow-to-region beg end)
 212       (as-binary-process
 213        (apply (function call-process-region)
 214               beg end (car base64-external-encoder)
 215               t t nil (cdr base64-external-encoder)))
 216       ;; for OS/2
 217       ;;   regularize line break code
 218       (goto-char (point-min))
 219       (while (re-search-forward "\r$" nil t)
 220         (replace-match ""))
 221       )))
 222
 223 (defun base64-external-decode-region (beg end)
 224   (save-excursion
 225     (as-binary-process
 226      (apply (function call-process-region)
 227             beg end (car base64-external-decoder)
 228             t t nil (cdr base64-external-decoder)))
 229     ))
 230
 231 (defun base64-external-decode-string (string)
 232   (with-temp-buffer
 233     (insert string)
 234     (as-binary-process
 235      (apply (function call-process-region)
 236             (point-min) (point-max)
 237             (car base64-external-decoder)
 238             t t nil (cdr base64-external-decoder)))
 239     (buffer-string)))
 240
 241
 242 ;;; @ application interfaces
 243 ;;;
 244
 245 (defun base64-encode-region (start end)
 246   "Encode current region by base64.
 247 START and END are buffer positions.
 248 This function calls internal base64 encoder if size of region is
 249 smaller than `base64-internal-encoding-limit', otherwise it calls
 250 external base64 encoder specified by `base64-external-encoder'.  In
 251 this case, you must install the program (maybe mmencode included in
 252 metamail or XEmacs package)."
 253   (interactive "r")
 254   (if (and base64-internal-encoding-limit
 255            (> (- end start) base64-internal-encoding-limit))
 256       (base64-external-encode-region start end)
 257     (base64-internal-encode-region start end)))
 258
 259 (defun base64-decode-region (start end)
 260   "Decode current region by base64.
 261 START and END are buffer positions.
 262 This function calls internal base64 decoder if size of region is
 263 smaller than `base64-internal-decoding-limit', otherwise it calls
 264 external base64 decoder specified by `base64-external-decoder'.  In
 265 this case, you must install the program (maybe mmencode included in
 266 metamail or XEmacs package)."
 267   (interactive "r")
 268   (if (and base64-internal-decoding-limit
 269            (> (- end start) base64-internal-decoding-limit))
 270       (base64-external-decode-region start end)
 271     (base64-internal-decode-region start end)))
 272
 273 (defun base64-decode-string (string)
 274   "Decode STRING which is encoded in base64, and return the result.
 275 This function calls internal base64 decoder if size of STRING is
 276 smaller than `base64-internal-decoding-limit', otherwise it calls
 277 external base64 decoder specified by `base64-external-decoder'.  In
 278 this case, you must install the program (maybe mmencode included in
 279 metamail or XEmacs package)."
 280   (interactive "r")
 281   (if (and base64-internal-decoding-limit
 282            (> (length string) base64-internal-decoding-limit))
 283       (base64-external-decode-string string)
 284     (base64-internal-decode-string string)))
 285
 286
 287 (mel-define-method-function (mime-encode-string string (nil "base64"))
 288                             'base64-encode-string)
 289 (mel-define-method-function (mime-decode-string string (nil "base64"))
 290                             'base64-decode-string)
 291 (mel-define-method-function (mime-encode-region start end (nil "base64"))
 292                             'base64-encode-region)
 293 (mel-define-method-function (mime-decode-region start end (nil "base64"))
 294                             'base64-decode-region)
 295
 296 (mel-define-method-function (encoded-text-encode-string string (nil "B"))
 297                             'base64-encode-string)
 298
 299 (mel-define-method encoded-text-decode-string (string (nil "B"))
 300   (if (and (string-match B-encoded-text-regexp string)
 301            (string= string (match-string 0 string)))
 302       (base64-decode-string string)
 303     (error "Invalid encoded-text %s" string)))
 304
 305 (mel-define-method mime-insert-encoded-file (filename (nil "base64"))
 306   "Encode contents of file FILENAME to base64, and insert the result.
 307 It calls external base64 encoder specified by
 308 `base64-external-encoder'.  So you must install the program (maybe
 309 mmencode included in metamail or XEmacs package)."
 310   (interactive (list (read-file-name "Insert encoded file: ")))
 311   (if (and base64-internal-encoding-limit
 312            (> (nth 7 (file-attributes filename))
 313               base64-internal-encoding-limit))
 314       (apply (function call-process) (car base64-external-encoder)
 315              filename t nil (cdr base64-external-encoder))
 316     (insert
 317      (base64-encode-string
 318       (with-temp-buffer
 319         (insert-file-contents-as-binary filename)
 320         (buffer-string))))
 321     (or (bolp)
 322         (insert "\n"))
 323      ))
 324
 325 (mel-define-method mime-write-decoded-region (start end filename
 326                                                     (nil "base64"))
 327   "Decode and write current region encoded by base64 into FILENAME.
 328 START and END are buffer positions."
 329   (interactive
 330    (list (region-beginning) (region-end)
 331          (read-file-name "Write decoded region to file: ")))
 332   (if (and base64-internal-decoding-limit
 333            (> (- end start) base64-internal-decoding-limit))
 334       (as-binary-process
 335        (apply (function call-process-region)
 336               start end (car base64-external-decoder)
 337               nil nil nil
 338               (append (cdr base64-external-decoder)
 339                       base64-external-decoder-option-to-specify-file
 340                       (list filename))))
 341     (let ((str (buffer-substring start end)))
 342       (with-temp-buffer
 343         (insert (base64-internal-decode-string str))
 344         (write-region-as-binary (point-min) (point-max) filename)))))
 345
 346
 347 ;;; @ etc
 348 ;;;
 349
 350 (defun pack-sequence (seq size)
 351   "Split sequence SEQ into SIZE elements packs,
 352 and return list of packs. [mel-b; tl-seq function]"
 353   (let ((len (length seq)) (p 0) obj
 354         unit (i 0)
 355         dest)
 356     (while (< p len)
 357       (setq obj (elt seq p))
 358       (setq unit (cons obj unit))
 359       (setq i (1+ i))
 360       (if (= i size)
 361           (progn
 362             (setq dest (cons (reverse unit) dest))
 363             (setq unit nil)
 364             (setq i 0)
 365             ))
 366       (setq p (1+ p))
 367       )
 368     (if unit
 369         (setq dest (cons (reverse unit) dest))
 370       )
 371     (reverse dest)
 372     ))
 373
 374
 375 ;;; @ end
 376 ;;;
 377
 378 (provide 'mel-b)
 379
 380 ;;; mel-b.el ends here.