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