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 decoder
  71 ;;;
  72
  73 (defconst base64-numbers
  74   [nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  75    nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
  76    nil nil nil nil nil nil nil nil nil nil nil 62  nil nil nil 63
  77    52  53  54  55  56  57  58  59  60  61  nil nil nil nil nil nil
  78    nil  0   1   2   3   4   5   6   7   8   9  10  11  12  13  14
  79    15  16  17  18  19  20  21  22  23  24  25  nil nil nil nil nil
  80    nil 26  27  28  29  30  31  32  33  34  35  36  37  38  39  40
  81    41  42  43  44  45  46  47  48  49  50  51])
  82
  83 (defmacro base64-char-to-num (c)
  84   `(aref base64-numbers ,c))
  85
  86 (defsubst base64-internal-decode (string buffer)
  87   (let* ((len (length string))
  88          (i 0)
  89          (j 0)
  90          v1 v2 v3)
  91     (catch 'tag
  92       (while (< i len)
  93         (when (prog1 (setq v1 (base64-char-to-num (aref string i)))
  94                 (setq i (1+ i)))
  95           (setq v2 (base64-char-to-num (aref string i))
  96                 i (1+ i)
  97                 v3 (base64-char-to-num (aref string i))
  98                 i (1+ i))
  99           (aset buffer j (logior (lsh v1 2)(lsh v2 -4)))
 100           (setq j (1+ j))
 101           (if v3
 102               (let ((v4 (base64-char-to-num (aref string i))))
 103                 (setq i (1+ i))
 104                 (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2)))
 105                 (setq j (1+ j))
 106                 (if v4
 107                     (aset buffer (prog1 j (setq j (1+ j)))
 108                           (logior (logand (lsh (logand v3 15) 6) 255)
 109                                   v4))
 110                   (throw 'tag nil)
 111                   ))
 112             (throw 'tag nil)
 113             ))))
 114     (substring buffer 0 j)
 115     ))
 116
 117 (defun base64-internal-decode-string (string)
 118   (base64-internal-decode string (make-string (length string) 0)))
 119
 120 (defsubst base64-internal-decode-string! (string)
 121   (base64-internal-decode string string))
 122
 123 (defun base64-internal-decode-region (beg end)
 124   (save-excursion
 125     (let ((str (buffer-substring beg end)))
 126       (delete-region beg end)
 127       (goto-char beg)
 128       (insert (base64-internal-decode-string! str)))))
 129
 130
 131 ;;; @ internal base64 encoder
 132 ;;;     based on base64 decoder by Enami Tsugutomo
 133
 134 (defun base64-num-to-char (n)
 135   (cond ((eq n nil) ?=)
 136         ((< n 26) (+ ?A n))
 137         ((< n 52) (+ ?a (- n 26)))
 138         ((< n 62) (+ ?0 (- n 52)))
 139         ((= n 62) ?+)
 140         ((= n 63) ?/)
 141         (t (error "not a base64 integer %d" n))))
 142
 143 (defun base64-encode-1 (pack)
 144   (let ((a (car pack))
 145         (b (nth 1 pack))
 146         (c (nth 2 pack)))
 147     (concat
 148      (char-to-string (base64-num-to-char (ash a -2)))
 149      (if b
 150          (concat
 151           (char-to-string
 152            (base64-num-to-char (logior (ash (logand a 3) 4) (ash b -4))))
 153           (if c
 154               (concat
 155                (char-to-string
 156                 (base64-num-to-char (logior (ash (logand b 15) 2) (ash c -6))))
 157                (char-to-string (base64-num-to-char (logand c 63)))
 158                )
 159             (concat (char-to-string
 160                      (base64-num-to-char (ash (logand b 15) 2))) "=")
 161             ))
 162        (concat (char-to-string
 163                 (base64-num-to-char (ash (logand a 3) 4))) "==")
 164        ))))
 165
 166 (defun base64-encode-string (string)
 167   "Encode STRING to base64, and return the result."
 168   (let ((len (length string))
 169         (b 0)(e 57)
 170         dest)
 171     (while (< e len)
 172       (setq dest
 173             (concat dest
 174                     (mapconcat
 175                      (function base64-encode-1)
 176                      (pack-sequence (substring string b e) 3)
 177                      "")
 178                     "\n"))
 179       (setq b e
 180             e (+ e 57)
 181             )
 182       )
 183     (let* ((es (mapconcat
 184                 (function base64-encode-1)
 185                 (pack-sequence (substring string b) 3)
 186                 ""))
 187            (m (mod (length es) 4))
 188            )
 189       (concat dest es (cond ((= m 3) "=")
 190                             ((= m 2) "==")
 191                             ))
 192       )))
 193
 194 (defun base64-internal-encode-region (beg end)
 195   (save-excursion
 196     (save-restriction
 197       (narrow-to-region beg end)
 198       (let ((str (buffer-substring beg end)))
 199         (delete-region beg end)
 200         (insert (base64-encode-string str))
 201         )
 202       (or (bolp)
 203           (insert "\n")
 204           )
 205       )))
 206
 207
 208 ;;; @ base64 encoder/decoder for region
 209 ;;;
 210
 211 (defun base64-external-encode-region (beg end)
 212   (save-excursion
 213     (save-restriction
 214       (narrow-to-region beg end)
 215       (as-binary-process
 216        (apply (function call-process-region)
 217               beg end (car base64-external-encoder)
 218               t t nil (cdr base64-external-encoder)))
 219       ;; for OS/2
 220       ;;   regularize line break code
 221       (goto-char (point-min))
 222       (while (re-search-forward "\r$" nil t)
 223         (replace-match ""))
 224       )))
 225
 226 (defun base64-external-decode-region (beg end)
 227   (save-excursion
 228     (as-binary-process
 229      (apply (function call-process-region)
 230             beg end (car base64-external-decoder)
 231             t t nil (cdr base64-external-decoder)))
 232     ))
 233
 234 (defun base64-external-decode-string (string)
 235   (with-temp-buffer
 236     (insert string)
 237     (as-binary-process
 238      (apply (function call-process-region)
 239             (point-min) (point-max)
 240             (car base64-external-decoder)
 241             t t nil (cdr base64-external-decoder)))
 242     (buffer-string)))
 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 ;;; @ base64 encoder/decoder for file
 288 ;;;
 289
 290 (defun base64-insert-encoded-file (filename)
 291   "Encode contents of file FILENAME to base64, and insert the result.
 292 It calls external base64 encoder specified by
 293 `base64-external-encoder'.  So you must install the program (maybe
 294 mmencode included in metamail or XEmacs package)."
 295   (interactive (list (read-file-name "Insert encoded file: ")))
 296   (if (and base64-internal-encoding-limit
 297            (> (nth 7 (file-attributes filename))
 298               base64-internal-encoding-limit))
 299       (apply (function call-process) (car base64-external-encoder)
 300              filename t nil (cdr base64-external-encoder))
 301     (insert
 302      (base64-encode-string
 303       (with-temp-buffer
 304         (insert-file-contents-as-binary filename)
 305         (buffer-string))))
 306     (or (bolp)
 307         (insert "\n"))
 308      ))
 309
 310 (defun base64-write-decoded-region (start end filename)
 311   "Decode and write current region encoded by base64 into FILENAME.
 312 START and END are buffer positions."
 313   (interactive
 314    (list (region-beginning) (region-end)
 315          (read-file-name "Write decoded region to file: ")))
 316   (if (and base64-internal-decoding-limit
 317            (> (- end start) base64-internal-decoding-limit))
 318       (as-binary-process
 319        (apply (function call-process-region)
 320               start end (car base64-external-decoder)
 321               nil nil nil
 322               (append (cdr base64-external-decoder)
 323                       base64-external-decoder-option-to-specify-file
 324                       (list filename))))
 325     (let ((str (buffer-substring start end)))
 326       (with-temp-buffer
 327         (insert (base64-internal-decode-string str))
 328         (write-region-as-binary (point-min) (point-max) filename)))))
 329
 330 ;;; @ etc
 331 ;;;
 332
 333 (defun base64-encoded-length (string)
 334   (let ((len (length string)))
 335     (* (+ (/ len 3)
 336           (if (= (mod len 3) 0) 0 1)
 337           ) 4)
 338     ))
 339
 340 (defun pack-sequence (seq size)
 341   "Split sequence SEQ into SIZE elements packs,
 342 and return list of packs. [mel-b; tl-seq function]"
 343   (let ((len (length seq)) (p 0) obj
 344         unit (i 0)
 345         dest)
 346     (while (< p len)
 347       (setq obj (elt seq p))
 348       (setq unit (cons obj unit))
 349       (setq i (1+ i))
 350       (if (= i size)
 351           (progn
 352             (setq dest (cons (reverse unit) dest))
 353             (setq unit nil)
 354             (setq i 0)
 355             ))
 356       (setq p (1+ p))
 357       )
 358     (if unit
 359         (setq dest (cons (reverse unit) dest))
 360       )
 361     (reverse dest)
 362     ))
 363
 364
 365 ;;; @ end
 366 ;;;
 367
 368 (provide 'mel-b)
 369
 370 ;;; mel-b.el ends here.