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