decode.lisp

Revision 2190, 7.8 kB (checked in by hhubner, 1 year ago)
add more thirdparty libs
Property svn:executable set to ``*

Line
1	;;;; -- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 --
2	;;;; *************************************************************************
3	;;;; FILE IDENTIFICATION
4	;;;;
5	;;;; Name: encode.lisp
6	;;;; Purpose: cl-base64 encoding routines
7	;;;; Programmer: Kevin M. Rosenberg
8	;;;; Date Started: Dec 2002
9	;;;;
10	;;;; $Id: decode.lisp 7061 2003-09-07 06:34:45Z kevin $
11	;;;;
12	;;;; This file implements the Base64 transfer encoding algorithm as
13	;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
14	;;;; See: http://www.ietf.org/rfc/rfc1521.txt
15	;;;;
16	;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
17	;;;;
18	;;;; Copyright 2002-2003 Kevin M. Rosenberg
19	;;;; Permission to use with BSD-style license included in the COPYING file
20	;;;; *************************************************************************
21
22	(in-package #:cl-base64)
23
24	(declaim (inline whitespace-p))
25	(defun whitespace-p (c)
26	"Returns T for a whitespace character."
27	(or (char= c #\Newline) (char= c #\Linefeed)
28	(char= c #\Return) (char= c #\Space)
29	(char= c #\Tab)))
30
31
32	;;; Decoding
33
34	#+ignore
35	(defmacro def-base64-stream-to-* (output-type)
36	`(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
37	(symbol-name output-type)))
38	(input &key (uri nil)
39	,@(when (eq output-type :stream)
40	'(stream)))
41	,(concatenate 'string "Decode base64 stream to " (string-downcase
42	(symbol-name output-type)))
43	(declare (stream input)
44	(optimize (speed 3) (space 0) (safety 0)))
45	(let ((pad (if uri uri-pad-char pad-char))
46	(decode-table (if uri uri-decode-table decode-table)))
47	(declare (type decode-table decode-table)
48	(type character pad))
49	(let (,@(case output-type
50	(:string
51	'((result (make-string (* 3 (truncate (length string) 4))))))
52	(:usb8-array
53	'((result (make-array (* 3 (truncate (length string) 4))
54	:element-type '(unsigned-byte 8)
55	:fill-pointer nil
56	:adjustable nil)))))
57	(ridx 0))
58	(declare ,@(case output-type
59	(:string
60	'((simple-string result)))
61	(:usb8-array
62	'((type (simple-array (usigned-byte 8) (*)) result))))
63	(fixnum ridx))
64	(do* ((bitstore 0)
65	(bitcount 0)
66	(char (read-char stream nil #\null)
67	(read-char stream nil #\null)))
68	((eq char #\null)
69	,(case output-type
70	(:stream
71	'stream)
72	((:string :usb8-array)
73	'result)
74	;; ((:stream :string)
75	;; '(subseq result 0 ridx))))
76	))
77	(declare (fixnum bitstore bitcount)
78	(character char))
79	(let ((svalue (aref decode-table (the fixnum (char-code char)))))
80	(declare (fixnum svalue))
81	(cond
82	((>= svalue 0)
83	(setf bitstore (logior
84	(the fixnum (ash bitstore 6))
85	svalue))
86	(incf bitcount 6)
87	(when (>= bitcount 8)
88	(decf bitcount 8)
89	(let ((ovalue (the fixnum
90	(logand
91	(the fixnum
92	(ash bitstore
93	(the fixnum (- bitcount))))
94	#xFF))))
95	(declare (fixnum ovalue))
96	,(case output-type
97	(:string
98	'(setf (char result ridx) (code-char ovalue)))
99	(:usb8-array
100	'(setf (aref result ridx) ovalue))
101	(:stream
102	'(write-char (code-char ovalue) stream)))
103	(incf ridx)
104	(setf bitstore (the fixnum (logand bitstore #xFF))))))
105	((char= char pad)
106	;; Could add checks to make sure padding is correct
107	;; Currently, padding is ignored
108	)
109	((whitespace-p char)
110	;; Ignore whitespace
111	)
112	((minusp svalue)
113	(warn "Bad character ~W in base64 decode" char))
114	)))))))
115
116	;;(def-base64-stream-to-* :string)
117	;;(def-base64-stream-to-* :stream)
118	;;(def-base64-stream-to-* :usb8-array)
119
120	(defmacro def-base64-string-to-* (output-type)
121	`(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-)
122	(symbol-name output-type)))
123	(input &key (uri nil)
124	,@(when (eq output-type :stream)
125	'(stream)))
126	,(concatenate 'string "Decode base64 string to " (string-downcase
127	(symbol-name output-type)))
128	(declare (string input)
129	(optimize (speed 3) (safety 0) (space 0)))
130	(let ((pad (if uri uri-pad-char pad-char))
131	(decode-table (if uri uri-decode-table decode-table)))
132	(declare (type decode-table decode-table)
133	(type character pad))
134	(let (,@(case output-type
135	(:string
136	'((result (make-string (* 3 (truncate (length input) 4))))))
137	(:usb8-array
138	'((result (make-array (* 3 (truncate (length input) 4))
139	:element-type '(unsigned-byte 8)
140	:fill-pointer nil
141	:adjustable nil)))))
142	(ridx 0))
143	(declare ,@(case output-type
144	(:string
145	'((simple-string result)))
146	(:usb8-array
147	'((type (simple-array (unsigned-byte 8) (*)) result))))
148	(fixnum ridx))
149	(loop
150	for char of-type character across input
151	for svalue of-type fixnum = (aref decode-table
152	(the fixnum (char-code char)))
153	with bitstore of-type fixnum = 0
154	with bitcount of-type fixnum = 0
155	do
156	(cond
157	((>= svalue 0)
158	(setf bitstore (logior
159	(the fixnum (ash bitstore 6))
160	svalue))
161	(incf bitcount 6)
162	(when (>= bitcount 8)
163	(decf bitcount 8)
164	(let ((ovalue (the fixnum
165	(logand
166	(the fixnum
167	(ash bitstore
168	(the fixnum (- bitcount))))
169	#xFF))))
170	(declare (fixnum ovalue))
171	,(case output-type
172	(:string
173	'(setf (char result ridx) (code-char ovalue)))
174	(:usb8-array
175	'(setf (aref result ridx) ovalue))
176	(:stream
177	'(write-char (code-char ovalue) stream)))
178	(incf ridx)
179	(setf bitstore (the fixnum (logand bitstore #xFF))))))
180	((char= char pad)
181	;; Could add checks to make sure padding is correct
182	;; Currently, padding is ignored
183	)
184	((whitespace-p char)
185	;; Ignore whitespace
186	)
187	((minusp svalue)
188	(warn "Bad character ~W in base64 decode" char))
189	))
190	,(case output-type
191	(:stream
192	'stream)
193	((:usb8-array :string)
194	'(subseq result 0 ridx)))))))
195
196	(def-base64-string-to-* :string)
197	(def-base64-string-to-* :stream)
198	(def-base64-string-to-* :usb8-array)
199
200	;; input-mode can be :string or :stream
201	;; input-format can be :character or :usb8
202
203	(defun base64-string-to-integer (string &key (uri nil))
204	"Decodes a base64 string to an integer"
205	(declare (string string)
206	(optimize (speed 3) (safety 0) (space 0)))
207	(let ((pad (if uri uri-pad-char pad-char))
208	(decode-table (if uri uri-decode-table decode-table)))
209	(declare (type decode-table decode-table)
210	(character pad))
211	(let ((value 0))
212	(declare (integer value))
213	(loop
214	for char of-type character across string
215	for svalue of-type fixnum =
216	(aref decode-table (the fixnum (char-code char)))
217	do
218	(cond
219	((>= svalue 0)
220	(setq value (+ svalue (ash value 6))))
221	((char= char pad)
222	(setq value (ash value -2)))
223	((whitespace-p char)
224	; ignore whitespace
225	)
226	((minusp svalue)
227	(warn "Bad character ~W in base64 decode" char))))
228	value)))
229
230
231	(defun base64-stream-to-integer (stream &key (uri nil))
232	"Decodes a base64 string to an integer"
233	(declare (stream stream)
234	(optimize (speed 3) (space 0) (safety 0)))
235	(let ((pad (if uri uri-pad-char pad-char))
236	(decode-table (if uri uri-decode-table decode-table)))
237	(declare (type decode-table decode-table)
238	(character pad))
239	(do* ((value 0)
240	(char (read-char stream nil #\null)
241	(read-char stream nil #\null)))
242	((eq char #\null)
243	value)
244	(declare (integer value)
245	(character char))
246	(let ((svalue (aref decode-table (the fixnum (char-code char)))))
247	(declare (fixnum svalue))
248	(cond
249	((>= svalue 0)
250	(setq value (+ svalue (ash value 6))))
251	((char= char pad)
252	(setq value (ash value -2)))
253	((whitespace-p char) ; ignore whitespace
254	)
255	((minusp svalue)
256	(warn "Bad character ~W in base64 decode" char)))))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format