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