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