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
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 (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)
35 (defmacro def-base64-stream-to-* (output-type)
36 `(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
37 (symbol-name output-type)))
39 ,@(when (eq output-type :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)
49 (let (,@(case output-type
51 '((result (make-string (* 3 (truncate (length string) 4))))))
53 '((result (make-array (* 3 (truncate (length string) 4))
54 :element-type '(unsigned-byte 8)
58 (declare ,@(case output-type
60 '((simple-string result)))
62 '((type (simple-array (usigned-byte 8) (*)) result))))
66 (char (read-char stream nil #\null)
67 (read-char stream nil #\null)))
72 ((:string :usb8-array)
75 ;; '(subseq result 0 ridx))))
77 (declare (fixnum bitstore bitcount)
79 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
80 (declare (fixnum svalue))
83 (setf bitstore (logior
84 (the fixnum (ash bitstore 6))
89 (let ((ovalue (the fixnum
93 (the fixnum (- bitcount))))
95 (declare (fixnum ovalue))
98 '(setf (char result ridx) (code-char ovalue)))
100 '(setf (aref result ridx) ovalue))
102 '(write-char (code-char ovalue) stream)))
104 (setf bitstore (the fixnum (logand bitstore #xFF))))))
106 ;; Could add checks to make sure padding is correct
107 ;; Currently, padding is ignored
113 (warn "Bad character ~W in base64 decode" char))
116 ;;(def-base64-stream-to-* :string)
117 ;;(def-base64-stream-to-* :stream)
118 ;;(def-base64-stream-to-* :usb8-array)
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)
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
136 '((result (make-string (* 3 (truncate (length input) 4))))))
138 '((result (make-array (* 3 (truncate (length input) 4))
139 :element-type '(unsigned-byte 8)
143 (declare ,@(case output-type
145 '((simple-string result)))
147 '((type (simple-array (unsigned-byte 8) (*)) result))))
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
158 (setf bitstore (logior
159 (the fixnum (ash bitstore 6))
162 (when (>= bitcount 8)
164 (let ((ovalue (the fixnum
168 (the fixnum (- bitcount))))
170 (declare (fixnum ovalue))
173 '(setf (char result ridx) (code-char ovalue)))
175 '(setf (aref result ridx) ovalue))
177 '(write-char (code-char ovalue) stream)))
179 (setf bitstore (the fixnum (logand bitstore #xFF))))))
181 ;; Could add checks to make sure padding is correct
182 ;; Currently, padding is ignored
188 (warn "Bad character ~W in base64 decode" char))
193 ((:usb8-array :string)
194 '(subseq result 0 ridx)))))))
196 (def-base64-string-to-* :string)
197 (def-base64-string-to-* :stream)
198 (def-base64-string-to-* :usb8-array)
200 ;; input-mode can be :string or :stream
201 ;; input-format can be :character or :usb8
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)
212 (declare (integer value))
214 for char of-type character across string
215 for svalue of-type fixnum =
216 (aref decode-table (the fixnum (char-code char)))
220 (setq value (+ svalue (ash value 6))))
222 (setq value (ash value -2)))
227 (warn "Bad character ~W in base64 decode" char))))
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)
240 (char (read-char stream nil #\null)
241 (read-char stream nil #\null)))
244 (declare (integer value)
246 (let ((svalue (aref decode-table (the fixnum (char-code char)))))
247 (declare (fixnum svalue))
250 (setq value (+ svalue (ash value 6))))
252 (setq value (ash value -2)))
253 ((whitespace-p char) ; ignore whitespace
256 (warn "Bad character ~W in base64 decode" char)))))))