mel-b-el.el

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