mel-b-el.el

   1 ;;; mel-b-el.el --- Base64 encoder/decoder.
   2
   3 ;; Copyright (C) 1992,1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: ENAMI Tsugutomo <enami@sys.ptg.sony.co.jp>
   6 ;;         MORIOKA Tomohiko <tomo@m17n.org>
   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         (p 0)
  82         dest unit)
  83     (while (< p len)
  84       (setq unit (cons (elt seq p) unit))
  85       (setq p (1+ p))
  86       (when (zerop (mod p size))
  87         (setq dest (cons (nreverse unit) dest))
  88         (setq unit nil)))
  89     (if unit
  90         (nreverse (cons (nreverse unit) dest))
  91       (nreverse dest))))
  92
  93
  94 ;;; @ internal base64 encoder
  95 ;;;     based on base64 decoder by Enami Tsugutomo
  96
  97 (eval-and-compile
  98   (defconst base64-characters
  99     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
 100   )
 101
 102 (defmacro base64-num-to-char (n)
 103   `(aref base64-characters ,n))
 104
 105 (defun base64-encode-1 (pack)
 106   (let ((buf (make-string 4 ?=)))
 107     (aset buf 0 (base64-num-to-char (ash (car pack) -2)))
 108     (if (nth 1 pack)
 109         (progn
 110           (aset buf 1 (base64-num-to-char
 111                        (logior (ash (logand (car pack) 3) 4)
 112                                (ash (nth 1 pack) -4))))
 113           (if (nth 2 pack)
 114               (progn
 115                 (aset buf 2 (base64-num-to-char
 116                              (logior (ash (logand (nth 1 pack) 15) 2)
 117                                      (ash (nth 2 pack) -6))))
 118                 (aset buf 3 (base64-num-to-char
 119                              (logand (nth 2 pack) 63))))
 120             (aset buf 2 (base64-num-to-char
 121                          (ash (logand (nth 1 pack) 15) 2)))))
 122       (aset buf 1 (base64-num-to-char
 123                    (ash (logand (car pack) 3) 4))))
 124     buf))
 125
 126 (defun-maybe base64-encode-string (string &optional no-line-break)
 127   "Encode STRING to base64, and return the result.
 128 Optional second argument NO-LINE-BREAK means do not break long lines
 129 into shorter lines."
 130   (let* ((len (length string))
 131          (b 0)(e 57)
 132          (dest ""))
 133     (while (< e len)
 134       (setq dest
 135             (concat dest
 136                     (mapconcat
 137                      (function base64-encode-1)
 138                      (pack-sequence (substring string b e) 3)
 139                      "")
 140                     (if (not no-line-break) "\n")))
 141       (setq b e
 142             e (+ e 57)))
 143     (concat dest
 144             (mapconcat
 145              (function base64-encode-1)
 146              (pack-sequence (substring string b) 3)
 147              ""))))
 148
 149 (defun base64-internal-encode-region (beg end)
 150   (save-excursion
 151     (save-restriction
 152       (narrow-to-region beg end)
 153       (insert
 154        (prog1
 155            (base64-encode-string
 156             (buffer-substring beg end))
 157          (delete-region beg end)))
 158       (or (bolp) (insert ?\n)))))
 159
 160
 161 ;;; @ internal base64 decoder
 162 ;;;
 163
 164 (defconst base64-numbers
 165   (eval-when-compile
 166     (let ((len (length base64-characters))
 167           (vec (make-vector 123 nil))
 168           (i 0))
 169       (while (< i len)
 170         (aset vec (aref base64-characters i) i)
 171         (setq i (1+ i)))
 172       vec)))
 173
 174 (defmacro base64-char-to-num (c)
 175   `(aref base64-numbers ,c))
 176
 177 (defsubst base64-internal-decode (string buffer)
 178   (let* ((len (length string))
 179          (i 0)(j 0)
 180          v1 v2 v3)
 181     (catch 'tag
 182       (while (< i len)
 183         (when (prog1 (setq v1 (base64-char-to-num (aref string i)))
 184                 (setq i (1+ i)))
 185           (setq v2 (base64-char-to-num (aref string i))
 186                 i (1+ i)
 187                 v3 (base64-char-to-num (aref string i))
 188                 i (1+ i))
 189           (aset buffer j (logior (lsh v1 2)(lsh v2 -4)))
 190           (setq j (1+ j))
 191           (if v3
 192               (let ((v4 (base64-char-to-num (aref string i))))
 193                 (setq i (1+ i))
 194                 (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2)))
 195                 (setq j (1+ j))
 196                 (if v4
 197                     (aset buffer (prog1 j (setq j (1+ j)))
 198                           (logior (lsh (logand v3 3) 6) v4))
 199                   (throw 'tag nil)))
 200             (throw 'tag nil)))))
 201     (substring buffer 0 j)))
 202
 203 (defun base64-internal-decode-string (string)
 204   (base64-internal-decode string (make-string (length string) 0)))
 205
 206 ;; (defsubst base64-decode-string! (string)
 207 ;;   (setq string (string-as-unibyte string))
 208 ;;   (base64-internal-decode string string))
 209
 210 (defun base64-internal-decode-region (beg end)
 211   (save-excursion
 212     (let ((str (string-as-unibyte (buffer-substring beg end))))
 213       (insert
 214        (prog1
 215            (base64-internal-decode str str)
 216          (delete-region beg end))))))
 217
 218 ;; (defun base64-internal-decode-region2 (beg end)
 219 ;;   (save-excursion
 220 ;;     (let ((str (buffer-substring beg end)))
 221 ;;       (delete-region beg end)
 222 ;;       (goto-char beg)
 223 ;;       (insert (base64-decode-string! str)))))
 224
 225 ;; (defun base64-internal-decode-region3 (beg end)
 226 ;;   (save-excursion
 227 ;;     (let ((str (buffer-substring beg end)))
 228 ;;       (delete-region beg end)
 229 ;;       (goto-char beg)
 230 ;;       (insert (base64-internal-decode-string str)))))
 231
 232
 233 ;;; @ external encoder/decoder
 234 ;;;
 235
 236 (defun base64-external-encode-region (beg end)
 237   (save-excursion
 238     (save-restriction
 239       (narrow-to-region beg end)
 240       (as-binary-process
 241        (apply (function call-process-region)
 242               beg end (car base64-external-encoder)
 243               t t nil
 244               (cdr base64-external-encoder)))
 245       ;; for OS/2
 246       ;;   regularize line break code
 247       (goto-char (point-min))
 248       (while (re-search-forward "\r$" nil t)
 249         (replace-match "")))))
 250
 251 (defun base64-external-decode-region (beg end)
 252   (save-excursion
 253     (as-binary-process
 254      (apply (function call-process-region)
 255             beg end (car base64-external-decoder)
 256             t t nil
 257             (cdr base64-external-decoder)))))
 258
 259 (defun base64-external-decode-string (string)
 260   (with-temp-buffer
 261     (insert string)
 262     (as-binary-process
 263      (apply (function call-process-region)
 264             (point-min)(point-max) (car base64-external-decoder)
 265             t t nil
 266             (cdr base64-external-decoder)))
 267     (buffer-string)))
 268
 269
 270 ;;; @ application interfaces
 271 ;;;
 272
 273 (defun-maybe base64-encode-region (start end)
 274   "Encode current region by base64.
 275 START and END are buffer positions.
 276 This function calls internal base64 encoder if size of region is
 277 smaller than `base64-internal-encoding-limit', otherwise it calls
 278 external base64 encoder specified by `base64-external-encoder'.  In
 279 this case, you must install the program (maybe mmencode included in
 280 metamail or XEmacs package)."
 281   (interactive "*r")
 282   (if (and base64-internal-encoding-limit
 283            (> (- end start) base64-internal-encoding-limit))
 284       (base64-external-encode-region start end)
 285     (base64-internal-encode-region start end)))
 286
 287 (defun-maybe base64-decode-region (start end)
 288   "Decode current region by base64.
 289 START and END are buffer positions.
 290 This function calls internal base64 decoder if size of region is
 291 smaller than `base64-internal-decoding-limit', otherwise it calls
 292 external base64 decoder specified by `base64-external-decoder'.  In
 293 this case, you must install the program (maybe mmencode included in
 294 metamail or XEmacs package)."
 295   (interactive "*r")
 296   (if (and base64-internal-decoding-limit
 297            (> (- end start) base64-internal-decoding-limit))
 298       (base64-external-decode-region start end)
 299     (base64-internal-decode-region start end)))
 300
 301 (defun-maybe base64-decode-string (string)
 302   "Decode STRING which is encoded in base64, and return the result.
 303 This function calls internal base64 decoder if size of STRING is
 304 smaller than `base64-internal-decoding-limit', otherwise it calls
 305 external base64 decoder specified by `base64-external-decoder'.  In
 306 this case, you must install the program (maybe mmencode included in
 307 metamail or XEmacs package)."
 308   (if (and base64-internal-decoding-limit
 309            (> (length string) base64-internal-decoding-limit))
 310       (base64-external-decode-string string)
 311     (base64-internal-decode-string string)))
 312
 313
 314 (mel-define-method-function (mime-encode-string string (nil "base64"))
 315                             'base64-encode-string)
 316 (mel-define-method-function (mime-decode-string string (nil "base64"))
 317                             'base64-decode-string)
 318 (mel-define-method-function (mime-encode-region start end (nil "base64"))
 319                             'base64-encode-region)
 320 (mel-define-method-function (mime-decode-region start end (nil "base64"))
 321                             'base64-decode-region)
 322
 323 (mel-define-method-function (encoded-text-encode-string string (nil "B"))
 324                             'base64-encode-string)
 325
 326 (mel-define-method encoded-text-decode-string (string (nil "B"))
 327   (if (string-match (eval-when-compile
 328                       (concat "\\`" B-encoded-text-regexp "\\'"))
 329                     string)
 330       (base64-decode-string string)
 331     (error "Invalid encoded-text %s" string)))
 332
 333 (defun base64-insert-encoded-file (filename)
 334   "Encode contents of file FILENAME to base64, and insert the result.
 335 It calls external base64 encoder specified by
 336 `base64-external-encoder'.  So you must install the program (maybe
 337 mmencode included in metamail or XEmacs package)."
 338   (interactive "*fInsert encoded file: ")
 339   (if (and base64-internal-encoding-limit
 340            (> (nth 7 (file-attributes filename))
 341               base64-internal-encoding-limit))
 342       (apply (function call-process)
 343              (car base64-external-encoder)
 344              filename t nil
 345              (cdr base64-external-encoder))
 346     (insert
 347      (base64-encode-string
 348       (with-temp-buffer
 349         (set-buffer-multibyte nil)
 350         (insert-file-contents-as-binary filename)
 351         (buffer-string))))
 352     (or (bolp) (insert ?\n))))
 353
 354 (mel-define-method-function (mime-insert-encoded-file filename (nil "base64"))
 355                             'base64-insert-encoded-file)
 356
 357 (defun base64-write-decoded-region (start end filename)
 358   "Decode and write current region encoded by base64 into FILENAME.
 359 START and END are buffer positions."
 360   (interactive "*r\nFWrite decoded region to file: ")
 361   (if (and base64-internal-decoding-limit
 362            (> (- end start) base64-internal-decoding-limit))
 363       (as-binary-process
 364        (apply (function call-process-region)
 365               start end (car base64-external-decoder)
 366               nil nil nil
 367               (append (cdr base64-external-decoder)
 368                       base64-external-decoder-option-to-specify-file
 369                       (list filename))))
 370     (let ((str (buffer-substring start end)))
 371       (with-temp-buffer
 372         (insert (base64-internal-decode-string str))
 373         (write-region-as-binary (point-min) (point-max) filename)))))
 374
 375 (mel-define-method-function
 376  (mime-write-decoded-region start end filename (nil "base64"))
 377  'base64-write-decoded-region)
 378
 379
 380 ;;; @ end
 381 ;;;
 382
 383 (provide 'mel-b-el)
 384
 385 ;;; mel-b-el.el ends here.