"SfR Fresh" - the SfR Freeware/Shareware Archive 
Member "gnus-5.10.10/contrib/base64.el" of archive gnus-5.10.10.tar.gz:
As a special service "SfR Fresh" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting with prefixed line numbers.
Alternatively you can here view or download the uninterpreted source code file.
That can be also achieved for any archive member file by clicking within an archive contents listing on the first character of the file(path) respectively on the according byte size field.
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 3, 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., 51 Franklin Street, Fifth Floor,
25 ;;; Boston, MA 02110-1301, 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)
279
280 ;;; arch-tag: cf16aa86-3365-4675-bc57-912d86bdfdb7