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.2 2003/01/12 22:32:40 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.2 2003/01/12 22:32:40 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 (defun string-to-base64 (string &key (uri nil) (columns 0) (stream nil))
  47   "Encode a string array to base64. If columns is > 0, designates
  48 maximum number of columns in a line and the string will be terminated
  49 with a #\Newline."
  50   (declare (string string)
  51            (fixnum columns)
  52            (optimize (speed 3)))
  53   (let ((pad (if uri *uri-pad-char* *pad-char*))
  54         (encode-table (if uri *uri-encode-table* *encode-table*)))
  55     (declare (simple-string encode-table)
  56              (character pad))
  57     (let* ((string-length (length string))
  58            (complete-group-count (truncate string-length 3))
  59            (remainder (nth-value 1 (truncate string-length 3)))
  60            (padded-length (* 4 (truncate (+ string-length 2) 3)))
  61            (num-lines (if (plusp columns)
  62                           (truncate (+ padded-length (1- columns)) columns)
  63                           0))
  64            (num-breaks (if (plusp num-lines)
  65                            (1- num-lines)
  66                            0))
  67            (strlen (if stream
  68                        0
  69                        (+ padded-length num-breaks)))
  70            (result (make-string strlen))
  71            (col (if (plusp columns)
  72                     0
  73                     (1+ padded-length)))
  74            (ioutput 0))
  75       (declare (fixnum string-length padded-length col ioutput)
  76                (simple-string result))
  77       (labels ((output-char (ch)
  78                  (if (= col columns)
  79                      (progn
  80                        (if stream
  81                            (write-char #\Newline stream)
  82                            (progn
  83                              (setf (schar result ioutput) #\Newline)
  84                              (incf ioutput)))
  85                        (setq col 1))
  86                      (incf col))
  87                  (if stream
  88                      (write-char ch stream)
  89                      (progn
  90                        (setf (schar result ioutput) ch)
  91                        (incf ioutput))))
  92              (output-group (svalue chars)
  93                (declare (fixnum svalue chars))
  94                (output-char
  95                 (schar encode-table
  96                        (the fixnum
  97                          (logand #x3f
  98                                  (the fixnum (ash svalue -18))))))
  99                (output-char
 100                 (schar encode-table
 101                        (the fixnum
 102                          (logand #x3f
 103                                  (the fixnum (ash svalue -12))))))
 104                (if (> chars 2)
 105                    (output-char
 106                     (schar encode-table
 107                            (the fixnum
 108                              (logand #x3f
 109                                      (the fixnum (ash svalue -6))))))
 110                  (output-char pad))
 111                (if (> chars 3)
 112                    (output-char
 113                     (schar encode-table
 114                            (the fixnum
 115                              (logand #x3f svalue))))
 116                  (output-char pad))))
 117         (do ((igroup 0 (1+ igroup))
 118              (isource 0 (+ isource 3)))
 119             ((= igroup complete-group-count)
 120              (cond
 121                ((= remainder 2)
 122                 (output-group
 123                  (the fixnum
 124                    (+
 125                     (the fixnum
 126                       (ash (char-code (the character
 127                                         (char string isource))) 16))
 128                     (the fixnum
 129                       (ash (char-code (the character
 130                                         (char string (1+ isource)))) 8))))
 131                  3))
 132                ((= remainder 1)
 133                 (output-group
 134                  (the fixnum
 135                    (ash (char-code (the character (char string isource))) 16))
 136                  2)))
 137              result)
 138           (declare (fixnum igroup isource))
 139           (output-group
 140            (the fixnum
 141              (+
 142               (the fixnum
 143                 (ash (char-code (the character
 144                                   (char string isource))) 16))
 145               (the fixnum
 146                 (ash (char-code (the character (char string (1+ isource)))) 8))
 147               (the fixnum
 148                 (char-code (the character (char string (+ 2 isource)))))))
 149            4))))))
 150
 151 (defmacro def-*-to-base64-* (input-type output-type)
 152   `(defun ,(intern (concatenate 'string (symbol-name input-type)
 153                                 (symbol-name :-to-base-64-)
 154                                 (symbol-name output-type)))
 155        (input
 156         ,@(when (eq output-type :stream)
 157                 'output)
 158         &key (uri nil) (columns 0))
 159      "Encode a string array to base64. If columns is > 0, designates
 160 maximum number of columns in a line and the string will be terminated
 161 with a #\Newline."
 162      (declare (,@(case input-type
 163                        (:string
 164                         '((string input)))
 165                        (:usb8-array)
 166                        '((type (array fixnum (*))) input))
 167                  (fixnum columns)
 168                  (optimize (speed 3))))
 169      (let ((pad (if uri *uri-pad-char* *pad-char*))
 170            (encode-table (if uri *uri-encode-table* *encode-table*)))
 171        (declare (simple-string encode-table)
 172                 (character pad))
 173        (let* ((string-length (length input))
 174               (complete-group-count (truncate string-length 3))
 175               (remainder (nth-value 1 (truncate string-length 3)))
 176               (padded-length (* 4 (truncate (+ string-length 2) 3)))
 177               (num-lines (if (plusp columns)
 178                              (truncate (+ padded-length (1- columns)) columns)
 179                              0))
 180               (num-breaks (if (plusp num-lines)
 181                               (1- num-lines)
 182                               0))
 183            (strlen (if stream
 184                        0
 185                        (+ padded-length num-breaks)))
 186            (result (make-string strlen))
 187            (col (if (plusp columns)
 188                     0
 189                     (1+ padded-length)))
 190            (ioutput 0))
 191       (declare (fixnum string-length padded-length col ioutput)
 192                (simple-string result))
 193       (macrolet ((output-char (ch)
 194                    (if (= col columns)
 195                        (progn
 196                          (if stream
 197                              (write-char #\Newline stream)
 198                              (progn
 199                                (setf (schar result ioutput) #\Newline)
 200                                (incf ioutput)))
 201                          (setq col 1))
 202                        (incf col))
 203                    ,@(case output-type
 204                            (:stream
 205                             '((write-char ch stream))
 206                             (:string
 207                              '((setf (schar result ioutput) ch)
 208                                (incf ioutput)))))))
 209         (labels ((output-group (svalue chars)
 210                    (declare (fixnum svalue chars))
 211                    (output-char
 212                     (schar encode-table
 213                            (the fixnum
 214                              (logand #x3f
 215                                      (the fixnum (ash svalue -18))))))
 216                    (output-char
 217                     (schar encode-table
 218                            (the fixnum
 219                              (logand #x3f
 220                                      (the fixnum (ash svalue -12))))))
 221                    (if (> chars 2)
 222                        (output-char
 223                         (schar encode-table
 224                            (the fixnum
 225                              (logand #x3f
 226                                      (the fixnum (ash svalue -6))))))
 227                        (output-char pad))
 228                    (if (> chars 3)
 229                        (output-char
 230                         (schar encode-table
 231                                (the fixnum
 232                                  (logand #x3f svalue))))
 233                  (output-char pad))))
 234           (do ((igroup 0 (1+ igroup))
 235                (isource 0 (+ isource 3)))
 236               ((= igroup complete-group-count)
 237                (cond
 238                  ((= remainder 2)
 239                   (output-group
 240                    (the fixnum
 241                      (+
 242                     (the fixnum
 243                       (ash
 244                        ,(case input-type
 245                               (:string
 246                                '(char-code (the character (char input isource))))
 247                               (:usb8-array
 248                                '(the fixnum (aref input isource))))
 249                        16))
 250                     (the fixnum
 251                       (ash
 252                        ,(case input-type
 253                               (:string
 254                                '(char-code (the character (char input (1+ isource)))))
 255                               (:usb8-array
 256                                '(the fixnum (aref input (1+ isource)))))
 257                        8))))
 258                    3))
 259                  ((= remainder 1)
 260                   (output-group
 261                    (the fixnum
 262                      ,(case input-type
 263                             (:string
 264                              '(char-code (the character (char input isource))))
 265                             (:usb8-array
 266                              '(the fixnum (aref input isource)))))
 267                    2)))
 268                result)
 269             (declare (fixnum igroup isource))
 270             (output-group
 271              (the fixnum
 272                (+
 273                 (the fixnum
 274                   (ash
 275                    ,(case input-type
 276                           (:string
 277                            '(char-code (the character (char input isource))))
 278                           (:usb8-array
 279                            '(the fixnum (aref input isource))))
 280                    16))
 281                 (the fixnum
 282                   (ash
 283                    ,(case input-type
 284                           (:string
 285                            '(char-code (the character (char input (1+ isource)))))
 286                           (:usb8-array
 287                            '(the fixnum (aref input (1+ isource)))))
 288                    8))
 289                 (the fixnum
 290                   ,(case input-type
 291                          (:string
 292                           '(char-code (the character (char input (+ 2 isource)))))
 293                          (:usb8-array
 294                           '(the fixnum (aref input (+ 2 isource)))))
 295                   )))
 296              4))))))))
 297
 298 (def-*-to-base64-* :string :string)
 299 (def-*-to-base64-* :string :stream)
 300 (def-*-to-base64-* :usb8-array :string)
 301 (def-*-to-base64-* :usb8-array :stream)
 302
 303
 304 (defun integer-to-base64-string (input &key (uri nil) (columns 0))
 305   "Encode an integer to base64 format."
 306   (declare (integer input)
 307            (fixnum columns)
 308            (optimize (speed 3)))
 309   (let ((pad (if uri *uri-pad-char* *pad-char*))
 310         (encode-table (if uri *uri-encode-table* *encode-table*)))
 311     (declare (simple-string encode-table)
 312              (character pad))
 313     (let* ((input-bits (integer-length input))
 314            (byte-bits (round-next-multiple input-bits 8))
 315            (padded-bits (round-next-multiple byte-bits 6))
 316            (remainder-padding (mod padded-bits 24))
 317            (padding-bits (if (zerop remainder-padding)
 318                              0
 319                              (- 24 remainder-padding)))
 320            (padding-chars (/ padding-bits 6))
 321            (padded-length (/ (+ padded-bits padding-bits) 6))
 322            (last-line-len (if (plusp columns)
 323                               (- padded-length (* columns
 324                                                   (truncate
 325                                                    padded-length columns)))
 326                               0))
 327            (num-lines (if (plusp columns)
 328                           (truncate (+ padded-length (1- columns)) columns)
 329                           0))
 330            (num-breaks (if (plusp num-lines)
 331                            (1- num-lines)
 332                            0))
 333            (strlen (+ padded-length num-breaks))
 334            (last-char (1- strlen))
 335            (str (make-string strlen))
 336            (col (if (zerop last-line-len)
 337                      columns
 338                     last-line-len)))
 339       (declare (fixnum padded-length num-lines col last-char
 340                        padding-chars last-line-len))
 341       (unless (plusp columns)
 342         (setq col -1)) ;; set to flag to optimize in loop
 343
 344       (dotimes (i padding-chars)
 345         (declare (fixnum i))
 346         (setf (schar str (the fixnum (- last-char i))) pad))
 347
 348       (do* ((strpos (- last-char padding-chars) (1- strpos))
 349             (int (ash input (/ padding-bits 3))))
 350            ((minusp strpos)
 351             str)
 352         (declare (fixnum strpos) (integer int))
 353         (cond
 354           ((zerop col)
 355            (setf (schar str strpos) #\Newline)
 356            (setq col columns))
 357           (t
 358            (setf (schar str strpos)
 359                  (schar encode-table (the fixnum (logand int #x3f))))
 360            (setq int (ash int -6))
 361            (decf col)))))))
 362
 363 (defun integer-to-base64-stream (input stream &key (uri nil) (columns 0))
 364   "Encode an integer to base64 format."
 365   (declare (integer input)
 366            (fixnum columns)
 367            (optimize (speed 3)))
 368   (let ((pad (if uri *uri-pad-char* *pad-char*))
 369         (encode-table (if uri *uri-encode-table* *encode-table*)))
 370     (declare (simple-string encode-table)
 371              (character pad))
 372     (let* ((input-bits (integer-length input))
 373            (byte-bits (round-next-multiple input-bits 8))
 374            (padded-bits (round-next-multiple byte-bits 6))
 375            (remainder-padding (mod padded-bits 24))
 376            (padding-bits (if (zerop remainder-padding)
 377                              0
 378                              (- 24 remainder-padding)))
 379            (padding-chars (/ padding-bits 6))
 380            (padded-length (/ (+ padded-bits padding-bits) 6))
 381            (strlen padded-length)
 382            (nonpad-chars (- strlen padding-chars))
 383            (last-nonpad-char (1- nonpad-chars))
 384            (str (make-string strlen)))
 385       (declare (fixnum padded-length last-nonpad-char))
 386       (do* ((strpos 0 (1+ strpos))
 387             (int (ash input (/ padding-bits 3)) (ash int -6))
 388             (6bit-value (logand int #x3f) (logand int #x3f)))
 389            ((= strpos nonpad-chars)
 390             (let ((col 0))
 391               (declare (fixnum col))
 392               (dotimes (i nonpad-chars)
 393                 (declare (fixnum i))
 394                 (write-char (schar str i) stream)
 395                 (when (plusp columns)
 396                   (incf col)
 397                   (when (= col columns)
 398                     (write-char #\Newline stream)
 399                     (setq col 0))))
 400               (dotimes (ipad padding-chars)
 401                 (declare (fixnum ipad))
 402                 (write-char pad stream)
 403                 (when (plusp columns)
 404                   (incf col)
 405                   (when (= col columns)
 406                     (write-char #\Newline stream)
 407                     (setq col 0)))))
 408             stream)
 409         (declare (fixnum 6bit-value strpos)
 410                  (integer int))
 411         (setf (schar str (- last-nonpad-char strpos))
 412               (schar encode-table 6bit-value))
 413         ))))
 414