| Current Path : /usr/share/common-lisp/source/cl-base64/ |
Linux ift1.ift-informatik.de 5.4.0-216-generic #236-Ubuntu SMP Fri Apr 11 19:53:21 UTC 2025 x86_64 |
| Current File : //usr/share/common-lisp/source/cl-base64/decode.lisp |
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: encode.lisp
;;;; Purpose: cl-base64 encoding routines
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Dec 2002
;;;;
;;;; $Id$
;;;;
;;;; This file implements the Base64 transfer encoding algorithm as
;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
;;;; See: http://www.ietf.org/rfc/rfc1521.txt
;;;;
;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
;;;;
;;;; Copyright 2002-2003 Kevin M. Rosenberg
;;;; Permission to use with BSD-style license included in the COPYING file
;;;; *************************************************************************
(in-package #:cl-base64)
(declaim (inline whitespace-p))
(defun whitespace-p (c)
"Returns T for a whitespace character."
(or (char= c #\Newline) (char= c #\Linefeed)
(char= c #\Return) (char= c #\Space)
(char= c #\Tab)))
;;; Decoding
#+ignore
(defmacro def-base64-stream-to-* (output-type)
`(defun ,(intern (concatenate 'string (symbol-name :base64-stream-to-)
(symbol-name output-type)))
(input &key (uri nil)
,@(when (eq output-type :stream)
'(stream)))
,(concatenate 'string "Decode base64 stream to " (string-downcase
(symbol-name output-type)))
(declare (stream input)
(optimize (speed 3) (space 0) (safety 0)))
(let ((pad (if uri *uri-pad-char* *pad-char*))
(decode-table (if uri *uri-decode-table* *decode-table*)))
(declare (type decode-table decode-table)
(type character pad))
(let (,@(case output-type
(:string
'((result (make-string (* 3 (truncate (length string) 4))))))
(:usb8-array
'((result (make-array (* 3 (truncate (length string) 4))
:element-type '(unsigned-byte 8)
:fill-pointer nil
:adjustable nil)))))
(ridx 0))
(declare ,@(case output-type
(:string
'((simple-string result)))
(:usb8-array
'((type (simple-array (unsigned-byte 8) (*)) result))))
(fixnum ridx))
(do* ((bitstore 0)
(bitcount 0)
(char (read-char stream nil #\null)
(read-char stream nil #\null)))
((eq char #\null)
,(case output-type
(:stream
'stream)
((:string :usb8-array)
'result)
;; ((:stream :string)
;; '(subseq result 0 ridx))))
))
(declare (fixnum bitstore bitcount)
(character char))
(let ((svalue (aref decode-table (the fixnum (char-code char)))))
(declare (fixnum svalue))
(cond
((>= svalue 0)
(setf bitstore (logior
(the fixnum (ash bitstore 6))
svalue))
(incf bitcount 6)
(when (>= bitcount 8)
(decf bitcount 8)
(let ((ovalue (the fixnum
(logand
(the fixnum
(ash bitstore
(the fixnum (- bitcount))))
#xFF))))
(declare (fixnum ovalue))
,(case output-type
(:string
'(setf (char result ridx) (code-char ovalue)))
(:usb8-array
'(setf (aref result ridx) ovalue))
(:stream
'(write-char (code-char ovalue) stream)))
(incf ridx)
(setf bitstore (the fixnum (logand bitstore #xFF))))))
((char= char pad)
;; Could add checks to make sure padding is correct
;; Currently, padding is ignored
)
((whitespace-p char)
;; Ignore whitespace
)
((minusp svalue)
(warn "Bad character ~W in base64 decode" char))
)))))))
;;(def-base64-stream-to-* :string)
;;(def-base64-stream-to-* :stream)
;;(def-base64-stream-to-* :usb8-array)
(defmacro def-base64-string-to-* (output-type)
`(defun ,(intern (concatenate 'string (symbol-name :base64-string-to-)
(symbol-name output-type)))
(input &key (uri nil)
,@(when (eq output-type :stream)
'(stream)))
,(concatenate 'string "Decode base64 string to " (string-downcase
(symbol-name output-type)))
(declare (string input)
(optimize (speed 3) (safety 0) (space 0)))
(let ((pad (if uri *uri-pad-char* *pad-char*))
(decode-table (if uri *uri-decode-table* *decode-table*)))
(declare (type decode-table decode-table)
(type character pad))
(let (,@(case output-type
(:string
'((result (make-string (* 3 (truncate (length input) 4))))))
(:usb8-array
'((result (make-array (* 3 (truncate (length input) 4))
:element-type '(unsigned-byte 8)
:fill-pointer nil
:adjustable nil)))))
(ridx 0))
(declare ,@(case output-type
(:string
'((simple-string result)))
(:usb8-array
'((type (simple-array (unsigned-byte 8) (*)) result))))
(fixnum ridx))
(loop
for char of-type character across input
for svalue of-type fixnum = (aref decode-table
(the fixnum (char-code char)))
with bitstore of-type fixnum = 0
with bitcount of-type fixnum = 0
do
(cond
((>= svalue 0)
(setf bitstore (logior
(the fixnum (ash bitstore 6))
svalue))
(incf bitcount 6)
(when (>= bitcount 8)
(decf bitcount 8)
(let ((ovalue (the fixnum
(logand
(the fixnum
(ash bitstore
(the fixnum (- bitcount))))
#xFF))))
(declare (fixnum ovalue))
,(case output-type
(:string
'(setf (char result ridx) (code-char ovalue)))
(:usb8-array
'(setf (aref result ridx) ovalue))
(:stream
'(write-char (code-char ovalue) stream)))
(incf ridx)
(setf bitstore (the fixnum (logand bitstore #xFF))))))
((char= char pad)
;; Could add checks to make sure padding is correct
;; Currently, padding is ignored
)
((whitespace-p char)
;; Ignore whitespace
)
((minusp svalue)
(warn "Bad character ~W in base64 decode" char))
))
,(case output-type
(:stream
'stream)
((:usb8-array :string)
'(subseq result 0 ridx)))))))
(def-base64-string-to-* :string)
(def-base64-string-to-* :stream)
(def-base64-string-to-* :usb8-array)
;; input-mode can be :string or :stream
;; input-format can be :character or :usb8
(defun base64-string-to-integer (string &key (uri nil))
"Decodes a base64 string to an integer"
(declare (string string)
(optimize (speed 3) (safety 0) (space 0)))
(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))
(let ((value 0))
(declare (integer value))
(loop
for char of-type character across string
for svalue of-type fixnum =
(aref decode-table (the fixnum (char-code char)))
do
(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))))
value)))
(defun base64-stream-to-integer (stream &key (uri nil))
"Decodes a base64 string to an integer"
(declare (stream stream)
(optimize (speed 3) (space 0) (safety 0)))
(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)))))))