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   "Base64-encode STRING 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 &optional no-line-break)
 150   (save-excursion
 151     (save-restriction
 152       (narrow-to-region beg end)
 153       (insert
 154        (prog1
 155            (base64-encode-string (buffer-substring beg end) no-line-break)
 156          (delete-region beg end))))))
 157
 158
 159 ;;; @ internal base64 decoder
 160 ;;;
 161
 162 (defconst base64-numbers
 163   (eval-when-compile
 164     (let ((len (length base64-characters))
 165           (vec (make-vector 123 nil))
 166           (i 0))
 167       (while (< i len)
 168         (aset vec (aref base64-characters i) i)
 169         (setq i (1+ i)))
 170       vec)))
 171
 172 (defmacro base64-char-to-num (c)
 173   `(aref base64-numbers ,c))
 174
 175 (defsubst base64-internal-decode (string buffer)
 176   (let* ((len (length string))
 177          (i 0)(j 0)
 178          v1 v2 v3)
 179     (catch 'tag
 180       (while (< i len)
 181         (when (prog1 (setq v1 (base64-char-to-num (aref string i)))
 182                 (setq i (1+ i)))
 183           (setq v2 (base64-char-to-num (aref string i))
 184                 i (1+ i)
 185                 v3 (base64-char-to-num (aref string i))
 186                 i (1+ i))
 187           (aset buffer j (logior (lsh v1 2)(lsh v2 -4)))
 188           (setq j (1+ j))
 189           (if v3
 190               (let ((v4 (base64-char-to-num (aref string i))))
 191                 (setq i (1+ i))
 192                 (aset buffer j (logior (lsh (logand v2 15) 4)(lsh v3 -2)))
 193                 (setq j (1+ j))
 194                 (if v4
 195                     (aset buffer (prog1 j (setq j (1+ j)))
 196                           (logior (lsh (logand v3 3) 6) v4))
 197                   (throw 'tag nil)))
 198             (throw 'tag nil)))))
 199     (substring buffer 0 j)))
 200
 201 (defun base64-internal-decode-string (string)
 202   (base64-internal-decode string (make-string (length string) 0)))
 203
 204 ;; (defsubst base64-decode-string! (string)
 205 ;;   (setq string (string-as-unibyte string))
 206 ;;   (base64-internal-decode string string))
 207
 208 (defun base64-internal-decode-region (beg end)
 209   (save-excursion
 210     (let ((str (string-as-unibyte (buffer-substring beg end))))
 211       (insert
 212        (prog1
 213            (base64-internal-decode str str)
 214          (delete-region beg end))))))
 215
 216 ;; (defun base64-internal-decode-region2 (beg end)
 217 ;;   (save-excursion
 218 ;;     (let ((str (buffer-substring beg end)))
 219 ;;       (delete-region beg end)
 220 ;;       (goto-char beg)
 221 ;;       (insert (base64-decode-string! str)))))
 222
 223 ;; (defun base64-internal-decode-region3 (beg end)
 224 ;;   (save-excursion
 225 ;;     (let ((str (buffer-substring beg end)))
 226 ;;       (delete-region beg end)
 227 ;;       (goto-char beg)
 228 ;;       (insert (base64-internal-decode-string str)))))
 229
 230
 231 ;;; @ external encoder/decoder
 232 ;;;
 233
 234 (defun base64-external-encode-region (beg end &optional no-line-break)
 235   (save-excursion
 236     (save-restriction
 237       (narrow-to-region beg end)
 238       (as-binary-process
 239        (apply (function call-process-region)
 240               beg end (car base64-external-encoder)
 241               t t nil
 242               (cdr base64-external-encoder)))
 243       ;; for OS/2
 244       ;;   regularize line break code
 245       (goto-char (point-min))
 246       (while (re-search-forward "\r$" nil t)
 247         (replace-match ""))
 248       (if no-line-break
 249           (progn
 250             (goto-char (point-min))
 251             (while (search-forward "\n" nil t)
 252               (replace-match "")))))))
 253
 254 (defun base64-external-decode-region (beg end)
 255   (save-excursion
 256     (as-binary-process
 257      (apply (function call-process-region)
 258             beg end (car base64-external-decoder)
 259             t t nil
 260             (cdr base64-external-decoder)))))
 261
 262 (defun base64-external-decode-string (string)
 263   (with-temp-buffer
 264     (insert string)
 265     (as-binary-process
 266      (apply (function call-process-region)
 267             (point-min)(point-max) (car base64-external-decoder)
 268             t t nil
 269             (cdr base64-external-decoder)))
 270     (buffer-string)))
 271
 272
 273 ;;; @ application interfaces
 274 ;;;
 275
 276 (defun-maybe base64-encode-region (start end &optional no-line-break)
 277   "Base64-encode the region between START and END.
 278 Return the length of the encoded text.
 279 Optional third argument NO-LINE-BREAK means do not break long lines
 280 into shorter lines.
 281 This function calls internal base64 encoder if size of region is
 282 smaller than `base64-internal-encoding-limit', otherwise it calls
 283 external base64 encoder specified by `base64-external-encoder'.  In
 284 this case, you must install the program (maybe mmencode included in
 285 metamail or XEmacs package)."
 286   (interactive "*r")
 287   (if (and base64-internal-encoding-limit
 288            (> (- end start) base64-internal-encoding-limit))
 289       (base64-external-encode-region start end no-line-break)
 290     (base64-internal-encode-region start end no-line-break)))
 291
 292 (defun-maybe base64-decode-region (start end)
 293   "Decode current region by base64.
 294 START and END are buffer positions.
 295 This function calls internal base64 decoder if size of region is
 296 smaller than `base64-internal-decoding-limit', otherwise it calls
 297 external base64 decoder specified by `base64-external-decoder'.  In
 298 this case, you must install the program (maybe mmencode included in
 299 metamail or XEmacs package)."
 300   (interactive "*r")
 301   (if (and base64-internal-decoding-limit
 302            (> (- end start) base64-internal-decoding-limit))
 303       (base64-external-decode-region start end)
 304     (base64-internal-decode-region start end)))
 305
 306 (defun-maybe base64-decode-string (string)
 307   "Decode STRING which is encoded in base64, and return the result.
 308 This function calls internal base64 decoder if size of STRING is
 309 smaller than `base64-internal-decoding-limit', otherwise it calls
 310 external base64 decoder specified by `base64-external-decoder'.  In
 311 this case, you must install the program (maybe mmencode included in
 312 metamail or XEmacs package)."
 313   (if (and base64-internal-decoding-limit
 314            (> (length string) base64-internal-decoding-limit))
 315       (base64-external-decode-string string)
 316     (base64-internal-decode-string string)))
 317
 318
 319 (mel-define-method-function (mime-encode-string string (nil "base64"))
 320                             'base64-encode-string)
 321 (mel-define-method-function (mime-decode-string string (nil "base64"))
 322                             'base64-decode-string)
 323 (mel-define-method-function (mime-encode-region start end (nil "base64"))
 324                             'base64-encode-region)
 325 (mel-define-method-function (mime-decode-region start end (nil "base64"))
 326                             'base64-decode-region)
 327
 328 (mel-define-method-function (encoded-text-encode-string string (nil "B"))
 329                             'base64-encode-string)
 330
 331 (mel-define-method encoded-text-decode-string (string (nil "B"))
 332   (if (string-match (eval-when-compile
 333                       (concat "\\`" B-encoded-text-regexp "\\'"))
 334                     string)
 335       (base64-decode-string string)
 336     (error "Invalid encoded-text %s" string)))
 337
 338 (defun base64-insert-encoded-file (filename)
 339   "Encode contents of file FILENAME to base64, and insert the result.
 340 It calls external base64 encoder specified by
 341 `base64-external-encoder'.  So you must install the program (maybe
 342 mmencode included in metamail or XEmacs package)."
 343   (interactive "*fInsert encoded file: ")
 344   (if (and base64-internal-encoding-limit
 345            (> (nth 7 (file-attributes filename))
 346               base64-internal-encoding-limit))
 347       (apply (function call-process)
 348              (car base64-external-encoder)
 349              filename t nil
 350              (cdr base64-external-encoder))
 351     (insert
 352      (base64-encode-string
 353       (with-temp-buffer
 354         (set-buffer-multibyte nil)
 355         (insert-file-contents-as-binary filename)
 356         (buffer-string))))
 357     (or (bolp) (insert ?\n))))
 358
 359 (mel-define-method-function (mime-insert-encoded-file filename (nil "base64"))
 360                             'base64-insert-encoded-file)
 361
 362 (defun base64-write-decoded-region (start end filename)
 363   "Decode and write current region encoded by base64 into FILENAME.
 364 START and END are buffer positions."
 365   (interactive "*r\nFWrite decoded region to file: ")
 366   (if (and base64-internal-decoding-limit
 367            (> (- end start) base64-internal-decoding-limit))
 368       (as-binary-process
 369        (apply (function call-process-region)
 370               start end (car base64-external-decoder)
 371               nil nil nil
 372               (append (cdr base64-external-decoder)
 373                       base64-external-decoder-option-to-specify-file
 374                       (list filename))))
 375     (let ((str (buffer-substring start end)))
 376       (with-temp-buffer
 377         (insert (base64-internal-decode-string str))
 378         (write-region-as-binary (point-min) (point-max) filename)))))
 379
 380 (mel-define-method-function
 381  (mime-write-decoded-region start end filename (nil "base64"))
 382  'base64-write-decoded-region)
 383
 384
 385 ;;; @ end
 386 ;;;
 387
 388 (provide 'mel-b-el)
 389
 390 ;;; mel-b-el.el ends here.