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