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