X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=blobdiff_plain;f=decode.lisp;h=515b4d030efae270eb10bcb969ebd3b25d18da52;hp=ea0cdf255361277e3d6f93a92642ec24cf968212;hb=5bde84a6cc294259c71d9271873563a25ab06c7f;hpb=9d5e8be84951cef7f6a11bb60af0c64d8bd1e254

diff --git a/decode.lisp b/decode.lisp
index ea0cdf2..515b4d0 100644
--- a/decode.lisp
+++ b/decode.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: decode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id$
 ;;;;
 ;;;; This file implements the Base64 transfer encoding algorithm as
 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
@@ -19,7 +19,7 @@
 ;;;; Permission to use with BSD-style license included in the COPYING file
 ;;;; *************************************************************************
 
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package #:cl-base64)
 
 (declaim (inline whitespace-p))
 (defun whitespace-p (c)
@@ -31,194 +31,226 @@
 
 ;;; Decoding
 
-(defun base64-to-string (string &key (uri nil))
-  "Decode a base64 string to a string array."
-  (declare (string string)
-	   (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))
-    (let ((result (make-string (* 3 (truncate (length string) 4))))
-	  (ridx 0))
-      (declare (simple-string result)
-	       (fixnum ridx))
-      (loop
-	 for char of-type character across string
-	 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)
-		(setf (char result ridx)
-		      (code-char (the fixnum
-				   (logand
-				    (the fixnum
-				      (ash bitstore
-					   (the fixnum (- bitcount))))
-				    #xFF))))
-		(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))
-))
-      (subseq result 0 ridx))))
+#+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)
-|#
+;;(def-base64-stream-to-* :string)
+;;(def-base64-stream-to-* :stream)
+;;(def-base64-stream-to-* :usb8-array)
 
 (defmacro def-base64-string-to-* (output-type)
-  `(defun ,(case output-type
-	    (:string
-	     'base64-string-to-string)
-	    (:stream
-	     'base64-string-to-stream)
-	    (:usb8-array
-	     'base64-string-to-usb8-array))
-       (input &key (uri nil)
-	,@(when (eq output-type :stream)
-		'(stream)))
-     "Decode base64 string"
-     (declare (input string)
-	      (optimize (speed 3)))
+  `(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*)))
+           (decode-table (if uri *uri-decode-table* *decode-table*)))
        (declare (type decode-table decode-table)
-		(character pad))
+                (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 (array fixnum (*)) result)))))
-		  (fixnum ridx))
-	 (loop 
-	    for char of-type character across string
-	    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 ((svalue (the fixnum
-				   (logand
-				    (the fixnum
-				      (ash bitstore
-					   (the fixnum (- bitcount))))
-				    #xFF))))
-		     (declare (fixnum svalue))
-		     ,@(case output-type
-			     (:string
-			      (setf (char result ridx) (code-char svalue)))
-			     (:usb8-array
-			      (setf (aref result ridx) svalue))
-			     (:stream
-			      (write-char (code-char svalue) 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))
-		 ))
-	      (subseq result 0 ridx))))))
+                     (: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)))
+           (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*)))
+        (decode-table (if uri *uri-decode-table* *decode-table*)))
     (declare (type decode-table decode-table)
-	     (character pad))
+             (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))))
+         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)))
+           (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*)))
+        (decode-table (if uri *uri-decode-table* *decode-table*)))
     (declare (type decode-table decode-table)
-	     (character pad))
+             (character pad))
     (do* ((value 0)
-	  (char (read-char stream nil #\null)
-		(read-char stream nil #\null)))
-	 ((eq char #\null)
-	  value)
-      (declare (value integer)
-	       (char character))
+          (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))))
-	value)))
+           (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)))))))