decode.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: decode.lisp,v 1.1 2003/01/12 20:25:26 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 (declaim (inline whitespace-p))
  25 (defun whitespace-p (c)
  26   "Returns T for a whitespace character."
  27   (or (char= c #\Newline) (char= c #\Linefeed)
  28       (char= c #\Return) (char= c #\Space)
  29       (char= c #\Tab)))
  30
  31
  32 ;;; Decoding
  33
  34 (defun base64-to-string (string &key (uri nil))
  35   "Decode a base64 string to a string array."
  36   (declare (string string)
  37            (optimize (speed 3)))
  38   (let ((pad (if uri *uri-pad-char* *pad-char*))
  39         (decode-table (if uri *uri-decode-table* *decode-table*)))
  40     (declare (type decode-table decode-table)
  41              (character pad))
  42     (let ((result (make-string (* 3 (truncate (length string) 4))))
  43           (ridx 0))
  44       (declare (simple-string result)
  45                (fixnum ridx))
  46       (loop
  47          for char of-type character across string
  48          for svalue of-type fixnum = (aref decode-table
  49                                            (the fixnum (char-code char)))
  50          with bitstore of-type fixnum = 0
  51          with bitcount of-type fixnum = 0
  52          do
  53            (cond
  54              ((>= svalue 0)
  55               (setf bitstore (logior
  56                               (the fixnum (ash bitstore 6))
  57                               svalue))
  58               (incf bitcount 6)
  59               (when (>= bitcount 8)
  60                 (decf bitcount 8)
  61                 (setf (char result ridx)
  62                       (code-char (the fixnum
  63                                    (logand
  64                                     (the fixnum
  65                                       (ash bitstore
  66                                            (the fixnum (- bitcount))))
  67                                     #xFF))))
  68                 (incf ridx)
  69                 (setf bitstore (the fixnum (logand bitstore #xFF)))))
  70              ((char= char pad)
  71               ;; Could add checks to make sure padding is correct
  72               ;; Currently, padding is ignored
  73               )
  74              ((whitespace-p char)
  75               ;; Ignore whitespace
  76               )
  77              ((minusp svalue)
  78               (warn "Bad character ~W in base64 decode" char))
  79 ))
  80       (subseq result 0 ridx))))
  81
  82 #|
  83 (def-base64-stream-to-* :string)
  84 (def-base64-stream-to-* :stream)
  85 (def-base64-stream-to-* :usb8-array)
  86 |#
  87
  88 (defmacro def-base64-string-to-* (output-type)
  89   `(defun ,(case output-type
  90             (:string
  91              'base64-string-to-string)
  92             (:stream
  93              'base64-string-to-stream)
  94             (:usb8-array
  95              'base64-string-to-usb8-array))
  96        (input &key (uri nil)
  97         ,@(when (eq output-type :stream)
  98                 '(stream)))
  99      "Decode base64 string"
 100      (declare (input string)
 101               (optimize (speed 3)))
 102      (let ((pad (if uri *uri-pad-char* *pad-char*))
 103            (decode-table (if uri *uri-decode-table* *decode-table*)))
 104        (declare (type decode-table decode-table)
 105                 (character pad))
 106        (let (,@(case output-type
 107                      (:string
 108                       '((result (make-string (* 3 (truncate (length string) 4))))))
 109                      (:usb8-array
 110                       '((result (make-array (* 3 (truncate (length string) 4))
 111                                  :element-type '(unsigned-byte 8)
 112                                  :fill-pointer nil
 113                                  :adjustable nil)))))
 114                (ridx 0))
 115          (declare ,@(case output-type
 116                           (:string
 117                            '((simple-string result))
 118                            (:usb8-array
 119                             '((type (array fixnum (*)) result)))))
 120                   (fixnum ridx))
 121          (loop
 122             for char of-type character across string
 123             for svalue of-type fixnum = (aref decode-table
 124                                               (the fixnum (char-code char)))
 125             with bitstore of-type fixnum = 0
 126             with bitcount of-type fixnum = 0
 127             do
 128               (cond
 129                 ((>= svalue 0)
 130                  (setf bitstore (logior
 131                                  (the fixnum (ash bitstore 6))
 132                                  svalue))
 133                  (incf bitcount 6)
 134                  (when (>= bitcount 8)
 135                    (decf bitcount 8)
 136                    (let ((svalue (the fixnum
 137                                    (logand
 138                                     (the fixnum
 139                                       (ash bitstore
 140                                            (the fixnum (- bitcount))))
 141                                     #xFF))))
 142                      (declare (fixnum svalue))
 143                      ,@(case output-type
 144                              (:string
 145                               (setf (char result ridx) (code-char svalue)))
 146                              (:usb8-array
 147                               (setf (aref result ridx) svalue))
 148                              (:stream
 149                               (write-char (code-char svalue) stream)))
 150                      (incf ridx)
 151                      (setf bitstore (the fixnum (logand bitstore #xFF)))))
 152                  ((char= char pad)
 153                   ;; Could add checks to make sure padding is correct
 154                   ;; Currently, padding is ignored
 155                   )
 156                  ((whitespace-p char)
 157                   ;; Ignore whitespace
 158                   )
 159                  ((minusp svalue)
 160                   (warn "Bad character ~W in base64 decode" char))
 161                  ))
 162               (subseq result 0 ridx))))))
 163
 164 (def-base64-string-to-* :string)
 165 (def-base64-string-to-* :stream)
 166 (def-base64-string-to-* :usb8-array)
 167
 168 ;; input-mode can be :string or :stream
 169 ;; input-format can be :character or :usb8
 170
 171 (defun base64-string-to-integer (string &key (uri nil))
 172   "Decodes a base64 string to an integer"
 173   (declare (string string)
 174            (optimize (speed 3)))
 175   (let ((pad (if uri *uri-pad-char* *pad-char*))
 176         (decode-table (if uri *uri-decode-table* *decode-table*)))
 177     (declare (type decode-table decode-table)
 178              (character pad))
 179     (let ((value 0))
 180       (declare (integer value))
 181       (loop
 182          for char of-type character across string
 183          for svalue of-type fixnum =
 184            (aref decode-table (the fixnum (char-code char)))
 185          do
 186            (cond
 187              ((>= svalue 0)
 188               (setq value (+ svalue (ash value 6))))
 189              ((char= char pad)
 190               (setq value (ash value -2)))
 191              ((whitespace-p char)
 192               ; ignore whitespace
 193               )
 194              ((minusp svalue)
 195               (warn "Bad character ~W in base64 decode" char))))
 196       value)))
 197
 198 (defun base64-stream-to-integer (stream &key (uri nil))
 199   "Decodes a base64 string to an integer"
 200   (declare (stream stream)
 201            (optimize (speed 3)))
 202   (let ((pad (if uri *uri-pad-char* *pad-char*))
 203         (decode-table (if uri *uri-decode-table* *decode-table*)))
 204     (declare (type decode-table decode-table)
 205              (character pad))
 206     (do* ((value 0)
 207           (char (read-char stream nil #\null)
 208                 (read-char stream nil #\null)))
 209          ((eq char #\null)
 210           value)
 211       (declare (value integer)
 212                (char character))
 213       (let ((svalue (aref decode-table (the fixnum (char-code char)))))
 214            (declare (fixnum svalue))
 215            (cond
 216              ((>= svalue 0)
 217               (setq value (+ svalue (ash value 6))))
 218              ((char= char pad)
 219               (setq value (ash value -2)))
 220              ((whitespace-p char)               ; ignore whitespace
 221               )
 222              ((minusp svalue)
 223               (warn "Bad character ~W in base64 decode" char))))
 224         value)))