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