* module (ice-9 base64)
@ 2004-03-05 16:40 Thien-Thi Nguyen
0 siblings, 0 replies; only message in thread
From: Thien-Thi Nguyen @ 2004-03-05 16:40 UTC (permalink / raw)
Cc: guile-user
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
_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2004-03-05 16:40 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2004-03-05 16:40 module (ice-9 base64) Thien-Thi Nguyen
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).