module (ice-9 base64)

[Thien-Thi Nguyen]

folks,

guile 1.4.1.99 will include the module (ice-9 base64), source appended.
probably the output buffering stuff deserves its own module once it's
cleaned up a bit.

thi


_____________________________________________
;;; base64.scm --- base64 encode/decode

;;      Copyright (C) 2004 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Commentary:

;; The base64 encoding (rfc 2045) is basically a 3-byte to
;; 4-byte transform:
;;
;; GGGGGGGG NNNNNNNN UUUUUUUU <=> GGGGGG GGNNNN NNNNUU UUUUUU
;;
;; modulo line breaks and terminating delimiters.  It is used
;; in MIME, HTTP, and other protocols where the transmission
;; medium may not be guaranteed 8-bit clean.

;;; Code:

(define-module (ice-9 base64)
  #:export (base64-encode base64-decode))

;;; support

(define (string-getc!-proc input)
  (let ((len (string-length input)) (p 0))
    (lambda ()                          ; rv
      (and (not (= p len))
           (let ((c (string-ref input p)))
             (set! p (1+ p))
             c)))))

(define (port-getc!-proc input)
  (lambda ()                            ; rv
    (let ((c (read-char input)))
      (and (not (eof-object? c)) c))))

(define (analyze-input input)           ; => (getc! . exp-input)
  (cond ((string? input)
         (cons (string-getc!-proc input)
               (string-length input)))
        ((port? input)
         (cons (port-getc!-proc input)
               (and=> (port-filename input)
                      (lambda (name)
                        (let ((guess (false-if-exception
                                      (stat:size (stat name)))))
                          (and (number? guess)
                               (not (< 0 guess))
                               guess))))))
        (else #f)))

(define c2i char->integer)
(define i2c integer->char)

(define (char+ c n)
  (i2c (+ (c2i c) n)))

(define *reasonable-chunk* (ash 1 (ash 1 (ash 1 (ash 1 (ash 1 0)))))) ; 64 KiB

(define subs make-shared-substring)

(define (make-buffer-stack size)
  (let ((cur #f) (stack '()) (idx size))

    (define (new!)
      (set! cur (make-string size))
      (set! stack (cons cur stack))
      (set! idx 0))

    (define (spill!)
      (or (= idx size) (set-car! stack (subs (car stack) 0 idx)))
      (let ((res (apply string-append (reverse! stack))))
        (set! cur #f)
        (set! stack '())
        (set! idx size)
        res))

    ;; rv
    (lambda (c)
      (cond (c (and (= idx size) (new!))
               (string-set! cur idx c)
               (set! idx (1+ idx)))
            (else (spill!))))))

(define (make-outp-buffer outp size)
  (let ((buf (make-string size)) (idx 0) (count 0))

    (define (>OUT flush? x)    ;;; todo: make non-blocking if (not flush?)
      (display x outp)
      (and flush? (force-output outp)))

    (define (new!)
      (>OUT #f buf)
      (set! idx 0))

    (define (spill!)
      (>OUT #t (if (= idx size) buf (subs buf 0 idx)))
      (set! idx 0)
      (let ((rv count))
        (set! count 0)
        rv))

    ;; rv
    (lambda (c)
      (cond (c (and (= idx size) (new!))
               (string-set! buf idx c)
               (set! idx (1+ idx))
               (set! count (1+ count)))
            (else (spill!))))))

(define (make-ob! output size)          ; output bufferer
  (if output
      (make-outp-buffer output (min *reasonable-chunk* size))
      (make-buffer-stack size)))

;;; encoding

(define *enc-map*
  (let ((em (make-vector 64 #f)))
    (vector-set! em 62 #\+)
    (vector-set! em 63 #\/)
    (do ((i 0 (1+ i)))
        ((= i 26) em)                   ; rv
      (and (< i 10)
           (vector-set! em (+ 52 i) (char+ #\0 i)))
      (vector-set! em (+ 0 i) (char+ #\A i))
      (vector-set! em (+ 26 i) (char+ #\a i)))))

(define (encode! output getc! line-break crlf exp-input)
  (let* ((g #t) (n #t) (u #t)
         (bgrp (and line-break (quotient (max 4 line-break) 4)))
         (ob! (make-ob! output
                        (if exp-input
                            ;; compute exact result size
                            (let ((raw (* 4 (inexact->exact
                                             (ceiling (/ (1- exp-input)
                                                         3))))))
                              (+ raw (if bgrp
                                         (* (quotient raw (* 4 bgrp))
                                            (if crlf 2 1))
                                         0)))
                            *reasonable-chunk*)))
         (lb! (if crlf
                  (lambda () (ob! #\cr) (ob! #\newline))
                  (lambda ()            (ob! #\newline)))))

    (define (acc! x)
      (ob! (if x (vector-ref *enc-map* x) #\=)))

    (define (find!)
      (and=> (getc!) c2i))

    (let loop ((group (1- bgrp)))
      (set! g (find!))
      (set! n (find!))
      (set! u (find!))
      (and g (begin
               (acc! (ash g -2))
               (acc! (and (or g n)
                          (logior (ash (logand (or g 0) 3) 4)
                                  (logand (ash (or n 0) -4) 15))))
               (acc! (and (or n u)
                          (logior (ash (logand (or n 0) 15) 2)
                                  (ash (or u 0) -6))))
               (acc! (and u (logand u 63)))))
      ;;(and g n u bgrp (= 0 (remainder group bgrp)) (lb!))
      (if (and g n u)
          (loop (and bgrp (if (= 0 group)
                              (begin (lb!) (1- bgrp))
                              (1- group))))
          (ob! #f)))))

;; Write to @var{out-port} the result of base64-encoding @var{input} and
;; return the number of bytes written.  If @var{out-port} is #f, return the
;; result as a string, instead.  @var{input} may be a string or a port.
;;
;; Optional third arg @var{line-break} specifies the maximum number of columns
;; to appear in the result before a line break.  Actual number of columns is a
;; rounded-down multiple of four, but not less than four.  The result never
;; ends with a line break.  #f means omit line breaks entirely.
;;
;; Optional fourth arg @var{crlf?} non-#f means use @sc{crlf} for line breaks
;; instead of simply @sc{lf}.
;;
;;-sig: (out-port input [line-break [crlf?]])
;;
(define (base64-encode out-port input . opts)
  (or (and=> (analyze-input input)
             (lambda (pair)             ; (getc! . exp-input)
               (encode! out-port
                        (car pair)
                        (and (not (null? opts))
                             (car opts))
                        (and (not (null? opts))
                             (not (null? (cdr opts)))
                             (cadr opts))
                        (cdr pair))))
      (error "bad input:" input)))

;;; decoding

(define *dec-map*
  (let ((dm (make-vector 256 #f)))
    (do ((i 0 (1+ i)))
        ((= i 64) dm)                   ; rv
      (vector-set! dm (c2i (vector-ref *enc-map* i)) i))))

(define (decode! output getc! exp-input)
  (let ((a #t) (b #t) (c #t) (d #t)
        (ob! (make-ob!
              output
              (if exp-input
                  ;; approximate result size (whitespace not known a priori)
                  (inexact->exact (ceiling (* 3 (/ (1+ exp-input) 4))))
                  *reasonable-chunk*))))

    (define (acc! x)
      (ob! (i2c x)))

    (define (find!)
      (let ((c (getc!)))
        (and c (if (char-whitespace? c)
                   (find!)
                   (vector-ref *dec-map* (c2i c))))))

    ;; do it!
    (let loop ()
      (set! a (find!))
      (set! b (find!))
      (set! c (find!))
      (set! d (find!))
      (and a b (acc! (logior (ash a 2) (ash b -4))))
      (and b c (acc! (logior (ash (logand b 15) 4) (ash c -2))))
      (and c d (acc! (logior (ash (logand c 3) 6) d)))
      (if (and a b c d)
          (loop)
          (ob! #f)))))

;; Write to @var{out-port} the result of base64-decoding @var{input} and
;; return the number of bytes written.  If @var{out-port} is #f, return the
;; result as a string, instead.  @var{input} may be a string or a port.
;;
(define (base64-decode out-port input)
  (or (and=> (analyze-input input)
             (lambda (pair)             ; (getc! . exp-input)
               (decode! out-port
                        (car pair)
                        (cdr pair))))
      (error "bad input:" input)))

;;; base64.scm ends here