r3747: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 12 Jan 2003 22:32:40 +0000 (22:32 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Sun, 12 Jan 2003 22:32:40 +0000 (22:32 +0000)
debian/changelog
decode.lisp
encode.lisp
package.lisp

index 857f024..81e12a0 100644 (file)
@@ -1,7 +1,10 @@
-cl-base64 (2.2.0-1) unstable; urgency=low
+cl-base64 (3.0.0-1) unstable; urgency=low
 
   * Fix error in integer-to-base64 when using columns
   * Add base64-test.asd and test.lisp regression suite
+  * Rewrite routines as macros to create efficient functions to
+    converting from strings or streams and converting to streams, strings,
+    and usb8-arrays.
 
  -- Kevin M. Rosenberg <kmr@debian.org>  Sat,  4 Jan 2003 06:40:32 -0700
 
index ea0cdf2..775bb8e 100644 (file)
@@ -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: decode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 ;;;;
 ;;;; This file implements the Base64 transfer encoding algorithm as
 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
@@ -21,6 +21,8 @@
 
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 
+(in-package #:cl-base64)
+
 (declaim (inline whitespace-p))
 (defun whitespace-p (c)
   "Returns T for a whitespace character."
 
 ;;; 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))))
-
-#|
-(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))
+#+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)))
-     "Decode base64 string"
-     (declare (input string)
+     ,(concatenate 'string "Decode base64 stream to " (string-downcase
+                                                      (symbol-name output-type)))
+     (declare (stream input)
              (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))
+               (type character pad))
        (let (,@(case output-type
                     (:string
                      '((result (make-string (* 3 (truncate (length string) 4))))))
               (ridx 0))
         (declare ,@(case output-type
                          (:string
-                          '((simple-string result))
+                          '((simple-string result)))
+                         (:usb8-array
+                          '((type (array fixnum (*)) 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)
+                     ((or :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
-                           '((type (array fixnum (*)) result)))))
+                           '(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)))
+     (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 (array fixnum (*)) result))))
                  (fixnum ridx))
         (loop 
-           for char of-type character across string
+           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
                 (incf bitcount 6)
                 (when (>= bitcount 8)
                   (decf bitcount 8)
-                  (let ((svalue (the fixnum
+                  (let ((ovalue (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)))
+                    (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)))))
+                    (setf bitstore (the fixnum (logand bitstore #xFF))))))
                 ((char= char pad)
                  ;; Could add checks to make sure padding is correct
                  ;; Currently, padding is ignored
                 ((minusp svalue)
                  (warn "Bad character ~W in base64 decode" char))
                 ))
-             (subseq result 0 ridx))))))
+        ,(case output-type
+               (:stream
+                'stream)
+               ((:stream :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
 
              (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)
                (read-char stream nil #\null)))
         ((eq char #\null)
          value)
-      (declare (value integer)
-              (char character))
+      (declare (integer value)
+              (character char))
       (let ((svalue (aref decode-table (the fixnum (char-code char)))))
           (declare (fixnum svalue))
           (cond
             ((whitespace-p char)               ; ignore whitespace
              )
             ((minusp svalue)
-             (warn "Bad character ~W in base64 decode" char))))
-       value)))
+             (warn "Bad character ~W in base64 decode" char)))))))
index e6ee841..d079515 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 ;;;;
 ;;;; This file implements the Base64 transfer encoding algorithm as
 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
@@ -28,7 +28,7 @@
 ;;;;   - Renamed functions now that supporting integer conversions
 ;;;;   - URI-compatible encoding using :uri key
 ;;;;
-;;;; $Id: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: encode.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 
 (in-package #:cl-base64)
 
@@ -147,11 +147,159 @@ with a #\Newline."
              (the fixnum
                (char-code (the character (char string (+ 2 isource)))))))
           4))))))
-  
-(defun integer-to-base64 (input &key (uri nil) (columns 0) (stream nil))
-  (if stream
-      (integer-to-base64-stream input stream :uri uri :columns columns)
-      (integer-to-base64-string input :uri uri :columns columns)))
+
+(defmacro def-*-to-base64-* (input-type output-type)
+  `(defun ,(intern (concatenate 'string (symbol-name input-type)
+                               (symbol-name :-to-base-64-)
+                               (symbol-name output-type)))
+       (input
+       ,@(when (eq output-type :stream)
+               'output)
+       &key (uri nil) (columns 0))
+     "Encode a string array to base64. If columns is > 0, designates
+maximum number of columns in a line and the string will be terminated
+with a #\Newline."
+     (declare (,@(case input-type
+                      (:string
+                       '((string input)))
+                      (:usb8-array)
+                      '((type (array fixnum (*))) input))
+                (fixnum columns)
+                (optimize (speed 3))))
+     (let ((pad (if uri *uri-pad-char* *pad-char*))
+          (encode-table (if uri *uri-encode-table* *encode-table*)))
+       (declare (simple-string encode-table)
+               (character pad))
+       (let* ((string-length (length input))
+             (complete-group-count (truncate string-length 3))
+             (remainder (nth-value 1 (truncate string-length 3)))
+             (padded-length (* 4 (truncate (+ string-length 2) 3)))
+             (num-lines (if (plusp columns)
+                            (truncate (+ padded-length (1- columns)) columns)
+                            0))
+             (num-breaks (if (plusp num-lines)
+                             (1- num-lines)
+                             0))
+          (strlen (if stream
+                      0
+                      (+ padded-length num-breaks)))
+          (result (make-string strlen))
+          (col (if (plusp columns)
+                   0
+                   (1+ padded-length)))
+          (ioutput 0))
+      (declare (fixnum string-length padded-length col ioutput)
+              (simple-string result))
+      (macrolet ((output-char (ch)
+                  (if (= col columns)
+                      (progn
+                        (if stream
+                            (write-char #\Newline stream)
+                            (progn
+                              (setf (schar result ioutput) #\Newline)
+                              (incf ioutput)))
+                        (setq col 1))
+                      (incf col))
+                  ,@(case output-type
+                          (:stream
+                           '((write-char ch stream))
+                           (:string
+                            '((setf (schar result ioutput) ch)
+                              (incf ioutput)))))))
+       (labels ((output-group (svalue chars)
+                  (declare (fixnum svalue chars))
+                  (output-char
+                   (schar encode-table
+                          (the fixnum
+                            (logand #x3f
+                                    (the fixnum (ash svalue -18))))))
+                  (output-char
+                   (schar encode-table
+                          (the fixnum
+                            (logand #x3f
+                                    (the fixnum (ash svalue -12))))))
+                  (if (> chars 2)
+                      (output-char
+                       (schar encode-table
+                          (the fixnum
+                            (logand #x3f
+                                    (the fixnum (ash svalue -6))))))
+                      (output-char pad))
+                  (if (> chars 3)
+                      (output-char
+                       (schar encode-table
+                              (the fixnum
+                                (logand #x3f svalue))))
+                (output-char pad))))
+         (do ((igroup 0 (1+ igroup))
+              (isource 0 (+ isource 3)))
+             ((= igroup complete-group-count)
+              (cond
+                ((= remainder 2)
+                 (output-group
+                  (the fixnum
+                    (+
+                   (the fixnum
+                     (ash
+                      ,(case input-type
+                             (:string
+                              '(char-code (the character (char input isource))))
+                             (:usb8-array
+                              '(the fixnum (aref input isource))))
+                      16))
+                   (the fixnum
+                     (ash
+                      ,(case input-type
+                             (:string
+                              '(char-code (the character (char input (1+ isource)))))
+                             (:usb8-array
+                              '(the fixnum (aref input (1+ isource)))))
+                      8))))
+                  3))
+                ((= remainder 1)
+                 (output-group
+                  (the fixnum
+                    ,(case input-type
+                           (:string
+                            '(char-code (the character (char input isource))))
+                           (:usb8-array
+                            '(the fixnum (aref input isource)))))
+                  2)))
+              result)
+           (declare (fixnum igroup isource))
+           (output-group 
+            (the fixnum
+              (+
+               (the fixnum
+                 (ash
+                  ,(case input-type
+                         (:string
+                          '(char-code (the character (char input isource))))
+                         (:usb8-array
+                          '(the fixnum (aref input isource))))
+                  16))
+               (the fixnum
+                 (ash
+                  ,(case input-type
+                         (:string
+                          '(char-code (the character (char input (1+ isource)))))
+                         (:usb8-array
+                          '(the fixnum (aref input (1+ isource)))))
+                  8))
+               (the fixnum
+                 ,(case input-type
+                        (:string
+                         '(char-code (the character (char input (+ 2 isource)))))
+                        (:usb8-array
+                         '(the fixnum (aref input (+ 2 isource)))))
+                 )))
+            4))))))))
+
+(def-*-to-base64-* :string :string)
+(def-*-to-base64-* :string :stream)
+(def-*-to-base64-* :usb8-array :string)
+(def-*-to-base64-* :usb8-array :stream)
+
 
 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
   "Encode an integer to base64 format."
index 7c119de..014cd1f 100644 (file)
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Dec 2002
 ;;;;
-;;;; $Id: package.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;; $Id: package.lisp,v 1.2 2003/01/12 22:32:40 kevin Exp $
 ;;;;
 ;;;; *************************************************************************
 
 (in-package #:cl-base64)
 
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *encode-table*
-    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
-  (declaim (type simple-string *encode-table*))
-  
-  (defvar *uri-encode-table*
-    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
-  (declaim (type simple-string *uri-encode-table*))
-  
-  (deftype decode-table () '(array fixnum (256)))
+(defvar *encode-table*
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+(declaim (type simple-string *encode-table*))
+
+(defvar *uri-encode-table*
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
+(declaim (type simple-string *uri-encode-table*))
 
-  (defun make-decode-table (encode-table)
-    (let ((dt (make-array 256 :adjustable nil :fill-pointer nil
-                         :element-type 'fixnum
-                         :initial-element -1)))
-      (loop for char of-type character across encode-table
-        for index of-type fixnum from 0 below 64
-        do (setf (aref dt (the fixnum (char-code char))) index))
-      dt))
+(deftype decode-table () '(array fixnum (256)))
+
+(defun make-decode-table (encode-table)
+  (let ((dt (make-array 256 :adjustable nil :fill-pointer nil
+                       :element-type 'fixnum
+                       :initial-element -1)))
+    (declare (type decode-table dt))
+    (loop for char of-type character across encode-table
+       for index of-type fixnum from 0 below 64
+       do (setf (aref dt (the fixnum (char-code char))) index))
+    dt))
     
-  (defvar *decode-table* (make-decode-table *encode-table*))
-  
-  (defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
+(defvar *decode-table* (make-decode-table *encode-table*))
   
-  (declaim (type decode-table *decode-table* *uri-decode-table*))
+(defvar *uri-decode-table* (make-decode-table *uri-encode-table*))
   
-  (defvar *pad-char* #\=)
-  (defvar *uri-pad-char* #\.)
-  (declaim (type character *pad-char* *uri-pad-char*))
-  )
+(defvar *pad-char* #\=)
+(defvar *uri-pad-char* #\.)
+(declaim (type character *pad-char* *uri-pad-char*))