X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=blobdiff_plain;f=encode.lisp;h=f3791aad7867651a608f65fb96a2280f7bdc1dce;hp=d079515487c3d222334aa5f833c1bb0c69db9e9e;hb=3771e78939bb92664c2e3064256eb9dd1650be3b;hpb=8d11e40eb06556b995b963ee7c72e59a5368d21e diff --git a/encode.lisp b/encode.lisp index d079515..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.2 2003/01/12 22:32:40 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.2 2003/01/12 22:32:40 kevin Exp $ +;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 kevin Exp $ (in-package #:cl-base64) @@ -43,129 +43,24 @@ 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 (char-code (the character - (char string isource))) 16)) - (the fixnum - (ash (char-code (the character - (char string (1+ isource)))) 8)))) - 3)) - ((= remainder 1) - (output-group - (the fixnum - (ash (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-base-64-) + (symbol-name :-to-base64-) (symbol-name output-type))) (input ,@(when (eq output-type :stream) - 'output) + '(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)))) + (declare ,@(case input-type + (:string + '((string input))) + (:usb8-array + '((type (array (unsigned-byte 8) (*)) 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) @@ -174,126 +69,141 @@ with a #\Newline." (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 + ,@(when (eq output-type :string) + '((num-lines (if (plusp columns) + (truncate (+ padded-length (1- columns)) columns) + 0)) + (num-breaks (if (plusp num-lines) + (1- num-lines) + 0)) + (strlen (+ padded-length num-breaks)) + (result (make-string strlen)) + (ioutput 0))) + (col (if (plusp columns) 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)) + (the fixnum (1+ padded-length))))) + (declare (fixnum string-length padded-length col + ,@(when (eq output-type :string) + '(ioutput))) + ,@(when (eq output-type :string) + '((simple-string result)))) + (labels ((output-char (ch) + (if (= col columns) + (progn + ,@(case output-type + (:stream + '((write-char #\Newline output))) + (:string + '((setf (schar result ioutput) #\Newline) + (incf ioutput)))) + (setq col 1)) + (incf col)) + ,@(case output-type + (:stream + '((write-char ch output))) + (:string + '((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 + (output-char pad)))) + (do ((igroup 0 (the fixnum (1+ igroup))) + (isource 0 (the fixnum (+ 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 + (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 + (the fixnum (1+ isource)))))) + (:usb8-array + '(the fixnum (aref input (the fixnum + (1+ isource)))))) + 8)))) + 3)) + ((= remainder 1) + (output-group + (the fixnum + (ash + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(the fixnum (aref input isource)))) + 16)) + 2))) + ,(case output-type + (:string + 'result) + (:stream + 'output))) + (declare (fixnum igroup isource)) + (output-group + (the fixnum + (+ + (the fixnum + (ash + (the fixnum + ,(case input-type + (:string + '(char-code (the character (char input isource)))) + (:usb8-array + '(aref input isource)))) + 16)) + (the fixnum + (ash + (the fixnum ,(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)))))))) + '(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 + (the fixnum (+ 2 isource)))))) + (:usb8-array + '(aref input (+ 2 isource)))) + ))) + 4))))))) (def-*-to-base64-* :string :string) (def-*-to-base64-* :string :stream) @@ -383,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))