X-Git-Url: http://git.kpe.io/?p=cl-base64.git;a=blobdiff_plain;f=encode.lisp;fp=encode.lisp;h=e6ee8415eb93b4e0b97be40d3944d295d87a3f2c;hp=0000000000000000000000000000000000000000;hb=9d5e8be84951cef7f6a11bb60af0c64d8bd1e254;hpb=1b3ea245129cdd7b33b2fc28da5fda8300c31a97

diff --git a/encode.lisp b/encode.lisp
new file mode 100644
index 0000000..e6ee841
--- /dev/null
+++ b/encode.lisp
@@ -0,0 +1,266 @@
+;;;; -*- 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: encode.lisp,v 1.1 2003/01/12 20:25:26 kevin Exp $
+;;;;
+;;;; 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
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
+;;;;   - .asd file
+;;;;   - numerous speed optimizations
+;;;;   - conversion to and from integers
+;;;;   - 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 $
+
+(in-package #:cl-base64)
+
+
+(defun round-next-multiple (x n)
+  "Round x up to the next highest multiple of n."
+  (declare (fixnum n)
+	   (optimize (speed 3)))
+  (let ((remainder (mod x n)))
+    (declare (fixnum remainder))
+    (if (zerop remainder)
+	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))))))
+  
+(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)))
+
+(defun integer-to-base64-string (input &key (uri nil) (columns 0))
+  "Encode an integer to base64 format."
+  (declare (integer 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* ((input-bits (integer-length input))
+	   (byte-bits (round-next-multiple input-bits 8))
+	   (padded-bits (round-next-multiple byte-bits 6))
+	   (remainder-padding (mod padded-bits 24))
+	   (padding-bits (if (zerop remainder-padding)
+			     0
+			     (- 24 remainder-padding)))
+	   (padding-chars (/ padding-bits 6))
+	   (padded-length (/ (+ padded-bits padding-bits) 6))
+	   (last-line-len (if (plusp columns)
+			      (- padded-length (* columns
+						  (truncate
+						   padded-length columns)))
+			      0))
+	   (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))
+	   (last-char (1- strlen))
+	   (str (make-string strlen))
+	   (col (if (zerop last-line-len)
+		     columns
+		    last-line-len)))
+      (declare (fixnum padded-length num-lines col last-char
+		       padding-chars last-line-len))
+      (unless (plusp columns)
+	(setq col -1)) ;; set to flag to optimize in loop
+      
+      (dotimes (i padding-chars)
+	(declare (fixnum i))
+	(setf (schar str (the fixnum (- last-char i))) pad))
+
+      (do* ((strpos (- last-char padding-chars) (1- strpos))
+	    (int (ash input (/ padding-bits 3))))
+	   ((minusp strpos)
+	    str)
+	(declare (fixnum strpos) (integer int))
+	(cond
+	  ((zerop col)
+	   (setf (schar str strpos) #\Newline)
+	   (setq col columns))
+	  (t
+	   (setf (schar str strpos)
+		 (schar encode-table (the fixnum (logand int #x3f))))
+	   (setq int (ash int -6))
+	   (decf col)))))))
+
+(defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
+  "Encode an integer to base64 format."
+  (declare (integer 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* ((input-bits (integer-length input))
+	   (byte-bits (round-next-multiple input-bits 8))
+	   (padded-bits (round-next-multiple byte-bits 6))
+	   (remainder-padding (mod padded-bits 24))
+	   (padding-bits (if (zerop remainder-padding)
+			     0
+			     (- 24 remainder-padding)))
+	   (padding-chars (/ padding-bits 6))
+	   (padded-length (/ (+ padded-bits padding-bits) 6))
+	   (strlen padded-length)
+	   (nonpad-chars (- strlen padding-chars))
+	   (last-nonpad-char (1- nonpad-chars))
+	   (str (make-string strlen)))
+      (declare (fixnum padded-length last-nonpad-char))
+      (do* ((strpos 0 (1+ strpos))
+	    (int (ash input (/ padding-bits 3)) (ash int -6))
+	    (6bit-value (logand int #x3f) (logand int #x3f)))
+	   ((= strpos nonpad-chars)
+	    (let ((col 0))
+	      (declare (fixnum col))
+	      (dotimes (i nonpad-chars)
+		(declare (fixnum i))
+		(write-char (schar str i) stream)
+		(when (plusp columns)
+		  (incf col)
+		  (when (= col columns)
+		    (write-char #\Newline stream)
+		    (setq col 0))))
+	      (dotimes (ipad padding-chars)
+		(declare (fixnum ipad))
+		(write-char pad stream)
+		(when (plusp columns)
+		  (incf col)
+		  (when (= col columns)
+		    (write-char #\Newline stream)
+		    (setq col 0)))))
+	    stream)
+	(declare (fixnum 6bit-value strpos)
+		 (integer int))
+	(setf (schar str (- last-nonpad-char strpos))
+	      (schar encode-table 6bit-value))
+	))))
+