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