mel-b-el.el

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