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