Mercurial > hg > xemacs-beta

comparison lisp/w3/base64.el @ 82:6a378aca36af r20-0b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b91
author cvs
date Mon, 13 Aug 2007 09:07:36 +0200
parents 0293115a14e9
children e04119814345
comparison
equal deleted inserted replaced
81:ebca3d831cea 82:6a378aca36af
1 ;;; base64.el,v --- Base64 encoding functions 1 ;;; base64.el,v --- Base64 encoding functions
2 ;; Author: wmperry 2 ;; Author: Kyle E. Jones
3 ;; Created: 1996/04/22 15:08:08 3 ;; Created: 1997/01/23 00:13:17
4 ;; Version: 1.7 4 ;; Version: 1.4
5 ;; Keywords: extensions 5 ;; Keywords: extensions
6 6
7 ;;; LCD Archive Entry:
8 ;;; base64.el|William M. Perry|wmperry@cs.indiana.edu|
9 ;;; Package for encoding/decoding base64 data (MIME)|
10 ;;; 1996/04/22 15:08:08|1.7|Location Undetermined
11 ;;;
12
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 ;;; Copyright (c) 1996 Free Software Foundation, Inc. 8 ;;; Copyright (C) 1997 Kyle E. Jones
15 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
16 ;;; 9 ;;;
17 ;;; This file is not part of GNU Emacs, but the same permissions apply. 10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
18 ;;; 11 ;;;
19 ;;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;;; GNU Emacs is free software; you can redistribute it and/or modify
20 ;;; it under the terms of the GNU General Public License as published by 13 ;;; it under the terms of the GNU General Public License as published by
30 ;;; along with GNU Emacs; see the file COPYING. If not, write to the 23 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
31 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
32 ;;; Boston, MA 02111-1307, USA. 25 ;;; Boston, MA 02111-1307, USA.
33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 27
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 ;; For non-MULE
36 ;;; Base 64 encoding functions 29 (if (not (fboundp 'char-int))
37 ;;; This code was converted to lisp code by me from the C code in 30 (fset 'char-int 'identity))
38 ;;; ftp://cs.utk.edu/pub/MIME/b64encode.c 31
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 (defvar base64-alphabet
40 33 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
41 (defvar base64-code-string 34
42 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 35 (defvar base64-decoder-program nil
43 "Character set used for base64 decoding") 36 "*Non-nil value should be a string that names a MIME base64 decoder.
44 37 The program should expect to read base64 data on its standard
45 (defvar base64-decode-vector 38 input and write the converted data to its standard output.")
46 (let ((vec (make-vector 256 nil)) 39
47 (i 0) 40 (defvar base64-decoder-switches nil
48 (case-fold-search nil)) 41 "*List of command line flags passed to the command named by
49 (while (< i 256) 42 base64-decoder-program.")
50 (aset vec i (string-match (regexp-quote (char-to-string i)) 43
51 base64-code-string)) 44 (defvar base64-encoder-program nil
52 (setq i (1+ i))) 45 "*Non-nil value should be a string that names a MIME base64 encoder.
53 vec)) 46 The program should expect arbitrary data on its standard
54 47 input and write base64 data to its standard output.")
55 (defvar base64-max-line-length 64) 48
56 49 (defvar base64-encoder-switches nil
57 ;(defun b0 (x) (aref base64-code-string (logand (lsh x -18) 63))) 50 "*List of command line flags passed to the command named by
58 ;(defun b1 (x) (aref base64-code-string (logand (lsh x -12) 63))) 51 base64-encoder-program.")
59 ;(defun b2 (x) (aref base64-code-string (logand (lsh x -6) 63))) 52
60 ;(defun b3 (x) (aref base64-code-string (logand x 63))) 53 (defconst base64-alphabet-decoding-alist
61 54 '(
62 (defmacro b0 (x) (` (aref base64-code-string (logand (lsh (, x) -18) 63)))) 55 ( ?A . 00) ( ?B . 01) ( ?C . 02) ( ?D . 03) ( ?E . 04) ( ?F . 05)
63 (defmacro b1 (x) (` (aref base64-code-string (logand (lsh (, x) -12) 63)))) 56 ( ?G . 06) ( ?H . 07) ( ?I . 08) ( ?J . 09) ( ?K . 10) ( ?L . 11)
64 (defmacro b2 (x) (` (aref base64-code-string (logand (lsh (, x) -6) 63)))) 57 ( ?M . 12) ( ?N . 13) ( ?O . 14) ( ?P . 15) ( ?Q . 16) ( ?R . 17)
65 (defmacro b3 (x) (` (aref base64-code-string (logand (, x) 63)))) 58 ( ?S . 18) ( ?T . 19) ( ?U . 20) ( ?V . 21) ( ?W . 22) ( ?X . 23)
66 59 ( ?Y . 24) ( ?Z . 25) ( ?a . 26) ( ?b . 27) ( ?c . 28) ( ?d . 29)
67 (defun base64-encode (str) 60 ( ?e . 30) ( ?f . 31) ( ?g . 32) ( ?h . 33) ( ?i . 34) ( ?j . 35)
68 "Do base64 encoding on string STR and return the encoded string. 61 ( ?k . 36) ( ?l . 37) ( ?m . 38) ( ?n . 39) ( ?o . 40) ( ?p . 41)
69 This code was converted to lisp code by me from the C code in 62 ( ?q . 42) ( ?r . 43) ( ?s . 44) ( ?t . 45) ( ?u . 46) ( ?v . 47)
70 ftp://cs.utk.edu/pub/MIME/b64encode.c. Returns a string that is 63 ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53)
71 broken into `base64-max-line-length' byte lines." 64 ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59)
72 (or str (setq str (buffer-string))) 65 ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63)
73 (let ((x (base64-encode-internal str)) 66 ))
74 (y "")) 67
75 (while (> (length x) base64-max-line-length) 68 (defvar base64-alphabet-decoding-vector
76 (setq y (concat y (substring x 0 base64-max-line-length) "\n") 69 (let ((v (make-vector 123 nil))
77 x (substring x base64-max-line-length nil))) 70 (p base64-alphabet-decoding-alist))
78 (setq y (concat y x)) 71 (while p
79 y)) 72 (aset v (car (car p)) (cdr (car p)))
80 73 (setq p (cdr p)))
81 (defun base64-encode-internal (str) 74 v))
82 "Do base64 encoding on string STR and return the encoded string. 75
83 This code was converted to lisp code by me from the C code in 76 (defun base64-run-command-on-region (start end output-buffer command
84 ftp://cs.utk.edu/pub/MIME/b64encode.c. Returns the entire string, 77 &rest arg-list)
85 not broken up into `base64-max-line-length' byte lines." 78 (let ((tempfile nil) status errstring)
86 (let ( 79 (unwind-protect
87 (word 0) ; The word to translate 80 (progn
88 w1 w2 w3 81 (setq tempfile (make-temp-name "base64"))
89 ) 82 (setq status
90 (cond 83 (apply 'call-process-region
91 ((> (length str) 3) 84 start end command nil
92 (concat 85 (list output-buffer tempfile)
93 (base64-encode-internal (substring str 0 3)) 86 nil arg-list))
94 (base64-encode-internal (substring str 3 nil)))) 87 (cond ((equal status 0) t)
95 ((= (length str) 3) 88 ((zerop (save-excursion
96 (setq w1 (aref str 0) 89 (set-buffer (find-file-noselect tempfile))
97 w2 (aref str 1) 90 (buffer-size)))
98 w3 (aref str 2) 91 t)
99 word (logior 92 (t (save-excursion
100 (lsh (logand w1 255) 16) 93 (set-buffer (find-file-noselect tempfile))
101 (lsh (logand w2 255) 8) 94 (setq errstring (buffer-string))
102 (logand w3 255))) 95 (kill-buffer nil)
103 (format "%c%c%c%c" (b0 word) (b1 word) (b2 word) (b3 word))) 96 (cons status errstring)))))
104 ((= (length str) 2) 97 (condition-case ()
105 (setq w1 (aref str 0) 98 (delete-file tempfile)
106 w2 (aref str 1) 99 (error nil)))))
107 word (logior 100
108 (lsh (logand w1 255) 16) 101 (defun base64-insert-char (char &optional count ignored buffer)
109 (lsh (logand w2 255) 8) 102 (condition-case nil
110 0)) 103 (progn
111 (format "%c%c%c=" (b0 word) (b1 word) (b2 word))) 104 (insert-char char count ignored buffer)
112 ((= (length str) 1) 105 (fset 'vm-insert-char 'insert-char))
113 (setq w1 (aref str 0) 106 (wrong-number-of-arguments
114 word (logior 107 (fset 'base64-insert-char 'base64-xemacs-insert-char)
115 (lsh (logand w1 255) 16) 108 (base64-insert-char char count ignored buffer))))
116 0)) 109
117 (format "%c%c==" (b0 word) (b1 word))) 110 (defun base64-xemacs-insert-char (char &optional count ignored buffer)
118 (t "")))) 111 (if (and buffer (eq buffer (current-buffer)))
119 112 (insert-char char count)
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 (save-excursion
121 ;;; Base64 decoding functions 114 (set-buffer buffer)
122 ;;; Most of the decoding code is courtesy Francesco Potorti` 115 (insert-char char count))))
123 ;;; <F.Potorti@cnuce.cnr.it> 116
124 ;;; this is much faster than my original code - thanks! 117 (defun base64-decode-region (start end)
125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
126 (defun base64-decode-region (beg end)
127 (interactive "r") 118 (interactive "r")
128 (barf-if-buffer-read-only) 119 (message "Decoding base64...")
129 (let 120 (let ((work-buffer nil)
130 ((exchange (= (point) beg)) 121 (done nil)
131 (endchars 0) 122 (counter 0)
132 (list) (code)) 123 (bits 0)
133 (goto-char beg) 124 (lim 0) inputpos
134 (while (< (point) end) 125 (non-data-chars (concat "^=" base64-alphabet)))
135 (setq list (mapcar 126 (unwind-protect
136 (function 127 (save-excursion
137 (lambda (c) 128 (setq work-buffer (generate-new-buffer " *base64-work*"))
138 (cond 129 (buffer-disable-undo work-buffer)
139 ((aref base64-decode-vector c)) 130 (if base64-decoder-program
140 ((char-equal c ?=) 131 (let* ((binary-process-output t) ; any text already has CRLFs
141 (setq endchars (1+ endchars)) 132 (status (apply 'command-on-region
142 0) 133 start end work-buffer
143 (nil 134 base64-decoder-program
144 (error 135 base64-decoder-switches)))
145 "Character %c does not match Mime base64 coding" c))))) 136 (if (not (eq status t))
146 (buffer-substring (point) (+ (point) 4)))) 137 (error "%s" (cdr status))))
147 (setq code (+ (nth 3 list) (lsh (nth 2 list) 6) 138 (goto-char start)
148 (lsh (nth 1 list) 12) (lsh (car list) 18))) 139 (skip-chars-forward non-data-chars end)
149 (delete-char 4) 140 (while (not done)
150 (cond 141 (setq inputpos (point))
151 ((zerop endchars) 142 (cond
152 (insert (% (lsh code -16) 256) (% (lsh code -8) 256) (% code 256))) 143 ((> (skip-chars-forward base64-alphabet end) 0)
153 ((= endchars 1) 144 (setq lim (point))
154 (insert (% (lsh code -16) 256) (% (lsh code -8) 256)) 145 (while (< inputpos lim)
155 (setq end (point))) 146 (setq bits (+ bits
156 ((= endchars 2) 147 (aref base64-alphabet-decoding-vector
157 (insert (% (lsh code -16) 256)) 148 (char-int (char-after inputpos)))))
158 (setq end (point)))) 149 (setq counter (1+ counter)
159 (if (char-equal (following-char) ?\n) 150 inputpos (1+ inputpos))
160 (progn (delete-char 1) 151 (cond ((= counter 4)
161 (setq end (- end 2))) 152 (base64-insert-char (lsh bits -16) 1 nil work-buffer)
162 (setq end (1- end)))) 153 (base64-insert-char (logand (lsh bits -8) 255) 1 nil
163 )) 154 work-buffer)
164 ; (if exchange 155 (base64-insert-char (logand bits 255) 1 nil
165 ; (exchange-point-and-mark)))) 156 work-buffer)
166 157 (setq bits 0 counter 0))
167 (defun base64-decode (st &optional nd) 158 (t (setq bits (lsh bits 6)))))))
168 "Do base64 decoding on string STR and return the original string. 159 (cond
169 If given buffer positions, destructively decodes that area of the 160 ((= (point) end)
170 current buffer." 161 (if (not (zerop counter))
171 (let ((replace-p nil) 162 (error "at least %d bits missing at end of base64 encoding"
172 (retval nil)) 163 (* (- 4 counter) 6)))
173 (if (stringp st) 164 (setq done t))
174 nil 165 ((= (char-after (point)) ?=)
175 (setq st (prog1 166 (setq done t)
176 (buffer-substring st (or nd (point-max))) 167 (cond ((= counter 1)
177 (delete-region st (or nd (point-max)))) 168 (error "at least 2 bits missing at end of base64 encoding"))
178 replace-p t)) 169 ((= counter 2)
179 (setq retval 170 (base64-insert-char (lsh bits -10) 1 nil work-buffer))
180 (save-excursion 171 ((= counter 3)
181 (set-buffer (get-buffer-create " *b64decode*")) 172 (base64-insert-char (lsh bits -16) 1 nil work-buffer)
182 (erase-buffer) 173 (base64-insert-char (logand (lsh bits -8) 255)
183 (insert st) 174 1 nil work-buffer))
184 (goto-char (point-min)) 175 ((= counter 0) t)))
185 (while (re-search-forward "\r*\n" nil t) 176 (t (skip-chars-forward non-data-chars end)))))
186 (replace-match "")) 177 (or (markerp end) (setq end (set-marker (make-marker) end)))
187 (goto-char (point-min)) 178 (goto-char start)
188 (base64-decode-region (point-min) (point-max)) 179 (insert-buffer-substring work-buffer)
189 (buffer-string))) 180 (delete-region (point) end))
190 (if replace-p (insert retval)) 181 (and work-buffer (kill-buffer work-buffer))))
191 retval)) 182 (message "Decoding base64... done"))
183
184 (defun base64-encode-region (start end)
185 (interactive "r")
186 (message "Encoding base64...")
187 (let ((work-buffer nil)
188 (counter 0)
189 (cols 0)
190 (bits 0)
191 (alphabet base64-alphabet)
192 inputpos)
193 (unwind-protect
194 (save-excursion
195 (setq work-buffer (generate-new-buffer " *base64-work*"))
196 (buffer-disable-undo work-buffer)
197 (if base64-encoder-program
198 (let ((status (apply 'base64-run-command-on-region
199 start end work-buffer
200 base64-encoder-program
201 base64-encoder-switches)))
202 (if (not (eq status t))
203 (error "%s" (cdr status))))
204 (setq inputpos start)
205 (while (< inputpos end)
206 (setq bits (+ bits (char-int (char-after inputpos))))
207 (setq counter (1+ counter))
208 (cond ((= counter 3)
209 (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
210 work-buffer)
211 (base64-insert-char
212 (aref alphabet (logand (lsh bits -12) 63))
213 1 nil work-buffer)
214 (base64-insert-char
215 (aref alphabet (logand (lsh bits -6) 63))
216 1 nil work-buffer)
217 (base64-insert-char
218 (aref alphabet (logand bits 63))
219 1 nil work-buffer)
220 (setq cols (+ cols 4))
221 (cond ((= cols 72)
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 (> cols 0)
241 (base64-insert-char ?\n 1 nil work-buffer)))
242 (or (markerp end) (setq end (set-marker (make-marker) end)))
243 (goto-char start)
244 (insert-buffer-substring work-buffer)
245 (delete-region (point) end))
246 (and work-buffer (kill-buffer work-buffer))))
247 (message "Encoding base64... done"))
248
249 (defun base64-encode (string)
250 (save-excursion
251 (set-buffer (get-buffer-create " *base64-encode*"))
252 (erase-buffer)
253 (insert string)
254 (base64-encode-region (point-min) (point-max))
255 (skip-chars-backward " \t\r\n")
256 (delete-region (point-max) (point))
257 (prog1
258 (buffer-string)
259 (kill-buffer (current-buffer)))))
260
261 (defun base64-decode (string)
262 (save-excursion
263 (set-buffer (get-buffer-create " *base64-decode*"))
264 (erase-buffer)
265 (insert string)
266 (base64-decode-region (point-min) (point-max))
267 (goto-char (point-max))
268 (skip-chars-backward " \t\r\n")
269 (delete-region (point-max) (point))
270 (prog1
271 (buffer-string)
272 (kill-buffer (current-buffer)))))
192 273
193 (provide 'base64) 274 (provide 'base64)