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