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