mel-b-el.el

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