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.4 2003/01/14 11:59:44 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 (in-package #:cl-base64)
26 (declaim (inline whitespace-p))
27 (defun whitespace-p (c)
28 "Returns T for a whitespace character."
29 (or (char= c #\Newline) (char= c #\Linefeed)
30 (char= c #\Return) (char= c #\Space)
37 (defmacro def-base64-stream-to-* (output-type)
38 `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
39 (symbol-name output-type)))
41 ,@(when (eq output-type :stream)
43 ,(concatenate 'string "Decode base64 stream to " (string-downcase
44 (symbol-name output-type)))
45 (declare (stream input)
47 (let ((pad (if uri *uri-pad-char* *pad-char*))
48 (decode-table (if uri *uri-decode-table* *decode-table*)))
49 (declare (type decode-table decode-table)
51 (let (,@(case output-type
53 '((result (make-string (* 3 (truncate (length string) 4))))))
55 '((result (make-array (* 3 (truncate (length string) 4))
56 :element-type '(unsigned-byte 8)
60 (declare ,@(case output-type
62 '((simple-string result)))
64 '((type (simple-array (usigned-byte 8) (*)) result))))
68 (char (read-char stream nil #\null)
69 (read-char stream nil #\null)))
74 ((:string :usb8-array)
77 ;; '(subseq result 0 ridx))))
79 (declare (fixnum bitstore bitcount)
81 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
82 (declare (fixnum svalue))
85 (setf bitstore (logior
86 (the fixnum (ash bitstore 6))
91 (let ((ovalue (the fixnum
95 (the fixnum (- bitcount))))
97 (declare (fixnum ovalue))
100 '(setf (char result ridx) (code-char ovalue)))
102 '(setf (aref result ridx) ovalue))
104 '(write-char (code-char ovalue) stream)))
106 (setf bitstore (the fixnum (logand bitstore #xFF))))))
108 ;; Could add checks to make sure padding is correct
109 ;; Currently, padding is ignored
115 (warn "Bad character ~W in base64 decode" char))
118 ;;(def-base64-stream-to-* :string)
119 ;;(def-base64-stream-to-* :stream)
120 ;;(def-base64-stream-to-* :usb8-array)
122 (defmacro def-base64-string-to-* (output-type)
123 `(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-)
124 (symbol-name output-type)))
125 (input &key (uri nil)
126 ,@(when (eq output-type :stream)
128 ,(concatenate 'string "Decode base64 string to " (string-downcase
129 (symbol-name output-type)))
130 (declare (string input)
131 (optimize (speed 3)))
132 (let ((pad (if uri *uri-pad-char* *pad-char*))
133 (decode-table (if uri *uri-decode-table* *decode-table*)))
134 (declare (type decode-table decode-table)
135 (type character pad))
136 (let (,@(case output-type
138 '((result (make-string (* 3 (truncate (length input) 4))))))
140 '((result (make-array (* 3 (truncate (length input) 4))
141 :element-type '(unsigned-byte 8)
145 (declare ,@(case output-type
147 '((simple-string result)))
149 '((type (simple-array (unsigned-byte 8) (*)) result))))
152 for char of-type character across input
153 for svalue of-type fixnum = (aref decode-table
154 (the fixnum (char-code char)))
155 with bitstore of-type fixnum = 0
156 with bitcount of-type fixnum = 0
160 (setf bitstore (logior
161 (the fixnum (ash bitstore 6))
164 (when (>= bitcount 8)
166 (let ((ovalue (the fixnum
170 (the fixnum (- bitcount))))
172 (declare (fixnum ovalue))
175 '(setf (char result ridx) (code-char ovalue)))
177 '(setf (aref result ridx) ovalue))
179 '(write-char (code-char ovalue) stream)))
181 (setf bitstore (the fixnum (logand bitstore #xFF))))))
183 ;; Could add checks to make sure padding is correct
184 ;; Currently, padding is ignored
190 (warn "Bad character ~W in base64 decode" char))
195 ((:usb8-array :string)
196 '(subseq result 0 ridx)))))))
198 (def-base64-string-to-* :string)
199 (def-base64-string-to-* :stream)
200 (def-base64-string-to-* :usb8-array)
202 ;; input-mode can be :string or :stream
203 ;; input-format can be :character or :usb8
205 (defun base64-string-to-integer (string &key (uri nil))
206 "Decodes a base64 string to an integer"
207 (declare (string string)
208 (optimize (speed 3)))
209 (let ((pad (if uri *uri-pad-char* *pad-char*))
210 (decode-table (if uri *uri-decode-table* *decode-table*)))
211 (declare (type decode-table decode-table)
214 (declare (integer value))
216 for char of-type character across string
217 for svalue of-type fixnum =
218 (aref decode-table (the fixnum (char-code char)))
222 (setq value (+ svalue (ash value 6))))
224 (setq value (ash value -2)))
229 (warn "Bad character ~W in base64 decode" char))))
233 (defun base64-stream-to-integer (stream &key (uri nil))
234 "Decodes a base64 string to an integer"
235 (declare (stream stream)
236 (optimize (speed 3)))
237 (let ((pad (if uri *uri-pad-char* *pad-char*))
238 (decode-table (if uri *uri-decode-table* *decode-table*)))
239 (declare (type decode-table decode-table)
242 (char (read-char stream nil #\null)
243 (read-char stream nil #\null)))
246 (declare (integer value)
248 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
249 (declare (fixnum svalue))
252 (setq value (+ svalue (ash value 6))))
254 (setq value (ash value -2)))
255 ((whitespace-p char) ; ignore whitespace
258 (warn "Bad character ~W in base64 decode" char)))))))