r4479: Auto commit for Debian build
[cl-base64.git] / encode.lisp
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
4 ;;;;
5 ;;;; Name:          encode.lisp
6 ;;;; Purpose:       cl-base64 encoding routines
7 ;;;; Programmer:    Kevin M. Rosenberg
8 ;;;; Date Started:  Dec 2002
9 ;;;;
10 ;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 kevin Exp $
11 ;;;;
12 ;;;; This file implements the Base64 transfer encoding algorithm as
13 ;;;; defined in RFC 1521 by Borensten & Freed, September 1993.
14 ;;;; See: http://www.ietf.org/rfc/rfc1521.txt
15 ;;;;
16 ;;;; Based on initial public domain code by Juri Pakaste <juri@iki.fi>
17 ;;;;
18 ;;;; Copyright 2002-2003 Kevin M. Rosenberg
19 ;;;; Permission to use with BSD-style license included in the COPYING file
20 ;;;; *************************************************************************
21
22 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
23
24 ;;;; Extended by Kevin M. Rosenberg <kevin@rosenberg.net>:
25 ;;;;   - .asd file
26 ;;;;   - numerous speed optimizations
27 ;;;;   - conversion to and from integers
28 ;;;;   - Renamed functions now that supporting integer conversions
29 ;;;;   - URI-compatible encoding using :uri key
30 ;;;;
31 ;;;; $Id: encode.lisp,v 1.5 2003/01/14 11:59:44 kevin Exp $
32
33 (in-package #:cl-base64)
34
35
36 (defun round-next-multiple (x n)
37   "Round x up to the next highest multiple of n."
38   (declare (fixnum n)
39            (optimize (speed 3)))
40   (let ((remainder (mod x n)))
41     (declare (fixnum remainder))
42     (if (zerop remainder)
43         x
44         (the fixnum (+ x (the fixnum (- n remainder)))))))
45
46 (defmacro def-*-to-base64-* (input-type output-type)
47   `(defun ,(intern (concatenate 'string (symbol-name input-type)
48                                 (symbol-name :-to-base64-)
49                                 (symbol-name output-type)))
50        (input
51         ,@(when (eq output-type :stream)
52                 '(output))
53         &key (uri nil) (columns 0))
54      "Encode a string array to base64. If columns is > 0, designates
55 maximum number of columns in a line and the string will be terminated
56 with a #\Newline."
57      (declare ,@(case input-type
58                       (:string
59                        '((string input)))
60                       (:usb8-array
61                        '((type (array (unsigned-byte 8) (*)) input))))
62               (fixnum columns)
63               (optimize (speed 3)))
64      (let ((pad (if uri *uri-pad-char* *pad-char*))
65            (encode-table (if uri *uri-encode-table* *encode-table*)))
66        (declare (simple-string encode-table)
67                 (character pad))
68        (let* ((string-length (length input))
69               (complete-group-count (truncate string-length 3))
70               (remainder (nth-value 1 (truncate string-length 3)))
71               (padded-length (* 4 (truncate (+ string-length 2) 3)))
72               ,@(when (eq output-type :string)
73                       '((num-lines (if (plusp columns)
74                                        (truncate (+ padded-length (1- columns)) columns)
75                                        0))
76                         (num-breaks (if (plusp num-lines)
77                                         (1- num-lines)
78                                         0))
79                         (strlen (+ padded-length num-breaks))
80                         (result (make-string strlen))
81                         (ioutput 0)))
82               (col (if (plusp columns)
83                        0
84                        (the fixnum (1+ padded-length)))))
85          (declare (fixnum string-length padded-length col
86                           ,@(when (eq output-type :string)
87                                   '(ioutput)))
88                   ,@(when (eq output-type :string)
89                           '((simple-string result))))
90          (labels ((output-char (ch)
91                     (if (= col columns)
92                         (progn
93                           ,@(case output-type
94                                   (:stream
95                                    '((write-char #\Newline output)))
96                                  (:string
97                                   '((setf (schar result ioutput) #\Newline)
98                                     (incf ioutput))))
99                           (setq col 1))
100                      (incf col))
101                  ,@(case output-type
102                          (:stream
103                           '((write-char ch output)))
104                          (:string
105                           '((setf (schar result ioutput) ch)
106                             (incf ioutput)))))
107                (output-group (svalue chars)
108                  (declare (fixnum svalue chars))
109                  (output-char
110                   (schar encode-table
111                          (the fixnum
112                            (logand #x3f
113                                    (the fixnum (ash svalue -18))))))
114                  (output-char
115                   (schar encode-table
116                          (the fixnum
117                            (logand #x3f
118                                         (the fixnum (ash svalue -12))))))
119                  (if (> chars 2)
120                      (output-char
121                       (schar encode-table
122                              (the fixnum
123                                (logand #x3f
124                                        (the fixnum (ash svalue -6))))))
125                      (output-char pad))
126                    (if (> chars 3)
127                        (output-char
128                         (schar encode-table
129                                (the fixnum
130                                  (logand #x3f svalue))))
131                        (output-char pad))))
132         (do ((igroup 0 (the fixnum (1+ igroup)))
133              (isource 0 (the fixnum (+ isource 3))))
134             ((= igroup complete-group-count)
135              (cond
136                ((= remainder 2)
137                 (output-group
138                  (the fixnum
139                      (+
140                       (the fixnum
141                         (ash
142                          ,(case input-type
143                                 (:string
144                                  '(char-code (the character (char input isource))))
145                                 (:usb8-array
146                                  '(the fixnum (aref input isource))))
147                          16))
148                       (the fixnum
149                         (ash
150                          ,(case input-type
151                                 (:string
152                                  '(char-code (the character (char input
153                                                                   (the fixnum (1+ isource))))))
154                                 (:usb8-array
155                                  '(the fixnum (aref input (the fixnum
156                                                             (1+ isource))))))
157                          8))))
158                  3))
159                ((= remainder 1)
160                 (output-group
161                  (the fixnum
162                    (ash
163                     ,(case input-type
164                            (:string
165                             '(char-code (the character (char input isource))))
166                            (:usb8-array
167                             '(the fixnum (aref input isource))))
168                     16))
169                  2)))
170              ,(case output-type
171                     (:string
172                      'result)
173                     (:stream
174                      'output)))
175           (declare (fixnum igroup isource))
176           (output-group 
177            (the fixnum
178              (+
179               (the fixnum
180                 (ash
181                  (the fixnum
182                  ,(case input-type
183                         (:string
184                          '(char-code (the character (char input isource))))
185                         (:usb8-array
186                          '(aref input isource))))
187                  16))
188               (the fixnum
189                 (ash
190                  (the fixnum
191                    ,(case input-type
192                           (:string
193                            '(char-code (the character (char input
194                                                             (the fixnum (1+ isource))))))
195                         (:usb8-array
196                          '(aref input (1+ isource)))))
197                  8))
198               (the fixnum
199                 ,(case input-type
200                        (:string
201                         '(char-code (the character (char input
202                                                          (the fixnum (+ 2 isource))))))
203                        (:usb8-array
204                         '(aref input (+ 2 isource))))
205                 )))
206            4)))))))
207
208 (def-*-to-base64-* :string :string)
209 (def-*-to-base64-* :string :stream)
210 (def-*-to-base64-* :usb8-array :string)
211 (def-*-to-base64-* :usb8-array :stream)
212
213
214 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
215   "Encode an integer to base64 format."
216   (declare (integer input)
217            (fixnum columns)
218            (optimize (speed 3)))
219   (let ((pad (if uri *uri-pad-char* *pad-char*))
220         (encode-table (if uri *uri-encode-table* *encode-table*)))
221     (declare (simple-string encode-table)
222              (character pad))
223     (let* ((input-bits (integer-length input))
224            (byte-bits (round-next-multiple input-bits 8))
225            (padded-bits (round-next-multiple byte-bits 6))
226            (remainder-padding (mod padded-bits 24))
227            (padding-bits (if (zerop remainder-padding)
228                              0
229                              (- 24 remainder-padding)))
230            (padding-chars (/ padding-bits 6))
231            (padded-length (/ (+ padded-bits padding-bits) 6))
232            (last-line-len (if (plusp columns)
233                               (- padded-length (* columns
234                                                   (truncate
235                                                    padded-length columns)))
236                               0))
237            (num-lines (if (plusp columns)
238                           (truncate (+ padded-length (1- columns)) columns)
239                           0))
240            (num-breaks (if (plusp num-lines)
241                            (1- num-lines)
242                            0))
243            (strlen (+ padded-length num-breaks))
244            (last-char (1- strlen))
245            (str (make-string strlen))
246            (col (if (zerop last-line-len)
247                      columns
248                     last-line-len)))
249       (declare (fixnum padded-length num-lines col last-char
250                        padding-chars last-line-len))
251       (unless (plusp columns)
252         (setq col -1)) ;; set to flag to optimize in loop
253       
254       (dotimes (i padding-chars)
255         (declare (fixnum i))
256         (setf (schar str (the fixnum (- last-char i))) pad))
257
258       (do* ((strpos (- last-char padding-chars) (1- strpos))
259             (int (ash input (/ padding-bits 3))))
260            ((minusp strpos)
261             str)
262         (declare (fixnum strpos) (integer int))
263         (cond
264           ((zerop col)
265            (setf (schar str strpos) #\Newline)
266            (setq col columns))
267           (t
268            (setf (schar str strpos)
269                  (schar encode-table (the fixnum (logand int #x3f))))
270            (setq int (ash int -6))
271            (decf col)))))))
272
273 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
274   "Encode an integer to base64 format."
275   (declare (integer input)
276            (fixnum columns)
277            (optimize (speed 3)))
278   (let ((pad (if uri *uri-pad-char* *pad-char*))
279         (encode-table (if uri *uri-encode-table* *encode-table*)))
280     (declare (simple-string encode-table)
281              (character pad))
282     (let* ((input-bits (integer-length input))
283            (byte-bits (round-next-multiple input-bits 8))
284            (padded-bits (round-next-multiple byte-bits 6))
285            (remainder-padding (mod padded-bits 24))
286            (padding-bits (if (zerop remainder-padding)
287                              0
288                              (- 24 remainder-padding)))
289            (padding-chars (/ padding-bits 6))
290            (padded-length (/ (+ padded-bits padding-bits) 6))
291            (strlen padded-length)
292            (nonpad-chars (- strlen padding-chars))
293            (last-nonpad-char (1- nonpad-chars))
294            (str (make-string strlen)))
295       (declare (fixnum padded-length last-nonpad-char))
296       (do* ((strpos 0 (the fixnum (1+ strpos)))
297             (int (ash input (/ padding-bits 3)) (ash int -6))
298             (6bit-value (the fixnum (logand int #x3f))
299                         (the fixnum (logand int #x3f))))
300            ((= strpos nonpad-chars)
301             (let ((col 0))
302               (declare (fixnum col))
303               (dotimes (i nonpad-chars)
304                 (declare (fixnum i))
305                 (write-char (schar str i) stream)
306                 (when (plusp columns)
307                   (incf col)
308                   (when (= col columns)
309                     (write-char #\Newline stream)
310                     (setq col 0))))
311               (dotimes (ipad padding-chars)
312                 (declare (fixnum ipad))
313                 (write-char pad stream)
314                 (when (plusp columns)
315                   (incf col)
316                   (when (= col columns)
317                     (write-char #\Newline stream)
318                     (setq col 0)))))
319             stream)
320         (declare (fixnum 6bit-value strpos)
321                  (integer int))
322         (setf (schar str (- last-nonpad-char strpos))
323               (schar encode-table 6bit-value))
324         ))))
325