Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-07 21:17:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding bytevector support to quoted printable.

Browse source
This commit is contained in:
Alex Shinn 2014-03-21 21:30:54 +09:00
parent f425126a11
commit e36b71a75f
1 changed files with 117 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

211
lib/chibi/quoted-printable.scm
View file

@ -18,30 +18,30 @@
(define *default-max-col* 76)
;; Allow for RFC1522 quoting for headers by always escaping ? and _
(define (qp-encode str start-col max-col separator)
(define (hex i) (integer->char (+ i (if (<= i 9) 48 55))))
(let ((end (string-length str))
(buf (make-string max-col)))
(let lp ((i 0) (col start-col) (res '()))
(define (qp-encode bv start-col max-col separator)
(define (hex i) (+ i (if (<= i 9) 48 55)))
(let ((end (bytevector-length bv))
(buf (make-bytevector max-col))
(out (open-output-bytevector)))
(let lp ((i 0) (col start-col))
(cond
((= i end)
(if (pair? res)
(string-concatenate (reverse (cons (substring buf 0 col) res))
separator)
(substring buf start-col col)))
((>= col (- max-col 3))
(lp i 0 (cons (substring buf (if (pair? res) 0 start-col) col) res)))
(else
(let ((c (char->integer (string-ref str i))))
(cond
((and (<= 33 c 126) (not (memq c '(61 63 95))))
(string-set! buf col (integer->char c))
(lp (+ i 1) (+ col 1) res))
(else
(string-set! buf col #\=)
(string-set! buf (+ col 1) (hex (arithmetic-shift c -4)))
(string-set! buf (+ col 2) (hex (bitwise-and c #b1111)))
(lp (+ i 1) (+ col 3) res)))))))))
((= i end)
(write-bytevector (bytevector-copy buf 0 col) out)
(get-output-bytevector out))
((>= col (- max-col 3))
(write-bytevector (bytevector-copy buf 0 col) out)
(lp i 0))
(else
(let ((c (bytevector-u8-ref bv i)))
(cond
((and (<= 33 c 126) (not (memq c '(61 63 95))))
(bytevector-u8-set! buf col c)
(lp (+ i 1) (+ col 1)))
(else
(bytevector-u8-set! buf col (char->integer #\=))
(bytevector-u8-set! buf (+ col 1) (hex (arithmetic-shift c -4)))
(bytevector-u8-set! buf (+ col 2) (hex (bitwise-and c #b1111)))
(lp (+ i 1) (+ col 3))))))))))
;;> Return a quoted-printable encoded representation of the input
;;> according to the official standard as described in RFC2045.
@ -51,19 +51,29 @@
;;> lines length less than \var{max-col} (default 76). The starting
;;> column may be overridden with \var{start-col} (default 0).
(define (quoted-printable-encode-string . o)
(let ((src (if (pair? o) (car o) (current-input-port)))
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
(car (cddr o))
*default-max-col*)))
(qp-encode (if (string? src) src (read-string #f src))
start-col max-col "=\r\n")))
(define (quoted-printable-encode-string src . o)
(if (string? src)
(utf8->string
(apply quoted-printable-encode-bytevector
(string->utf8 src)
o))
(apply quoted-printable-encode-bytevector src o)))
(define (quoted-printable-encode-bytevector . o)
(let* ((src (if (pair? o) (car o) (current-input-port)))
(o (if (pair? o) (cdr o) '()))
(start-col (if (pair? o) (car o) 0))
(o (if (pair? o) (cdr o) '()))
(max-col (if (pair? o) (car o) *default-max-col*))
(o (if (pair? o) (cdr o) '()))
(sep (if (pair? o) (car o) (string->utf8 "=\r\n"))))
(qp-encode (if (bytevector? src) src (read-bytevector 1000000000 src))
start-col max-col sep)))
;;> Variation of the above to read and write to ports.
(define (quoted-printable-encode . o)
(display (apply quoted-printable-encode-string o)))
(write-string (apply quoted-printable-encode-string o)))
;;> Return a quoted-printable encoded representation of string as
;;> above, wrapped in =?ENC?Q?...?= as per RFC1522, split across
@ -74,82 +84,95 @@
;;> \var{enc}.
(define (quoted-printable-encode-header encoding . o)
(let ((src (if (pair? o) (car o) (current-input-port)))
(start-col (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
(max-col (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
(car (cddr o))
*default-max-col*))
(nl (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (pair? (cdr (cddr o))))
(cadr (cddr o))
"\r\n")))
(let* ((src (if (pair? o) (car o) (current-input-port)))
(o (if (pair? o) (cdr o) '()))
(start-col (if (pair? o) (car o) 0))
(o (if (pair? o) (cdr o) '()))
(max-col (if (pair? o) (car o) *default-max-col*))
(o (if (pair? o) (cdr o) '()))
(nl (if (pair? o) (car o) "\r\n")))
(let* ((prefix (string-append "=?" encoding "?Q?"))
(prefix-length (+ 2 (string-length prefix)))
(separator (string-append "?=" nl "\t" prefix))
(separator (string->utf8 (string-append "?=" nl "\t" prefix)))
(effective-max-col (- max-col prefix-length)))
(string-append prefix
(qp-encode (if (string? src) src (read-string #f src))
start-col effective-max-col separator)
"?="))))
(bytevector-append
(string->utf8 prefix)
(qp-encode (if (string? src) src (read-string #f src))
start-col effective-max-col separator)
(string->utf8 "?=")))))
;;> Return a quoted-printable decoded representation of \var{str}. If
;;> \var{mime-header?} is specified and true, _ will be decoded as as
;;> space in accordance with RFC1522. No errors will be raised on
;;> invalid input.
(define (quoted-printable-decode-string . o)
(define (hex? c) (or (char-numeric? c) (<= 65 (char->integer c) 70)))
(define (unhex1 c)
(let ((i (char->integer c))) (if (>= i 65) (- i 55) (- i 48))))
(define (quoted-printable-decode-string src . o)
(if (string? src)
(utf8->string
(apply quoted-printable-decode-bytevector
(string->utf8 src)
o))
(apply quoted-printable-decode-bytevector src o)))
(define (quoted-printable-decode-bytevector . o)
(define (hex? c)
(or (char<=? #\0 (integer->char c) #\9)
(char<=? #\A (integer->char c) #\F)))
(define (unhex1 i)
(if (>= i 65) (- i 55) (- i 48)))
(define (unhex c1 c2)
(integer->char (+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2))))
(+ (arithmetic-shift (unhex1 c1) 4) (unhex1 c2)))
(let ((src (if (pair? o) (car o) (current-input-port)))
(mime-header? (and (pair? o) (pair? (cdr o)) (car (cdr o)))))
(let* ((str (if (string? src) src (read-string #f src)))
(end (string-length str)))
(call-with-output-string
(lambda (out)
(let lp ((i 0))
(cond
((< i end)
(let ((c (string-ref str i)))
(case c
((#\=) ; = escapes
(let* ((bv (if (bytevector? src) src (read-bytevector 1000000000 src)))
(end (bytevector-length bv))
(out (open-output-bytevector)))
(let lp ((i 0))
(cond
((>= i end)
(get-output-bytevector out))
(else
(let ((c (bytevector-u8-ref bv i)))
(case c
((61) ; = escapes
(cond
((< (+ i 2) end)
(let ((c2 (bytevector-u8-ref bv (+ i 1))))
(cond
((< (+ i 2) end)
(let ((c2 (string-ref str (+ i 1))))
(cond
((eq? c2 #\newline) (lp (+ i 2)))
((eq? c2 #\return)
(lp (if (eq? (string-ref str (+ i 2)) #\newline)
(+ i 3)
(+ i 2))))
((hex? c2)
(let ((c3 (string-ref str (+ i 2))))
(if (hex? c3) (write-char (unhex c2 c3) out))
(lp (+ i 3))))
(else (lp (+ i 3))))))))
((#\_) ; maybe translate _ to space
(write-char (if mime-header? #\space c) out)
(lp (+ i 1)))
((#\space #\tab) ; strip trailing whitespace
(let lp2 ((j (+ i 1)))
(cond
((not (= j end))
(case (string-ref str j)
((#\space #\tab) (lp2 (+ j 1)))
((#\newline)
(lp (+ j 1)))
((#\return)
(let ((k (+ j 1)))
(lp (if (and (< k end)
(eqv? #\newline (string-ref str k)))
(+ k 1) k))))
(else (display (substring str i j) out) (lp j)))))))
(else ; a literal char
(write-char c out)
(lp (+ i 1)))))))))))))
((eq? c2 10) (lp (+ i 2)))
((eq? c2 13)
(lp (if (eq? 10 (bytevector-u8-ref bv (+ i 2)))
(+ i 3)
(+ i 2))))
((hex? c2)
(let ((c3 (bytevector-u8-ref bv (+ i 2))))
(if (hex? c3) (write-u8 (unhex c2 c3) out))
(lp (+ i 3))))
(else (lp (+ i 3))))))))
((95) ; maybe translate _ to space
(write-u8 (if mime-header? 32 c) out)
(lp (+ i 1)))
((32 9) ; strip trailing whitespace
(let lp2 ((j (+ i 1)))
(cond
((not (= j end))
(case (bytevector-u8-ref bv j)
((32 9) (lp2 (+ j 1)))
((10)
(lp (+ j 1)))
((13)
(let ((k (+ j 1)))
(lp (if (and (< k end)
(eq? 10 (bytevector-u8-ref bv k)))
(+ k 1) k))))
(else
(write-bytevector (bytevector-copy bv i j) out)
(lp j)))))))
(else ; a literal char
(write-u8 c out)
(lp (+ i 1)))))))))))
;;> Variation of the above to read and write to ports.
(define (quoted-printable-decode . o)
(display (apply quoted-printable-decode-string o)))
(write-string (apply quoted-printable-decode-string o)))