cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

base64.lisp (3651B)

      1 ;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.base64
     24   (:use :cl)
     25   (:export :encode-reader
     26            :decode-reader))
     27 
     28 (in-package :rw.base64)
     29 
     30 (defun encode-reader (reader &key table (suffix #\=))
     31   (let (pending
     32         (table (or table
     33                    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")))
     34     (lambda ()
     35       (cond
     36         (pending (pop pending))
     37         ((not (rw:peek reader)) nil)
     38         (t
     39          (flet ((%next ()
     40                   (let ((x (rw:next reader)))
     41                     (when x
     42                       (assert (<= 0 x #xff))
     43                       x)))
     44                 (%map (x n)
     45                   (char table (ldb (byte 6 n) x))))
     46            (let* ((a (%next))
     47                   (b (%next))
     48                   (c (%next))
     49                   (x (+ (ash a 16) (ash (or b 0) 8) (or c 0))))
     50              (push (if c (%map x 0) suffix) pending)
     51              (push (if b (%map x 6) suffix) pending)
     52              (push (%map x 12) pending)
     53              (%map x 18))))))))
     54 
     55 (defun decode-reader (reader &key table) ;; TODO skip newlines?
     56   (let (pending
     57         (table (or table
     58                    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")))
     59     (lambda ()
     60       (cond
     61         (pending (pop pending))
     62         ((not (rw:peek reader)) nil)
     63         (t
     64          (rw:skip reader)
     65          (let ((x (rw:peek reader)))
     66            (when (and x (position x table))
     67              (flet ((%next ()
     68                       (position (rw:next reader) table))
     69                     (%map (x n)
     70                       (ldb (byte 8 n) x)))
     71                (let* ((a (%next))
     72                       (b (%next))
     73                       (c (%next))
     74                       (d (%next))
     75                       (x (+ (ash a 18) (ash b 12) (ash (or c 0) 6) (or d 0))))
     76                  (when d (push (%map x 0) pending))
     77                  (when c (push (%map x 8) pending))
     78                  (%map x 16))))))))))
     79 
     80 ;;(rw:till (rw:peek-reader (decode-reader (rw:peek-reader (encode-reader (rw:peek-reader (rw:reader #(1 2 3 4 32))))))))
     81 ;;(rw:till (rw:peek-reader (encode-reader (rw:peek-reader (rw:wrap-reader (rw:reader "any carnal pleasure.") #'char-code)))))
     82 ;;(rw:till (rw:peek-reader (rw:wrap-reader (decode-reader (rw:peek-reader (encode-reader (rw:peek-reader (rw:wrap-reader (rw:reader "any carnal pleasure.") #'char-code))))) #'code-char)))
     83 ;;(rw:till (rw:peek-reader (rw:wrap-reader (decode-reader (rw:peek-reader (rw:reader "YW55IGNhcm5hbCBwbGVhc3VyZS4="))) #'code-char)))