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