-(defun base64-stream-to-integer (stream &key (uri nil))
- "Decodes a base64 string to an integer"
- (declare (stream stream)
- (optimize (speed 3)))
- (let ((pad (if uri *uri-pad-char* *pad-char*))
- (decode-table (if uri *uri-decode-table* *decode-table*)))
- (declare (type decode-table decode-table)
- (character pad))
- (do* ((value 0)
- (char (read-char stream nil #\null)
- (read-char stream nil #\null)))
- ((eq char #\null)
- value)
- (declare (integer value)
- (character char))
- (let ((svalue (aref decode-table (the fixnum (char-code char)))))
- (declare (fixnum svalue))
- (cond
- ((>= svalue 0)
- (setq value (+ svalue (ash value 6))))
- ((char= char pad)
- (setq value (ash value -2)))
- ((whitespace-p char) ; ignore whitespace
- )
- ((minusp svalue)
- (warn "Bad character ~W in base64 decode" char)))))))
+ :ignore - Whitespace characters are ignored (default).
+ :signal - Signal a BAD-BASE64-CHARACTER condition using SIGNAL.
+ :error - Signal a BAD-BASE64-CHARACTER condition using ERROR."
+ hose sink)
+ (declare (optimize (speed 3) (safety 1))
+ (type decode-table table)
+ (type ,(ecase hose
+ (:stream 'stream)
+ (:string 'string))
+ input))
+ (let/typed ((decode-table (if uri +uri-decode-table+ table)
+ decode-table)
+ ,@(ecase sink
+ (:stream)
+ (:usb8-array
+ (ecase hose
+ (:stream
+ `((result (make-array 1024
+ :element-type '(unsigned-byte 8)
+ :adjustable t
+ :fill-pointer 0)
+ (array (unsigned-byte 8) (*)))))
+ (:string
+ `((result (make-array (* 3 (ceiling (length input) 4))
+ :element-type '(unsigned-byte 8))
+ (simple-array (unsigned-byte 8) (*)))
+ (rpos 0 array-index)))))
+ (:string
+ (case hose
+ (:stream
+ `((result (make-array 1024
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0)
+ (array character (*)))))
+ (:string
+ `((result (make-array (* 3 (ceiling (length input) 4))
+ :element-type 'character)
+ (simple-array character (*)))
+ (rpos 0 array-index)))))
+ (:integer
+ `((result 0 unsigned-byte)))))
+ (flet ((bad-char (pos code &optional (action :error))
+ (let ((args (list 'bad-base64-character
+ :input input
+ :position pos
+ :code code)))
+ (ecase action
+ (:error
+ (apply #'error args))
+ (:cerror
+ (apply #'cerror "Ignore the error and continue." args))
+ (:signal
+ (apply #'signal args)))))
+ (incomplete-input (pos)
+ (error 'incomplete-base64-data :input input :position pos)))
+ ,(let ((body
+ `(let/typed ((ipos 0 array-index)
+ (bitstore 0 (unsigned-byte 24))
+ (bitcount 0 (integer 0 14))
+ (svalue -1 (signed-byte 8))
+ (padchar 0 (integer 0 3))
+ (code 0 fixnum))
+ (loop
+ ,@(ecase hose
+ (:string
+ `((if (< ipos length)
+ (setq code (char-code (aref input ipos)))
+ (return))))
+ (:stream
+ `((let ((char (read-char input nil nil)))
+ (if char
+ (setq code (char-code char))
+ (return))))))
+ (cond
+ ((or (< 127 code)
+ (= -1 (setq svalue (aref decode-table code))))
+ (bad-char ipos code))
+ ((= -2 svalue)
+ (cond ((<= (incf padchar) 2)
+ (unless (<= 2 bitcount)
+ (bad-char ipos code))
+ (decf bitcount 2))
+ (t
+ (bad-char ipos code))))
+ ((= -3 svalue)
+ (ecase whitespace
+ (:ignore
+ ;; Do nothing.
+ )
+ (:error
+ (bad-char ipos code :error))
+ (:signal
+ (bad-char ipos code :signal))))
+ ((not (zerop padchar))
+ (bad-char ipos code))
+ (t
+ (setf bitstore (logior (the (unsigned-byte 24)
+ (ash bitstore 6))
+ svalue))
+ (incf bitcount 6)
+ (when (>= bitcount 8)
+ (decf bitcount 8)
+ (let ((byte (logand (the (unsigned-byte 24)
+ (ash bitstore (- bitcount)))
+ #xFF)))
+ (declare (type (unsigned-byte 8) byte))
+ ,@(ecase sink
+ (:usb8-array
+ (ecase hose
+ (:string
+ `((setf (aref result rpos) byte)
+ (incf rpos)))
+ (:stream
+ `((vector-push-extend byte result)))))
+ (:string
+ (ecase hose
+ (:string
+ `((setf (schar result rpos)
+ (code-char byte))
+ (incf rpos)))
+ (:stream
+ `((vector-push-extend (code-char byte)
+ result)))))
+ (:integer
+ `((setq result
+ (logior (ash result 8) byte))))
+ (:stream
+ '((write-char (code-char byte) stream)))))
+ (setf bitstore (logand bitstore #xFF)))))
+ (incf ipos))
+ (unless (zerop bitcount)
+ (incomplete-input ipos))
+ ,(ecase sink
+ ((:string :usb8-array)
+ (ecase hose
+ (:string
+ `(if (= rpos (length result))
+ result
+ (subseq result 0 rpos)))
+ (:stream
+ `(copy-seq result))))
+ (:integer
+ 'result)
+ (:stream
+ 'stream)))))
+ (ecase hose
+ (:string
+ `(let ((length (length input)))
+ (declare (type array-length length))
+ (etypecase/unroll (input simple-base-string
+ simple-string
+ string)
+ ,body)))
+ (:stream
+ body)))))))
+
+(define-base64-decoder :string :usb8-array)
+(define-base64-decoder :string :string)
+(define-base64-decoder :string :integer)
+(define-base64-decoder :string :stream)
+
+(define-base64-decoder :stream :usb8-array)
+(define-base64-decoder :stream :string)
+(define-base64-decoder :stream :integer)
+(define-base64-decoder :stream :stream)
+
+;; input-mode can be :string or :stream
+;; input-format can be :character or :usb8