encode.lisp

Revision 2190, 9.5 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: encode.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	;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
23	;;;; - .asd file
24	;;;; - numerous speed optimizations
25	;;;; - conversion to and from integers
26	;;;; - Renamed functions now that supporting integer conversions
27	;;;; - URI-compatible encoding using :uri key
28	;;;;
29	;;;; $Id: encode.lisp 7061 2003-09-07 06:34:45Z kevin $
30
31	(in-package #:cl-base64)
32
33	(defun round-next-multiple (x n)
34	"Round x up to the next highest multiple of n."
35	(declare (fixnum n)
36	(optimize (speed 3) (safety 0) (space 0)))
37	(let ((remainder (mod x n)))
38	(declare (fixnum remainder))
39	(if (zerop remainder)
40	x
41	(the fixnum (+ x (the fixnum (- n remainder)))))))
42
43	(defmacro def--to-base64- (input-type output-type)
44	`(defun ,(intern (concatenate 'string (symbol-name input-type)
45	(symbol-name :-to-base64-)
46	(symbol-name output-type)))
47	(input
48	,@(when (eq output-type :stream)
49	'(output))
50	&key (uri nil) (columns 0))
51	"Encode a string array to base64. If columns is > 0, designates
52	maximum number of columns in a line and the string will be terminated
53	with a #\Newline."
54	(declare ,@(case input-type
55	(:string
56	'((string input)))
57	(:usb8-array
58	'((type (array (unsigned-byte 8) (*)) input))))
59	(fixnum columns)
60	(optimize (speed 3) (safety 0) (space 0)))
61	(let ((pad (if uri uri-pad-char pad-char))
62	(encode-table (if uri uri-encode-table encode-table)))
63	(declare (simple-string encode-table)
64	(character pad))
65	(let* ((string-length (length input))
66	(complete-group-count (truncate string-length 3))
67	(remainder (nth-value 1 (truncate string-length 3)))
68	(padded-length (* 4 (truncate (+ string-length 2) 3)))
69	,@(when (eq output-type :string)
70	'((num-lines (if (plusp columns)
71	(truncate (+ padded-length (1- columns)) columns)
72	0))
73	(num-breaks (if (plusp num-lines)
74	(1- num-lines)
75	0))
76	(strlen (+ padded-length num-breaks))
77	(result (make-string strlen))
78	(ioutput 0)))
79	(col (if (plusp columns)
80	0
81	(the fixnum (1+ padded-length)))))
82	(declare (fixnum string-length padded-length col
83	,@(when (eq output-type :string)
84	'(ioutput)))
85	,@(when (eq output-type :string)
86	'((simple-string result))))
87	(labels ((output-char (ch)
88	(if (= col columns)
89	(progn
90	,@(case output-type
91	(:stream
92	'((write-char #\Newline output)))
93	(:string
94	'((setf (schar result ioutput) #\Newline)
95	(incf ioutput))))
96	(setq col 1))
97	(incf col))
98	,@(case output-type
99	(:stream
100	'((write-char ch output)))
101	(:string
102	'((setf (schar result ioutput) ch)
103	(incf ioutput)))))
104	(output-group (svalue chars)
105	(declare (fixnum svalue chars))
106	(output-char
107	(schar encode-table
108	(the fixnum
109	(logand #x3f
110	(the fixnum (ash svalue -18))))))
111	(output-char
112	(schar encode-table
113	(the fixnum
114	(logand #x3f
115	(the fixnum (ash svalue -12))))))
116	(if (> chars 2)
117	(output-char
118	(schar encode-table
119	(the fixnum
120	(logand #x3f
121	(the fixnum (ash svalue -6))))))
122	(output-char pad))
123	(if (> chars 3)
124	(output-char
125	(schar encode-table
126	(the fixnum
127	(logand #x3f svalue))))
128	(output-char pad))))
129	(do ((igroup 0 (the fixnum (1+ igroup)))
130	(isource 0 (the fixnum (+ isource 3))))
131	((= igroup complete-group-count)
132	(cond
133	((= remainder 2)
134	(output-group
135	(the fixnum
136	(+
137	(the fixnum
138	(ash
139	,(case input-type
140	(:string
141	'(char-code (the character (char input isource))))
142	(:usb8-array
143	'(the fixnum (aref input isource))))
144	16))
145	(the fixnum
146	(ash
147	,(case input-type
148	(:string
149	'(char-code (the character (char input
150	(the fixnum (1+ isource))))))
151	(:usb8-array
152	'(the fixnum (aref input (the fixnum
153	(1+ isource))))))
154	8))))
155	3))
156	((= remainder 1)
157	(output-group
158	(the fixnum
159	(ash
160	,(case input-type
161	(:string
162	'(char-code (the character (char input isource))))
163	(:usb8-array
164	'(the fixnum (aref input isource))))
165	16))
166	2)))
167	,(case output-type
168	(:string
169	'result)
170	(:stream
171	'output)))
172	(declare (fixnum igroup isource))
173	(output-group
174	(the fixnum
175	(+
176	(the fixnum
177	(ash
178	(the fixnum
179	,(case input-type
180	(:string
181	'(char-code (the character (char input isource))))
182	(:usb8-array
183	'(aref input isource))))
184	16))
185	(the fixnum
186	(ash
187	(the fixnum
188	,(case input-type
189	(:string
190	'(char-code (the character (char input
191	(the fixnum (1+ isource))))))
192	(:usb8-array
193	'(aref input (1+ isource)))))
194	8))
195	(the fixnum
196	,(case input-type
197	(:string
198	'(char-code (the character (char input
199	(the fixnum (+ 2 isource))))))
200	(:usb8-array
201	'(aref input (+ 2 isource))))
202	)))
203	4)))))))
204
205	(def--to-base64- :string :string)
206	(def--to-base64- :string :stream)
207	(def--to-base64- :usb8-array :string)
208	(def--to-base64- :usb8-array :stream)
209
210
211	(defun integer-to-base64-string (input &key (uri nil) (columns 0))
212	"Encode an integer to base64 format."
213	(declare (integer input)
214	(fixnum columns)
215	(optimize (speed 3) (space 0) (safety 0)))
216	(let ((pad (if uri uri-pad-char pad-char))
217	(encode-table (if uri uri-encode-table encode-table)))
218	(declare (simple-string encode-table)
219	(character pad))
220	(let* ((input-bits (integer-length input))
221	(byte-bits (round-next-multiple input-bits 8))
222	(padded-bits (round-next-multiple byte-bits 6))
223	(remainder-padding (mod padded-bits 24))
224	(padding-bits (if (zerop remainder-padding)
225	0
226	(- 24 remainder-padding)))
227	(padding-chars (/ padding-bits 6))
228	(padded-length (/ (+ padded-bits padding-bits) 6))
229	(last-line-len (if (plusp columns)
230	(- padded-length (* columns
231	(truncate
232	padded-length columns)))
233	0))
234	(num-lines (if (plusp columns)
235	(truncate (+ padded-length (1- columns)) columns)
236	0))
237	(num-breaks (if (plusp num-lines)
238	(1- num-lines)
239	0))
240	(strlen (+ padded-length num-breaks))
241	(last-char (1- strlen))
242	(str (make-string strlen))
243	(col (if (zerop last-line-len)
244	columns
245	last-line-len)))
246	(declare (fixnum padded-length num-lines col last-char
247	padding-chars last-line-len))
248	(unless (plusp columns)
249	(setq col -1)) ;; set to flag to optimize in loop
250
251	(dotimes (i padding-chars)
252	(declare (fixnum i))
253	(setf (schar str (the fixnum (- last-char i))) pad))
254
255	(do* ((strpos (- last-char padding-chars) (1- strpos))
256	(int (ash input (/ padding-bits 3))))
257	((minusp strpos)
258	str)
259	(declare (fixnum strpos) (integer int))
260	(cond
261	((zerop col)
262	(setf (schar str strpos) #\Newline)
263	(setq col columns))
264	(t
265	(setf (schar str strpos)
266	(schar encode-table (the fixnum (logand int #x3f))))
267	(setq int (ash int -6))
268	(decf col)))))))
269
270	(defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
271	"Encode an integer to base64 format."
272	(declare (integer input)
273	(fixnum columns)
274	(optimize (speed 3) (space 0) (safety 0)))
275	(let ((pad (if uri uri-pad-char pad-char))
276	(encode-table (if uri uri-encode-table encode-table)))
277	(declare (simple-string encode-table)
278	(character pad))
279	(let* ((input-bits (integer-length input))
280	(byte-bits (round-next-multiple input-bits 8))
281	(padded-bits (round-next-multiple byte-bits 6))
282	(remainder-padding (mod padded-bits 24))
283	(padding-bits (if (zerop remainder-padding)
284	0
285	(- 24 remainder-padding)))
286	(padding-chars (/ padding-bits 6))
287	(padded-length (/ (+ padded-bits padding-bits) 6))
288	(strlen padded-length)
289	(nonpad-chars (- strlen padding-chars))
290	(last-nonpad-char (1- nonpad-chars))
291	(str (make-string strlen)))
292	(declare (fixnum padded-length last-nonpad-char))
293	(do* ((strpos 0 (the fixnum (1+ strpos)))
294	(int (ash input (/ padding-bits 3)) (ash int -6))
295	(6bit-value (the fixnum (logand int #x3f))
296	(the fixnum (logand int #x3f))))
297	((= strpos nonpad-chars)
298	(let ((col 0))
299	(declare (fixnum col))
300	(dotimes (i nonpad-chars)
301	(declare (fixnum i))
302	(write-char (schar str i) stream)
303	(when (plusp columns)
304	(incf col)
305	(when (= col columns)
306	(write-char #\Newline stream)
307	(setq col 0))))
308	(dotimes (ipad padding-chars)
309	(declare (fixnum ipad))
310	(write-char pad stream)
311	(when (plusp columns)
312	(incf col)
313	(when (= col columns)
314	(write-char #\Newline stream)
315	(setq col 0)))))
316	stream)
317	(declare (fixnum 6bit-value strpos)
318	(integer int))
319	(setf (schar str (- last-nonpad-char strpos))
320	(schar encode-table 6bit-value))
321	))))
322

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format