文字列を Base64 エンコードする


Tags: R6RS, 文字列, Web, FIXME

wikipedia-ja:Base64

エンコード

(import
  (rnrs base)
  (rnrs io ports)
  (rnrs io simple)
  (rnrs bytevectors)
  (rnrs control)
  (rename (rnrs arithmetic bitwise)
    (bitwise-and &&)
    (bitwise-ior !!)
    (bitwise-arithmetic-shift-left <<)
    (bitwise-arithmetic-shift-right >>)))

(define (base64-encode str)
  (define base64chars "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  (define hex->base64char
    (lambda (b) (if (<= 0 b #x3F) (string-ref base64chars b) #\?)))
  (define filter
    (lambda (in out)
      (let* ((b1 (get-u8 in)) (b2 (get-u8 in)) (b3 (get-u8 in)))
        (cond
          ((eof-object? b1))
          ((eof-object? b2)
            (put-char out (hex->base64char (&& #x3F (>> b1 2))))
            (put-char out (hex->base64char (&& #x30 (<< b1 4))))
            (put-char out #\=)
            (put-char out #\=))
          ((eof-object? b3)
            (put-char out (hex->base64char (&& #x3F (>> b1 2))))
            (put-char out (hex->base64char (!! (&& #x30 (<< b1 4)) (&& #x0F (>> b2 4)))))
            (put-char out (hex->base64char (&& #x3C (<< b2 2))))
            (put-char out #\=))
          (else
            (put-char out (hex->base64char (&& #x3F (>> b1 2))))
            (put-char out (hex->base64char (!! (&& #x30 (<< b1 4)) (&& #x0F (>> b2 4)))))
            (put-char out (hex->base64char (!! (&& #x3C (<< b2 2)) (&& #x03 (>> b3 6)))))
            (put-char out (hex->base64char (&& #x3F b3)))
            (filter in out))))))
  (call-with-port (open-bytevector-input-port (string->utf8 str))
    (lambda (in)
      (call-with-string-output-port
        (lambda (out) (filter in out))))))

(base64-encode "逆引き Scheme") ; => "6YCG5byV44GNIFNjaGVtZQ=="

あるいは、

(import (rename (rnrs)
                (bitwise-and &&)
                (bitwise-ior !!)
                (bitwise-arithmetic-shift-left <<)
                (bitwise-arithmetic-shift-right >>)))

(define (base64-encode str)
  (define base64-chars "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
                        abcdefghijklmnopqrstuvwxyz\
                        0123456789+/")
  (define (hex->base64-char b)
    (if (<= 0 b #x3f) (string-ref base64-chars b) #\?))
  (call-with-port (open-bytevector-input-port (string->utf8 str))
    (lambda (in)
      (call-with-string-output-port
        (lambda (out)
          (define (s1 b1)
            (unless (eof-object? b1)
              (put-char out (hex->base64-char (&& #b00111111 (>> b1 2))))
              (s2 b1 (get-u8 in))))
          (define (s2 b1 b2)
            (cond ((eof-object? b2)
                   (put-char out (hex->base64-char (&& #b00110000 (<< b1 4))))
                   (put-char out #\=)
                   (put-char out #\=))
                  (else
                   (put-char out (hex->base64-char
                                  (!! (&& #b00110000 (<< b1 4))
                                      (&& #b00001111 (>> b2 4)))))
                   (s3 b2 (get-u8 in)))))
          (define (s3 b2 b3)
            (cond ((eof-object? b3)
                   (put-char out (hex->base64-char (&& #b00111100 (<< b2 2))))
                   (put-char out #\=))
                  (else
                   (put-char out (hex->base64-char
                                  (!! (&& #b00111100 (<< b2 2))
                                      (&& #b00000011 (>> b3 6)))))
                   (put-char out (hex->base64-char (&& #b00111111 b3)))
                   (s1 (get-u8 in)))))
          (s1 (get-u8 in)))))))

デコード

(import (rename (rnrs)
                (bitwise-and &&)
                (bitwise-ior !!)
                (bitwise-arithmetic-shift-left <<)
                (bitwise-arithmetic-shift-right >>)))

(define (base64-decode str)
  (define base64char->hex
    (lambda (c)
      (cond
        ((char<=? #\A c #\Z) (- (char->integer c) (char->integer #\A)))
        ((char<=? #\a c #\z) (+ (- (char->integer c) (char->integer #\a)) #x1A))
        ((char<=? #\0 c #\9) (+ (- (char->integer c) (char->integer #\0)) #x34))
        ((char=? #\+ c) #x3E)
        ((char=? #\/ c) #x3F)
        (else #f))))
  (define filter
    (lambda (in out)
      (let loop ((c (get-char in)) (oc 0) (counter 0))
        (unless (or (eof-object? c) (char=? #\= c))
          (let ((code (base64char->hex c)))
            (if code
              (cond
                ((= 0 counter)
                 (loop (get-char in) code (+ 1 counter)))
                ((= 1 counter)
                 (put-u8 out (!! (&& #xFC (<< oc 2)) (&& #x03 (>> code 4))))
                 (loop (get-char in) code (+ 1 counter)))
                ((= 2 counter)
                 (put-u8 out (!! (&& #xF0 (<< oc 4)) (&& #x0F (>> code 2))))
                 (loop (get-char in) code (+ 1 counter)))
                ((= 3 counter)
                 (put-u8 out (!! (&& #xC0 (<< oc 6)) (&& #x3F code)))
                 (loop (get-char in) 0 0)))
              (loop (get-char in) oc counter)))))))
  (bytevector->string
    (call-with-port (open-string-input-port str)
      (lambda (in)
        (call-with-bytevector-output-port
          (lambda (out) (filter in out)))))
    (make-transcoder (utf-8-codec))))