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.5 2003/05/06 16:21:06 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 (in-package #:cl-base64)
24 (eval-when (:compile-toplevel)
25 (declaim (optimize (space 0) (speed 3) (safety 1) (compilation-speed 0))))
28 (declaim (inline whitespace-p))
29 (defun whitespace-p (c)
30 "Returns T for a whitespace character."
31 (or (char= c #\Newline) (char= c #\Linefeed)
32 (char= c #\Return) (char= c #\Space)
39 (defmacro def-base64-stream-to-* (output-type)
40 `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
41 (symbol-name output-type)))
43 ,@(when (eq output-type :stream)
45 ,(concatenate 'string "Decode base64 stream to " (string-downcase
46 (symbol-name output-type)))
47 (declare (stream input)
49 (let ((pad (if uri *uri-pad-char* *pad-char*))
50 (decode-table (if uri *uri-decode-table* *decode-table*)))
51 (declare (type decode-table decode-table)
53 (let (,@(case output-type
55 '((result (make-string (* 3 (truncate (length string) 4))))))
57 '((result (make-array (* 3 (truncate (length string) 4))
58 :element-type '(unsigned-byte 8)
62 (declare ,@(case output-type
64 '((simple-string result)))
66 '((type (simple-array (usigned-byte 8) (*)) result))))
70 (char (read-char stream nil #\null)
71 (read-char stream nil #\null)))
76 ((:string :usb8-array)
79 ;; '(subseq result 0 ridx))))
81 (declare (fixnum bitstore bitcount)
83 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
84 (declare (fixnum svalue))
87 (setf bitstore (logior
88 (the fixnum (ash bitstore 6))
93 (let ((ovalue (the fixnum
97 (the fixnum (- bitcount))))
99 (declare (fixnum ovalue))
102 '(setf (char result ridx) (code-char ovalue)))
104 '(setf (aref result ridx) ovalue))
106 '(write-char (code-char ovalue) stream)))
108 (setf bitstore (the fixnum (logand bitstore #xFF))))))
110 ;; Could add checks to make sure padding is correct
111 ;; Currently, padding is ignored
117 (warn "Bad character ~W in base64 decode" char))
120 ;;(def-base64-stream-to-* :string)
121 ;;(def-base64-stream-to-* :stream)
122 ;;(def-base64-stream-to-* :usb8-array)
124 (defmacro def-base64-string-to-* (output-type)
125 `(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-)
126 (symbol-name output-type)))
127 (input &key (uri nil)
128 ,@(when (eq output-type :stream)
130 ,(concatenate 'string "Decode base64 string to " (string-downcase
131 (symbol-name output-type)))
132 (declare (string input)
133 (optimize (speed 3)))
134 (let ((pad (if uri *uri-pad-char* *pad-char*))
135 (decode-table (if uri *uri-decode-table* *decode-table*)))
136 (declare (type decode-table decode-table)
137 (type character pad))
138 (let (,@(case output-type
140 '((result (make-string (* 3 (truncate (length input) 4))))))
142 '((result (make-array (* 3 (truncate (length input) 4))
143 :element-type '(unsigned-byte 8)
147 (declare ,@(case output-type
149 '((simple-string result)))
151 '((type (simple-array (unsigned-byte 8) (*)) result))))
154 for char of-type character across input
155 for svalue of-type fixnum = (aref decode-table
156 (the fixnum (char-code char)))
157 with bitstore of-type fixnum = 0
158 with bitcount of-type fixnum = 0
162 (setf bitstore (logior
163 (the fixnum (ash bitstore 6))
166 (when (>= bitcount 8)
168 (let ((ovalue (the fixnum
172 (the fixnum (- bitcount))))
174 (declare (fixnum ovalue))
177 '(setf (char result ridx) (code-char ovalue)))
179 '(setf (aref result ridx) ovalue))
181 '(write-char (code-char ovalue) stream)))
183 (setf bitstore (the fixnum (logand bitstore #xFF))))))
185 ;; Could add checks to make sure padding is correct
186 ;; Currently, padding is ignored
192 (warn "Bad character ~W in base64 decode" char))
197 ((:usb8-array :string)
198 '(subseq result 0 ridx)))))))
200 (def-base64-string-to-* :string)
201 (def-base64-string-to-* :stream)
202 (def-base64-string-to-* :usb8-array)
204 ;; input-mode can be :string or :stream
205 ;; input-format can be :character or :usb8
207 (defun base64-string-to-integer (string &key (uri nil))
208 "Decodes a base64 string to an integer"
209 (declare (string string)
210 (optimize (speed 3)))
211 (let ((pad (if uri *uri-pad-char* *pad-char*))
212 (decode-table (if uri *uri-decode-table* *decode-table*)))
213 (declare (type decode-table decode-table)
216 (declare (integer value))
218 for char of-type character across string
219 for svalue of-type fixnum =
220 (aref decode-table (the fixnum (char-code char)))
224 (setq value (+ svalue (ash value 6))))
226 (setq value (ash value -2)))
231 (warn "Bad character ~W in base64 decode" char))))
235 (defun base64-stream-to-integer (stream &key (uri nil))
236 "Decodes a base64 string to an integer"
237 (declare (stream stream)
238 (optimize (speed 3)))
239 (let ((pad (if uri *uri-pad-char* *pad-char*))
240 (decode-table (if uri *uri-decode-table* *decode-table*)))
241 (declare (type decode-table decode-table)
244 (char (read-char stream nil #\null)
245 (read-char stream nil #\null)))
248 (declare (integer value)
250 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
251 (declare (fixnum svalue))
254 (setq value (+ svalue (ash value 6))))
256 (setq value (ash value -2)))
257 ((whitespace-p char) ; ignore whitespace
260 (warn "Bad character ~W in base64 decode" char)))))))