Mercurial > hg > xemacs-beta

comparison lisp/url/base64.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; base64.el,v --- Base64 encoding functions
2 ;; Author: wmperry
3 ;; Created: 1996/04/22 15:08:08
4 ;; Version: 1.7
5 ;; Keywords: extensions
6
7 ;;; LCD Archive Entry:
8 ;;; base64.el|William M. Perry|wmperry@spry.com|
9 ;;; Package for encoding/decoding base64 data (MIME)|
10 ;;; 1996/04/22 15:08:08|1.7|Location Undetermined
11 ;;;
12
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 ;;; Base 64 encoding functions
15 ;;; This code was converted to lisp code by me from the C code in
16 ;;; ftp://cs.utk.edu/pub/MIME/b64encode.c
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18
19 (defvar base64-code-string
20 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
21 "Character set used for base64 decoding")
22
23 (defvar base64-decode-vector
24 (let ((vec (make-vector 256 nil))
25 (i 0)
26 (case-fold-search nil))
27 (while (< i 256)
28 (aset vec i (string-match (regexp-quote (char-to-string i))
29 base64-code-string))
30 (setq i (1+ i)))
31 vec))
32
33 (defvar base64-max-line-length 64)
34
35 ;(defun b0 (x) (aref base64-code-string (logand (lsh x -18) 63)))
36 ;(defun b1 (x) (aref base64-code-string (logand (lsh x -12) 63)))
37 ;(defun b2 (x) (aref base64-code-string (logand (lsh x -6) 63)))
38 ;(defun b3 (x) (aref base64-code-string (logand x 63)))
39
40 (defmacro b0 (x) (` (aref base64-code-string (logand (lsh (, x) -18) 63))))
41 (defmacro b1 (x) (` (aref base64-code-string (logand (lsh (, x) -12) 63))))
42 (defmacro b2 (x) (` (aref base64-code-string (logand (lsh (, x) -6) 63))))
43 (defmacro b3 (x) (` (aref base64-code-string (logand (, x) 63))))
44
45 (defun base64-encode (str)
46 "Do base64 encoding on string STR and return the encoded string.
47 This code was converted to lisp code by me from the C code in
48 ftp://cs.utk.edu/pub/MIME/b64encode.c. Returns a string that is
49 broken into `base64-max-line-length' byte lines."
50 (or str (setq str (buffer-string)))
51 (let ((x (base64-encode-internal str))
52 (y ""))
53 (while (> (length x) base64-max-line-length)
54 (setq y (concat y (substring x 0 base64-max-line-length) "\n")
55 x (substring x base64-max-line-length nil)))
56 (setq y (concat y x))
57 y))
58
59 (defun base64-encode-internal (str)
60 "Do base64 encoding on string STR and return the encoded string.
61 This code was converted to lisp code by me from the C code in
62 ftp://cs.utk.edu/pub/MIME/b64encode.c. Returns the entire string,
63 not broken up into `base64-max-line-length' byte lines."
64 (let (
65 (word 0) ; The word to translate
66 w1 w2 w3
67 )
68 (cond
69 ((> (length str) 3)
70 (concat
71 (base64-encode-internal (substring str 0 3))
72 (base64-encode-internal (substring str 3 nil))))
73 ((= (length str) 3)
74 (setq w1 (aref str 0)
75 w2 (aref str 1)
76 w3 (aref str 2)
77 word (logior
78 (lsh (logand w1 255) 16)
79 (lsh (logand w2 255) 8)
80 (logand w3 255)))
81 (format "%c%c%c%c" (b0 word) (b1 word) (b2 word) (b3 word)))
82 ((= (length str) 2)
83 (setq w1 (aref str 0)
84 w2 (aref str 1)
85 word (logior
86 (lsh (logand w1 255) 16)
87 (lsh (logand w2 255) 8)
88 0))
89 (format "%c%c%c=" (b0 word) (b1 word) (b2 word)))
90 ((= (length str) 1)
91 (setq w1 (aref str 0)
92 word (logior
93 (lsh (logand w1 255) 16)
94 0))
95 (format "%c%c==" (b0 word) (b1 word)))
96 (t ""))))
97
98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;; Base64 decoding functions
100 ;;; Most of the decoding code is courtesy Francesco Potorti`
101 ;;; <F.Potorti@cnuce.cnr.it>
102 ;;; this is much faster than my original code - thanks!
103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 (defun base64-decode-region (beg end)
105 (interactive "r")
106 (barf-if-buffer-read-only)
107 (let
108 ((exchange (= (point) beg))
109 (endchars 0)
110 (list) (code))
111 (goto-char beg)
112 (while (< (point) end)
113 (setq list (mapcar
114 (function
115 (lambda (c)
116 (cond
117 ((aref base64-decode-vector c))
118 ((char-equal c ?=)
119 (setq endchars (1+ endchars))
120 0)
121 (nil
122 (error
123 "Character %c does not match Mime base64 coding" c)))))
124 (buffer-substring (point) (+ (point) 4))))
125 (setq code (+ (nth 3 list) (lsh (nth 2 list) 6)
126 (lsh (nth 1 list) 12) (lsh (car list) 18)))
127 (delete-char 4)
128 (cond
129 ((zerop endchars)
130 (insert (% (lsh code -16) 256) (% (lsh code -8) 256) (% code 256)))
131 ((= endchars 1)
132 (insert (% (lsh code -16) 256) (% (lsh code -8) 256))
133 (setq end (point)))
134 ((= endchars 2)
135 (insert (% (lsh code -16) 256))
136 (setq end (point))))
137 (if (char-equal (following-char) ?\n)
138 (progn (delete-char 1)
139 (setq end (- end 2)))
140 (setq end (1- end))))
141 ))
142 ; (if exchange
143 ; (exchange-point-and-mark))))
144
145 (defun base64-decode (st &optional nd)
146 "Do base64 decoding on string STR and return the original string.
147 If given buffer positions, destructively decodes that area of the
148 current buffer."
149 (let ((replace-p nil)
150 (retval nil))
151 (if (stringp st)
152 nil
153 (setq st (prog1
154 (buffer-substring st (or nd (point-max)))
155 (delete-region st (or nd (point-max))))
156 replace-p t))
157 (setq retval
158 (save-excursion
159 (set-buffer (get-buffer-create " *b64decode*"))
160 (erase-buffer)
161 (insert st)
162 (goto-char (point-min))
163 (while (re-search-forward "\r*\n" nil t)
164 (replace-match ""))
165 (goto-char (point-min))
166 (base64-decode-region (point-min) (point-max))
167 (buffer-string)))
168 (if replace-p (insert retval))
169 retval))
170
171 (provide 'base64)