git.chise.org Git - elisp/gnus.git-/blob - lisp/base64.el

   1 ;;; base64.el,v --- Base64 encoding functions
   2 ;; Author: Kyle E. Jones
   3 ;; Created: 1997/03/12 14:37:09
   4 ;; Version: 1.6
   5 ;; Keywords: extensions
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (C) 1997 Kyle E. Jones
   9 ;;;
  10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11 ;;;
  12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2, or (at your option)
  15 ;;; any later version.
  16 ;;;
  17 ;;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU 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
  28 (eval-when-compile (require 'static))
  29
  30 (require 'mel)
  31
  32 (eval-and-compile
  33   (defun autoload-functionp (object)
  34     (if (functionp object)
  35         (let ((def object))
  36           (while (and (symbolp def) (fboundp def))
  37             (setq def (symbol-function def)))
  38           (eq (car-safe def) 'autoload))))
  39   (if (autoload-functionp 'base64-decode-string)
  40       (fmakunbound 'base64-decode-string))
  41   (if (autoload-functionp 'base64-decode-region)
  42       (fmakunbound 'base64-decode-region))
  43   (if (autoload-functionp 'base64-encode-string)
  44       (fmakunbound 'base64-encode-string))
  45   (if (autoload-functionp 'base64-encode-region)
  46       (fmakunbound 'base64-encode-region))
  47   (mel-find-function 'mime-decode-string "base64")
  48   (mel-find-function 'mime-decode-region "base64")
  49   (mel-find-function 'mime-encode-string "base64")
  50   (mel-find-function 'mime-encode-region "base64"))
  51
  52 (static-when nil
  53 (eval-when-compile (require 'cl))
  54
  55 ;; For non-MULE
  56 (if (not (fboundp 'char-int))
  57     (defalias 'char-int 'identity))
  58
  59 (defvar base64-alphabet
  60   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  61
  62 (defvar base64-decoder-program nil
  63   "*Non-nil value should be a string that names a MIME base64 decoder.
  64 The program should expect to read base64 data on its standard
  65 input and write the converted data to its standard output.")
  66
  67 (defvar base64-decoder-switches nil
  68   "*List of command line flags passed to the command named by
  69 base64-decoder-program.")
  70
  71 (defvar base64-encoder-program nil
  72   "*Non-nil value should be a string that names a MIME base64 encoder.
  73 The program should expect arbitrary data on its standard
  74 input and write base64 data to its standard output.")
  75
  76 (defvar base64-encoder-switches nil
  77   "*List of command line flags passed to the command named by
  78 base64-encoder-program.")
  79
  80 (defconst base64-alphabet-decoding-alist
  81   '(
  82     ( ?A . 00) ( ?B . 01) ( ?C . 02) ( ?D . 03) ( ?E . 04) ( ?F . 05)
  83     ( ?G . 06) ( ?H . 07) ( ?I . 08) ( ?J . 09) ( ?K . 10) ( ?L . 11)
  84     ( ?M . 12) ( ?N . 13) ( ?O . 14) ( ?P . 15) ( ?Q . 16) ( ?R . 17)
  85     ( ?S . 18) ( ?T . 19) ( ?U . 20) ( ?V . 21) ( ?W . 22) ( ?X . 23)
  86     ( ?Y . 24) ( ?Z . 25) ( ?a . 26) ( ?b . 27) ( ?c . 28) ( ?d . 29)
  87     ( ?e . 30) ( ?f . 31) ( ?g . 32) ( ?h . 33) ( ?i . 34) ( ?j . 35)
  88     ( ?k . 36) ( ?l . 37) ( ?m . 38) ( ?n . 39) ( ?o . 40) ( ?p . 41)
  89     ( ?q . 42) ( ?r . 43) ( ?s . 44) ( ?t . 45) ( ?u . 46) ( ?v . 47)
  90     ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53)
  91     ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59)
  92     ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63)
  93     ))
  94
  95 (defvar base64-alphabet-decoding-vector
  96   (let ((v (make-vector 123 nil))
  97         (p base64-alphabet-decoding-alist))
  98     (while p
  99       (aset v (car (car p)) (cdr (car p)))
 100       (setq p (cdr p)))
 101     v))
 102
 103 (defvar base64-binary-coding-system 'binary)
 104
 105 (defun base64-run-command-on-region (start end output-buffer command
 106                                            &rest arg-list)
 107   (let ((tempfile nil) status errstring default-process-coding-system
 108         (coding-system-for-write base64-binary-coding-system)
 109         (coding-system-for-read base64-binary-coding-system))
 110     (unwind-protect
 111         (progn
 112           (setq tempfile (make-temp-name "base64"))
 113           (setq status
 114                 (apply 'call-process-region
 115                        start end command nil
 116                        (list output-buffer tempfile)
 117                        nil arg-list))
 118           (cond ((equal status 0) t)
 119                 ((zerop (save-excursion
 120                           (set-buffer (find-file-noselect tempfile))
 121                           (buffer-size)))
 122                  t)
 123                 (t (save-excursion
 124                      (set-buffer (find-file-noselect tempfile))
 125                      (setq errstring (buffer-string))
 126                      (kill-buffer nil)
 127                      (cons status errstring)))))
 128       (ignore-errors
 129         (delete-file tempfile)))))
 130
 131 (if (featurep 'xemacs)
 132     (defalias 'base64-insert-char 'insert-char)
 133   (defun base64-insert-char (char &optional count ignored buffer)
 134     (if (or (null buffer) (eq buffer (current-buffer)))
 135         (insert-char char count)
 136       (with-current-buffer buffer
 137         (insert-char char count))))
 138   (setq base64-binary-coding-system 'no-conversion))
 139
 140 (defun base64-decode-region (start end)
 141   (interactive "r")
 142   ;;(message "Decoding base64...")
 143   (let ((work-buffer nil)
 144         (done nil)
 145         (counter 0)
 146         (bits 0)
 147         (lim 0) inputpos
 148         (non-data-chars (concat "^=" base64-alphabet)))
 149     (unwind-protect
 150         (save-excursion
 151           (setq work-buffer (generate-new-buffer " *base64-work*"))
 152           (buffer-disable-undo work-buffer)
 153           (if base64-decoder-program
 154               (let* ((binary-process-output t) ; any text already has CRLFs
 155                      (status (apply 'base64-run-command-on-region
 156                                     start end work-buffer
 157                                     base64-decoder-program
 158                                     base64-decoder-switches)))
 159                 (if (not (eq status t))
 160                     (error "%s" (cdr status))))
 161             (goto-char start)
 162             (skip-chars-forward non-data-chars end)
 163             (while (not done)
 164               (setq inputpos (point))
 165               (cond
 166                ((> (skip-chars-forward base64-alphabet end) 0)
 167                 (setq lim (point))
 168                 (while (< inputpos lim)
 169                   (setq bits (+ bits
 170                                 (aref base64-alphabet-decoding-vector
 171                                       (char-int (char-after inputpos)))))
 172                   (setq counter (1+ counter)
 173                         inputpos (1+ inputpos))
 174                   (cond ((= counter 4)
 175                          (base64-insert-char (lsh bits -16) 1 nil work-buffer)
 176                          (base64-insert-char (logand (lsh bits -8) 255) 1 nil
 177                                              work-buffer)
 178                          (base64-insert-char (logand bits 255) 1 nil
 179                                              work-buffer)
 180                          (setq bits 0 counter 0))
 181                         (t (setq bits (lsh bits 6)))))))
 182               (cond
 183                ((or (= (point) end)
 184                     (eq (char-after (point)) ?=))
 185                 (if (and (= (point) end) (> counter 1))
 186                     (message
 187                      "at least %d bits missing at end of base64 encoding"
 188                      (* (- 4 counter) 6)))
 189                 (setq done t)
 190                 (cond ((= counter 1)
 191                        (error "at least 2 bits missing at end of base64 encoding"))
 192                       ((= counter 2)
 193                        (base64-insert-char (lsh bits -10) 1 nil work-buffer))
 194                       ((= counter 3)
 195                        (base64-insert-char (lsh bits -16) 1 nil work-buffer)
 196                        (base64-insert-char (logand (lsh bits -8) 255)
 197                                            1 nil work-buffer))
 198                       ((= counter 0) t)))
 199                (t (skip-chars-forward non-data-chars end)))))
 200           (or (markerp end) (setq end (set-marker (make-marker) end)))
 201           (goto-char start)
 202           (insert-buffer-substring work-buffer)
 203           (delete-region (point) end))
 204       (and work-buffer (kill-buffer work-buffer))))
 205   ;;(message "Decoding base64... done")
 206   )
 207
 208 (defun base64-encode-region (start end &optional no-line-break)
 209   (interactive "r")
 210   (message "Encoding base64...")
 211   (let ((work-buffer nil)
 212         (counter 0)
 213         (cols 0)
 214         (bits 0)
 215         (alphabet base64-alphabet)
 216         inputpos)
 217     (unwind-protect
 218         (save-excursion
 219           (setq work-buffer (generate-new-buffer " *base64-work*"))
 220           (buffer-disable-undo work-buffer)
 221           (if base64-encoder-program
 222               (let ((status (apply 'base64-run-command-on-region
 223                                    start end work-buffer
 224                                    base64-encoder-program
 225                                    base64-encoder-switches)))
 226                 (if (not (eq status t))
 227                     (error "%s" (cdr status))))
 228             (setq inputpos start)
 229             (while (< inputpos end)
 230               (setq bits (+ bits (char-int (char-after inputpos))))
 231               (setq counter (1+ counter))
 232               (cond ((= counter 3)
 233                      (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
 234                                          work-buffer)
 235                      (base64-insert-char
 236                       (aref alphabet (logand (lsh bits -12) 63))
 237                       1 nil work-buffer)
 238                      (base64-insert-char
 239                       (aref alphabet (logand (lsh bits -6) 63))
 240                       1 nil work-buffer)
 241                      (base64-insert-char
 242                       (aref alphabet (logand bits 63))
 243                       1 nil work-buffer)
 244                      (setq cols (+ cols 4))
 245                      (cond ((and (= cols 72)
 246                                  (not no-line-break))
 247                             (base64-insert-char ?\n 1 nil work-buffer)
 248                             (setq cols 0)))
 249                      (setq bits 0 counter 0))
 250                     (t (setq bits (lsh bits 8))))
 251               (setq inputpos (1+ inputpos)))
 252             ;; write out any remaining bits with appropriate padding
 253             (if (= counter 0)
 254                 nil
 255               (setq bits (lsh bits (- 16 (* 8 counter))))
 256               (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
 257                                   work-buffer)
 258               (base64-insert-char (aref alphabet (logand (lsh bits -12) 63))
 259                                   1 nil work-buffer)
 260               (if (= counter 1)
 261                   (base64-insert-char ?= 2 nil work-buffer)
 262                 (base64-insert-char (aref alphabet (logand (lsh bits -6) 63))
 263                                     1 nil work-buffer)
 264                 (base64-insert-char ?= 1 nil work-buffer)))
 265             (if (and (> cols 0)
 266                      (not no-line-break))
 267                 (base64-insert-char ?\n 1 nil work-buffer)))
 268           (or (markerp end) (setq end (set-marker (make-marker) end)))
 269           (goto-char start)
 270           (insert-buffer-substring work-buffer)
 271           (delete-region (point) end))
 272       (and work-buffer (kill-buffer work-buffer))))
 273   (message "Encoding base64... done"))
 274
 275 (defun base64-encode (string &optional no-line-break)
 276   (save-excursion
 277     (set-buffer (get-buffer-create " *base64-encode*"))
 278     (erase-buffer)
 279     (insert string)
 280     (base64-encode-region (point-min) (point-max) no-line-break)
 281     (skip-chars-backward " \t\r\n")
 282     (delete-region (point-max) (point))
 283     (prog1
 284         (buffer-string)
 285       (kill-buffer (current-buffer)))))
 286
 287 (defun base64-decode (string)
 288   (save-excursion
 289     (set-buffer (get-buffer-create " *base64-decode*"))
 290     (erase-buffer)
 291     (insert string)
 292     (base64-decode-region (point-min) (point-max))
 293     (goto-char (point-max))
 294     (skip-chars-backward " \t\r\n")
 295     (delete-region (point-max) (point))
 296     (prog1
 297         (buffer-string)
 298       (kill-buffer (current-buffer)))))
 299
 300 (defalias 'base64-decode-string 'base64-decode)
 301 (defalias 'base64-encode-string 'base64-encode)
 302
 303 );; (static-when nil ...
 304
 305 (provide 'base64)