1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: cl-base64 encoding routines
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Dec 2002
10 ;;;; $Id: decode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
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
16 ;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
18 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
19 ;;;; Permission to use with BSD-style license included in the COPYING file
20 ;;;; *************************************************************************
22 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
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)
34 (defun base64-to-string (string &key (uri nil))
35 "Decode a base64 string to a string array."
36 (declare (string string)
38 (let ((pad (if uri *uri-pad-char* *pad-char*))
39 (decode-table (if uri *uri-decode-table* *decode-table*)))
40 (declare (type decode-table decode-table)
42 (let ((result (make-string (* 3 (truncate (length string) 4))))
44 (declare (simple-string result)
47 for char of-type character across string
48 for svalue of-type fixnum = (aref decode-table
49 (the fixnum (char-code char)))
50 with bitstore of-type fixnum = 0
51 with bitcount of-type fixnum = 0
55 (setf bitstore (logior
56 (the fixnum (ash bitstore 6))
61 (setf (char result ridx)
62 (code-char (the fixnum
66 (the fixnum (- bitcount))))
69 (setf bitstore (the fixnum (logand bitstore #xFF)))))
71 ;; Could add checks to make sure padding is correct
72 ;; Currently, padding is ignored
78 (warn "Bad character ~W in base64 decode" char))
80 (subseq result 0 ridx))))
83 (def-base64-stream-to-* :string)
84 (def-base64-stream-to-* :stream)
85 (def-base64-stream-to-* :usb8-array)
88 (defmacro def-base64-string-to-* (output-type)
89 `(defun ,(case output-type
91 'base64-string-to-string)
93 'base64-string-to-stream)
95 'base64-string-to-usb8-array))
97 ,@(when (eq output-type :stream)
99 "Decode base64 string"
100 (declare (input string)
101 (optimize (speed 3)))
102 (let ((pad (if uri *uri-pad-char* *pad-char*))
103 (decode-table (if uri *uri-decode-table* *decode-table*)))
104 (declare (type decode-table decode-table)
106 (let (,@(case output-type
108 '((result (make-string (* 3 (truncate (length string) 4))))))
110 '((result (make-array (* 3 (truncate (length string) 4))
111 :element-type '(unsigned-byte 8)
115 (declare ,@(case output-type
117 '((simple-string result))
119 '((type (array fixnum (*)) result)))))
122 for char of-type character across string
123 for svalue of-type fixnum = (aref decode-table
124 (the fixnum (char-code char)))
125 with bitstore of-type fixnum = 0
126 with bitcount of-type fixnum = 0
130 (setf bitstore (logior
131 (the fixnum (ash bitstore 6))
134 (when (>= bitcount 8)
136 (let ((svalue (the fixnum
140 (the fixnum (- bitcount))))
142 (declare (fixnum svalue))
145 (setf (char result ridx) (code-char svalue)))
147 (setf (aref result ridx) svalue))
149 (write-char (code-char svalue) stream)))
151 (setf bitstore (the fixnum (logand bitstore #xFF)))))
153 ;; Could add checks to make sure padding is correct
154 ;; Currently, padding is ignored
160 (warn "Bad character ~W in base64 decode" char))
162 (subseq result 0 ridx))))))
164 (def-base64-string-to-* :string)
165 (def-base64-string-to-* :stream)
166 (def-base64-string-to-* :usb8-array)
168 ;; input-mode can be :string or :stream
169 ;; input-format can be :character or :usb8
171 (defun base64-string-to-integer (string &key (uri nil))
172 "Decodes a base64 string to an integer"
173 (declare (string string)
174 (optimize (speed 3)))
175 (let ((pad (if uri *uri-pad-char* *pad-char*))
176 (decode-table (if uri *uri-decode-table* *decode-table*)))
177 (declare (type decode-table decode-table)
180 (declare (integer value))
182 for char of-type character across string
183 for svalue of-type fixnum =
184 (aref decode-table (the fixnum (char-code char)))
188 (setq value (+ svalue (ash value 6))))
190 (setq value (ash value -2)))
195 (warn "Bad character ~W in base64 decode" char))))
198 (defun base64-stream-to-integer (stream &key (uri nil))
199 "Decodes a base64 string to an integer"
200 (declare (stream stream)
201 (optimize (speed 3)))
202 (let ((pad (if uri *uri-pad-char* *pad-char*))
203 (decode-table (if uri *uri-decode-table* *decode-table*)))
204 (declare (type decode-table decode-table)
207 (char (read-char stream nil #\null)
208 (read-char stream nil #\null)))
211 (declare (value integer)
213 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
214 (declare (fixnum svalue))
217 (setq value (+ svalue (ash value 6))))
219 (setq value (ash value -2)))
220 ((whitespace-p char) ; ignore whitespace
223 (warn "Bad character ~W in base64 decode" char))))