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