X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=blobdiff_plain;f=encode.lisp;h=f3791aad7867651a608f65fb96a2280f7bdc1dce;hp=803c9ce532293c9aa7816c2609c35c843cfbe805;hb=0e74ef4c46d71c9e8ece1f0c9c185d4abbb06f44;hpb=98dfcc6acae8710d4577652fcb2b7c12ee86da22 diff --git a/encode.lisp b/encode.lisp index 803c9ce..f3791aa 100644 --- a/encode.lisp +++ b/encode.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Dec 2002 ;;;; -;;;; $Id: encode.lisp,v 1.3 2003/01/13 21:38:01 kevin Exp $ +;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 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.3 2003/01/13 21:38:01 kevin Exp $ +;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 kevin Exp $ (in-package #:cl-base64) @@ -43,118 +43,6 @@ x (the fixnum (+ x (the fixnum (- n remainder))))))) -(defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil)) - "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 (string string) - (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 string)) - (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)) - (labels ((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)) - (if stream - (write-char ch stream) - (progn - (setf (schar result ioutput) ch) - (incf ioutput)))) - (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 (the fixnum - (char-code (the character - (char string isource)))) - 16)) - (the fixnum - (ash (the fixnum - (char-code (the character - (char string (1+ isource))))) - 8)))) - 3)) - ((= remainder 1) - (output-group - (the fixnum - (ash - (the fixnum - (char-code (the character (char string isource)))) - 16)) - 2))) - result) - (declare (fixnum igroup isource)) - (output-group - (the fixnum - (+ - (the fixnum - (ash (char-code (the character - (char string isource))) 16)) - (the fixnum - (ash (char-code (the character (char string (1+ isource)))) 8)) - (the fixnum - (char-code (the character (char string (+ 2 isource))))))) - 4)))))) - (defmacro def-*-to-base64-* (input-type output-type) `(defun ,(intern (concatenate 'string (symbol-name input-type) (symbol-name :-to-base64-) @@ -170,7 +58,7 @@ with a #\Newline." (:string '((string input))) (:usb8-array - '((type (array fixnum (*)) input)))) + '((type (array (unsigned-byte 8) (*)) input)))) (fixnum columns) (optimize (speed 3))) (let ((pad (if uri *uri-pad-char* *pad-char*)) @@ -193,7 +81,7 @@ with a #\Newline." (ioutput 0))) (col (if (plusp columns) 0 - (1+ padded-length)))) + (the fixnum (1+ padded-length))))) (declare (fixnum string-length padded-length col ,@(when (eq output-type :string) '(ioutput))) @@ -241,8 +129,8 @@ with a #\Newline." (the fixnum (logand #x3f svalue)))) (output-char pad)))) - (do ((igroup 0 (1+ igroup)) - (isource 0 (+ isource 3))) + (do ((igroup 0 (the fixnum (1+ igroup))) + (isource 0 (the fixnum (+ isource 3)))) ((= igroup complete-group-count) (cond ((= remainder 2) @@ -261,9 +149,11 @@ with a #\Newline." (ash ,(case input-type (:string - '(char-code (the character (char input (1+ isource))))) + '(char-code (the character (char input + (the fixnum (1+ isource)))))) (:usb8-array - '(the fixnum (aref input (1+ isource))))) + '(the fixnum (aref input (the fixnum + (1+ isource)))))) 8)))) 3)) ((= remainder 1) @@ -300,14 +190,16 @@ with a #\Newline." (the fixnum ,(case input-type (:string - '(char-code (the character (char input (1+ isource))))) + '(char-code (the character (char input + (the fixnum (1+ isource)))))) (:usb8-array '(aref input (1+ isource))))) 8)) (the fixnum ,(case input-type (:string - '(char-code (the character (char input (+ 2 isource))))) + '(char-code (the character (char input + (the fixnum (+ 2 isource)))))) (:usb8-array '(aref input (+ 2 isource)))) ))) @@ -401,9 +293,10 @@ with a #\Newline." (last-nonpad-char (1- nonpad-chars)) (str (make-string strlen))) (declare (fixnum padded-length last-nonpad-char)) - (do* ((strpos 0 (1+ strpos)) + (do* ((strpos 0 (the fixnum (1+ strpos))) (int (ash input (/ padding-bits 3)) (ash int -6)) - (6bit-value (logand int #x3f) (logand int #x3f))) + (6bit-value (the fixnum (logand int #x3f)) + (the fixnum (logand int #x3f)))) ((= strpos nonpad-chars) (let ((col 0)) (declare (fixnum col))