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