suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

formatting etc

Browse Source 
svn: r5045

original commit: f17f7bc479
This commit is contained in:
Eli Barzilay 2006-12-06 21:23:38 +00:00
parent e6fc4d4027
commit c276d448fe
19 changed files with 533 additions and 553 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/net/cgi.ss
View File

@ -1,7 +1,5 @@
(module cgi mzscheme
(require (lib "unit.ss")
"cgi-sig.ss"
"cgi-unit.ss")
(require (lib "unit.ss") "cgi-sig.ss" "cgi-unit.ss")
(define-values/invoke-unit/infer cgi@)

6
collects/net/cookie.ss
View File

@ -1,8 +1,6 @@
(module cookie mzscheme
(require (lib "unit.ss")
"cookie-sig.ss"
"cookie-unit.ss")
(require (lib "unit.ss") "cookie-sig.ss" "cookie-unit.ss")
(provide-signature-elements cookie^)
(define-values/invoke-unit/infer cookie@))
(define-values/invoke-unit/infer cookie@))

4
collects/net/dns.ss
View File

@ -1,7 +1,5 @@
(module dns mzscheme
(require (lib "unit.ss")
"dns-sig.ss"
"dns-unit.ss")
(require (lib "unit.ss") "dns-sig.ss" "dns-unit.ss")
(define-values/invoke-unit/infer dns@)

4
collects/net/ftp.ss
View File

@ -1,7 +1,5 @@
(module ftp mzscheme
(require (lib "unit.ss")
"ftp-sig.ss"
"ftp-unit.ss")
(require (lib "unit.ss") "ftp-sig.ss" "ftp-unit.ss")
(define-values/invoke-unit/infer ftp@)

23
collects/net/imap.ss
View File

@ -1,11 +1,8 @@
(module imap mzscheme
(require (lib "unit.ss")
(lib "contract.ss")
"imap-sig.ss"
"imap-unit.ss")
(require (lib "unit.ss") (lib "contract.ss") "imap-sig.ss" "imap-unit.ss")
(define-values/invoke-unit/infer imap@)
(provide/contract
[imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)]
[imap-list-child-mailboxes
@ -14,7 +11,7 @@
(imap-connection? (or/c false/c bytes?) (or/c false/c bytes?)
. -> .
(listof (list/c (listof symbol?) bytes?))))])
(provide
imap-connection?
imap-connect imap-connect*
@ -25,7 +22,7 @@
imap-noop
imap-poll
imap-status
imap-port-number ; a parameter
imap-new?
@ -35,18 +32,18 @@
imap-uidvalidity
imap-unseen
imap-reset-new!
imap-get-expunges
imap-pending-expunges?
imap-get-updates
imap-pending-updates?
imap-get-messages
imap-copy imap-append
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
imap-mailbox-exists?
imap-create-mailbox
imap-mailbox-flags))
imap-mailbox-flags))

120
collects/net/mime-util.ss
View File

@ -2,7 +2,7 @@
;;; <mime-util.ss> ---- Extra utilities
;;; Time-stamp: <01/05/07 17:41:12 solsona>
;;;
;;; Copyright (C) 2001 by Francisco Solsona.
;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file is part of mime-plt.
@ -40,22 +40,22 @@
;; that has character c
(define string-index
(lambda (s c)
(let ((n (string-length s)))
(let loop ((i 0))
(cond ((>= i n) #f)
((char=? (string-ref s i) c) i)
(else (loop (+ i 1))))))))
(let ([n (string-length s)])
(let loop ([i 0])
(cond [(>= i n) #f]
[(char=? (string-ref s i) c) i]
[else (loop (+ i 1))])))))
;; string-tokenizer breaks string s into substrings separated by character c
(define string-tokenizer
(lambda (c s)
(let loop ((s s))
(if (string=? s "") '()
(let ((i (string-index s c)))
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1)
(string-length s))))
(list s)))))))
(let loop ([s s])
(if (string=? s "") '()
(let ([i (string-index s c)])
(if i (cons (substring s 0 i)
(loop (substring s (+ i 1)
(string-length s))))
(list s)))))))
;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\""))
@ -65,30 +65,30 @@
;; Break out alternate quoted and unquoted parts.
;; Initial and final string are unquoted.
(let-values ([(unquoted quoted)
(let loop ([str str][unquoted null][quoted null])
(let ([m (regexp-match-positions re:quote-start str)])
(if m
(let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse! (cons str unquoted)) (reverse! quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts:
(apply
string-append
(let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
(car quoted)
(loop (cdr unquoted) (cdr quoted))))))))))
(let loop ([str str] [unquoted null] [quoted null])
(let ([m (regexp-match-positions re:quote-start str)])
(if m
(let ([prefix (substring str 0 (caar m))]
[rest (substring str (add1 (caar m)) (string-length str))])
;; Find closing quote
(let ([m (regexp-match-positions re:quote-start rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
(loop rest (cons prefix unquoted) (cons (format "\"~a\"" inside) quoted)))
;; No closing quote!
(loop "" (cons prefix unquoted) (cons (format "\"~a" rest) quoted)))))
(values (reverse! (cons str unquoted)) (reverse! quoted)))))])
;; Put the pieces back together, stripping spaces for unquoted parts:
(apply
string-append
(let loop ([unquoted unquoted][quoted quoted])
(let ([clean (regexp-replace* re:space (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
(car quoted)
(loop (cdr unquoted) (cdr quoted))))))))))
;; Only trims left and right spaces:
(define trim-spaces
@ -108,39 +108,41 @@
(define re:comments (regexp "^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))"))
(define trim-comments
(lambda (str)
(let* ((positions (regexp-match-positions re:comments str)))
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str))))
(let ([positions (regexp-match-positions re:comments str)])
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str))))
(define lowercase
(lambda (str)
(let loop ((out "") (rest str) (size (string-length str)))
(cond ((zero? size) out)
(else
(loop (string-append out (string
(char-downcase
(string-ref rest 0))))
(substring rest 1 size)
(sub1 size)))))))
(let loop ([out ""] [rest str] [size (string-length str)])
(cond [(zero? size) out]
[else
(loop (string-append out (string
(char-downcase
(string-ref rest 0))))
(substring rest 1 size)
(sub1 size))]))))
(define warning void)
#|
(define warning
void
#;
(lambda (msg . args)
(fprintf (current-error-port)
(apply format (cons msg args)))
(newline (current-error-port))))
|#
(apply format (cons msg args)))
(newline (current-error-port)))
)
;; Copies its input `in' to its ouput port if given, it uses
;; current-output-port if out is not provided.
(define cat
(opt-lambda (in (out (current-output-port)))
(let loop ((ln (read-line in)))
(unless (eof-object? ln)
(fprintf out "~a~n" ln)
(loop (read-line in))))))
(let loop ([ln (read-line in)])
(unless (eof-object? ln)
(fprintf out "~a\n" ln)
(loop (read-line in))))))
)
;;; mime-util.ss ends here

12
collects/net/mime.ss
View File

@ -1,8 +1,8 @@
;;;
;;; <mime.ss> ---- MIME support
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing.
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing.
;;;
;;; This file is part of mime
@ -34,8 +34,8 @@
"qp.ss"
"base64-sig.ss"
"base64.ss"
"head-sig.ss"
"head.ss")
"head-sig.ss"
"head.ss")
(define-unit-from-context base64@ base64^)
(define-unit-from-context qp@ qp^)
@ -43,9 +43,9 @@
(define-compound-unit/infer mime@2 (import) (export mime^)
(link base64@ qp@ head@ mime@))
(define-values/invoke-unit/infer mime@2)
(provide-signature-elements mime^))
;;; mime.ss ends here
;;; mime.ss ends here

4
collects/net/nntp.ss
View File

@ -1,7 +1,5 @@
(module nntp mzscheme
(require (lib "unit.ss")
"nntp-sig.ss"
"nntp-unit.ss")
(require (lib "unit.ss") "nntp-sig.ss" "nntp-unit.ss")
(define-values/invoke-unit/infer nntp@)

5
collects/net/pop3.ss
View File

@ -1,7 +1,5 @@
(module pop3 mzscheme
(require (lib "unit.ss")
"pop3-sig.ss"
"pop3-unit.ss")
(require (lib "unit.ss") "pop3-sig.ss" "pop3-unit.ss")
(define-values/invoke-unit/infer pop3@)
@ -29,5 +27,4 @@
"Status: RO")
("some body" "text" "goes" "." "here" "." "")
> (disconnect-from-server c)
|#

382
collects/net/private/rbtree.ss
View File

@ -20,8 +20,8 @@
(module rbtree mzscheme
(provide new-tree tree-empty?
expunge-insert! expunge-tree->list
fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list)
expunge-insert! expunge-tree->list
fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list)
(define-struct tree (v red? left-count left right parent) (make-inspector))
@ -33,167 +33,167 @@
(define (k+ a b)
(cons (+ (car a) (if (number? b) b (car b)))
(cdr a)))
(cdr a)))
(define (k- a b)
(cons (- (car a) (if (number? b) b (car b)))
(cdr a)))
(cdr a)))
(define kv car)
(define (mk-insert sort-to-left? sort=? right+
left-insert-adjust!
left-rotate-adjust! right-rotate-adjust!)
(define (mk-insert sort-to-left? sort=? right+
left-insert-adjust!
left-rotate-adjust! right-rotate-adjust!)
(define-values (rotate-left! rotate-right!)
(let ([mk
(lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!)
(lambda (t)
(let ([old-east (tree-east t)])
(let ([r (tree-west old-east)])
(set-tree-east! t r)
(when r
(set-tree-parent! r t)))
(let ([p (tree-parent t)])
(set-tree-parent! old-east p)
(if (eq? t (tree-left p))
(set-tree-left! p old-east)
(set-tree-right! p old-east)))
(set-tree-west! old-east t)
(set-tree-parent! t old-east)
(adj-count! t old-east))))])
(values (mk tree-left tree-right set-tree-left! set-tree-right!
left-rotate-adjust!)
(mk tree-right tree-left set-tree-right! set-tree-left!
right-rotate-adjust!))))
(lambda (tree-west tree-east set-tree-west! set-tree-east! adj-count!)
(lambda (t)
(let ([old-east (tree-east t)])
(let ([r (tree-west old-east)])
(set-tree-east! t r)
(when r
(set-tree-parent! r t)))
(let ([p (tree-parent t)])
(set-tree-parent! old-east p)
(if (eq? t (tree-left p))
(set-tree-left! p old-east)
(set-tree-right! p old-east)))
(set-tree-west! old-east t)
(set-tree-parent! t old-east)
(adj-count! t old-east))))])
(values (mk tree-left tree-right set-tree-left! set-tree-right!
left-rotate-adjust!)
(mk tree-right tree-left set-tree-right! set-tree-left!
right-rotate-adjust!))))
(values
;; insert
(lambda (pre-root n)
(let ([new
;; Insert:
(let loop ([t (tree-left pre-root)]
[n n]
[parent pre-root]
[set-child! (lambda (t v)
(set-tree-left! pre-root v))])
(cond
[(not t) (let ([new (make-tree n #t 0 #f #f parent)])
(set-child! parent new)
new)]
[(sort=? n t)
(set-tree-v! t n)
pre-root]
[(sort-to-left? n t)
(left-insert-adjust! t)
(loop (tree-left t) n t set-tree-left!)]
[else
(loop (tree-right t) (right+ n t) t set-tree-right!)]))])
;; Restore red-black property:
(let loop ([v new])
(let ([p (tree-parent v)])
(when (and p (tree-red? p))
(let ([gp (tree-parent p)])
(let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? p (tree-left gp))
(values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))])
(let ([uncle (tree-east (tree-parent p))])
(if (and uncle (tree-red? uncle))
(begin
(set-tree-red?! p #f)
(set-tree-red?! uncle #f)
(set-tree-red?! gp #t)
(loop gp))
(let ([finish (lambda (v)
(let* ([p (tree-parent v)]
[gp (tree-parent p)])
(set-tree-red?! p #f)
(set-tree-red?! gp #t)
(rotate-east! gp)
(loop gp)))])
(if (eq? v (tree-east p))
(begin
(rotate-west! p)
(finish p))
(finish v))))))))))
(set-tree-red?! (tree-left pre-root) #f)))
;; Insert:
(let loop ([t (tree-left pre-root)]
[n n]
[parent pre-root]
[set-child! (lambda (t v)
(set-tree-left! pre-root v))])
(cond
[(not t) (let ([new (make-tree n #t 0 #f #f parent)])
(set-child! parent new)
new)]
[(sort=? n t)
(set-tree-v! t n)
pre-root]
[(sort-to-left? n t)
(left-insert-adjust! t)
(loop (tree-left t) n t set-tree-left!)]
[else
(loop (tree-right t) (right+ n t) t set-tree-right!)]))])
;; Restore red-black property:
(let loop ([v new])
(let ([p (tree-parent v)])
(when (and p (tree-red? p))
(let ([gp (tree-parent p)])
(let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? p (tree-left gp))
(values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))])
(let ([uncle (tree-east (tree-parent p))])
(if (and uncle (tree-red? uncle))
(begin
(set-tree-red?! p #f)
(set-tree-red?! uncle #f)
(set-tree-red?! gp #t)
(loop gp))
(let ([finish (lambda (v)
(let* ([p (tree-parent v)]
[gp (tree-parent p)])
(set-tree-red?! p #f)
(set-tree-red?! gp #t)
(rotate-east! gp)
(loop gp)))])
(if (eq? v (tree-east p))
(begin
(rotate-west! p)
(finish p))
(finish v))))))))))
(set-tree-red?! (tree-left pre-root) #f)))
;; delete (fetch only)
(lambda (pre-root n)
(let ([orig-t (fetch-find-node pre-root n)])
(when orig-t
;; Delete note t if it has at most one child.
;; Otherwise, move a leaf's data to here, and
;; delete the leaf.
(let ([t (if (and (tree-left orig-t)
(tree-right orig-t))
(let loop ([t (tree-right orig-t)])
(if (tree-left t)
(loop (tree-left t))
t))
orig-t)])
(unless (eq? t orig-t)
;; Swap out:
(let ([delta (kv (tree-v t))])
(set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t)))
(let loop ([c (tree-right orig-t)])
(when c
(set-tree-v! c (k- (tree-v c) delta))
(loop (tree-left c))))))
;; Now we can delete t:
(let ([child-t (or (tree-left t)
(tree-right t))]
[p (tree-parent t)])
(when child-t
(set-tree-parent! child-t p)
;; Adjust relative index of left spine of the
;; right branch (in the case that there was only
;; a right branch)
(let loop ([c (tree-right t)])
(when c
(set-tree-v! c (k+ (tree-v c) (tree-v t)))
(loop (tree-left c)))))
(if (eq? (tree-left p) t)
(set-tree-left! p child-t)
(set-tree-right! p child-t))
;; Restore red-black property:
(when (not (tree-red? t))
(let loop ([c child-t] [p p])
(cond
[(and c (tree-red? c)) (set-tree-red?! c #f)]
[(tree-parent p)
(let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? c (tree-left p))
(values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))])
(let ([sibling (tree-east p)])
(let ([z (if (tree-red? sibling)
(begin
(set-tree-red?! sibling #f)
(set-tree-red?! p #t)
(rotate-west! p)
(tree-east p))
sibling)])
(if (not (or (and (tree-west z)
(tree-red? (tree-west z)))
(and (tree-east z)
(tree-red? (tree-east z)))))
(begin
(set-tree-red?! z #t)
(loop p (tree-parent p)))
(let ([w (if (not (and (tree-east z)
(tree-red? (tree-east z))))
(begin
(set-tree-red?! (tree-west z) #f)
(set-tree-red?! z #t)
(rotate-east! z)
(tree-east p))
z)])
(set-tree-red?! w (tree-red? p))
(set-tree-red?! p #f)
(set-tree-red?! (tree-east w) #f)
(rotate-west! p))))))]))))))))))
(when orig-t
;; Delete note t if it has at most one child.
;; Otherwise, move a leaf's data to here, and
;; delete the leaf.
(let ([t (if (and (tree-left orig-t)
(tree-right orig-t))
(let loop ([t (tree-right orig-t)])
(if (tree-left t)
(loop (tree-left t))
t))
orig-t)])
(unless (eq? t orig-t)
;; Swap out:
(let ([delta (kv (tree-v t))])
(set-tree-v! orig-t (k+ (tree-v t) (tree-v orig-t)))
(let loop ([c (tree-right orig-t)])
(when c
(set-tree-v! c (k- (tree-v c) delta))
(loop (tree-left c))))))
;; Now we can delete t:
(let ([child-t (or (tree-left t)
(tree-right t))]
[p (tree-parent t)])
(when child-t
(set-tree-parent! child-t p)
;; Adjust relative index of left spine of the
;; right branch (in the case that there was only
;; a right branch)
(let loop ([c (tree-right t)])
(when c
(set-tree-v! c (k+ (tree-v c) (tree-v t)))
(loop (tree-left c)))))
(if (eq? (tree-left p) t)
(set-tree-left! p child-t)
(set-tree-right! p child-t))
;; Restore red-black property:
(when (not (tree-red? t))
(let loop ([c child-t] [p p])
(cond
[(and c (tree-red? c)) (set-tree-red?! c #f)]
[(tree-parent p)
(let-values ([(tree-west tree-east rotate-west! rotate-east!)
(if (eq? c (tree-left p))
(values tree-left tree-right rotate-left! rotate-right!)
(values tree-right tree-left rotate-right! rotate-left!))])
(let ([sibling (tree-east p)])
(let ([z (if (tree-red? sibling)
(begin
(set-tree-red?! sibling #f)
(set-tree-red?! p #t)
(rotate-west! p)
(tree-east p))
sibling)])
(if (not (or (and (tree-west z)
(tree-red? (tree-west z)))
(and (tree-east z)
(tree-red? (tree-east z)))))
(begin
(set-tree-red?! z #t)
(loop p (tree-parent p)))
(let ([w (if (not (and (tree-east z)
(tree-red? (tree-east z))))
(begin
(set-tree-red?! (tree-west z) #f)
(set-tree-red?! z #t)
(rotate-east! z)
(tree-east p))
z)])
(set-tree-red?! w (tree-red? p))
(set-tree-red?! p #f)
(set-tree-red?! (tree-east w) #f)
(rotate-west! p))))))]))))))))))
(define-values (expunge-insert! ---)
(mk-insert
(mk-insert
;; sort-to-left?
(lambda (n t)
((+ n (tree-left-count t)) . < . (tree-v t)))
@ -207,14 +207,14 @@
(set-tree-left-count! t (add1 (tree-left-count t))))
;; left-rotate-adjust!
(lambda (t old-right)
(set-tree-left-count! old-right (+ 1
(tree-left-count old-right)
(tree-left-count t))))
(set-tree-left-count! old-right (+ 1
(tree-left-count old-right)
(tree-left-count t))))
;; right-rotate-adjust!
(lambda (t old-left)
(set-tree-left-count! t (- (tree-left-count t)
(tree-left-count old-left)
1)))))
(tree-left-count old-left)
1)))))
(define-values (fetch-insert! fetch-delete!)
(mk-insert
@ -232,28 +232,28 @@
;; left-rotate-adjust!
(lambda (t old-right)
(set-tree-v! old-right (k+ (tree-v old-right)
(tree-v t))))
(tree-v t))))
;; right-rotate-adjust!
(lambda (t old-left)
(set-tree-v! t (k- (tree-v t)
(tree-v old-left))))))
(tree-v old-left))))))
(define (expunge-tree->list pre-root)
(let loop ([t (tree-left pre-root)])
(if t
(append (loop (tree-left t))
(list (tree-v t))
(loop (tree-right t)))
null)))
(append (loop (tree-left t))
(list (tree-v t))
(loop (tree-right t)))
null)))
(define (fetch-find-node pre-root n)
(let loop ([t (tree-left pre-root)]
[n n])
[n n])
(and t
(cond
[(= n (kv (tree-v t))) t]
[(< n (kv (tree-v t))) (loop (tree-left t) n)]
[else (loop (tree-right t) (- n (kv (tree-v t))))]))))
(cond
[(= n (kv (tree-v t))) t]
[(< n (kv (tree-v t))) (loop (tree-left t) n)]
[else (loop (tree-right t) (- n (kv (tree-v t))))]))))
(define (fetch-find pre-root n)
(let ([t (fetch-find-node pre-root n)])
@ -262,22 +262,22 @@
(define (fetch-shift! pre-root n)
(fetch-delete! pre-root n)
(let loop ([t (tree-left pre-root)]
[n n])
[n n])
(when t
(if (n . < . (kv (tree-v t)))
(begin
(set-tree-v! t (k- (tree-v t) 1))
(loop (tree-left t) n))
(loop (tree-right t)
(- n (kv (tree-v t))))))))
(if (n . < . (kv (tree-v t)))
(begin
(set-tree-v! t (k- (tree-v t) 1))
(loop (tree-left t) n))
(loop (tree-right t)
(- n (kv (tree-v t))))))))
(define (fetch-tree->list pre-root)
(let loop ([t (tree-left pre-root)][d 0])
(if t
(append (loop (tree-left t) d)
(list (k+ (tree-v t) d))
(loop (tree-right t) (+ d (kv (tree-v t)))))
null))))
(append (loop (tree-left t) d)
(list (k+ (tree-v t) d))
(loop (tree-right t) (+ d (kv (tree-v t)))))
null))))
#|
@ -321,7 +321,7 @@ Tests:
[(< n 0) (fetch-delete! t (- n))]
[(inexact? n) (fetch-shift! t (inexact->exact n))]
[else (fetch-insert! t (list n))])
(printf "Check ~a~n" v)
(printf "Check ~a\n" v)
(let ([v (map list v)])
(unless (equal? (fetch-tree->list t) v)
(error 'bad "~s != ~s" (fetch-tree->list t) v))))
@ -356,32 +356,32 @@ Tests:
(cons
(cons n l)
(map (lambda (r) (cons (car l) r))
(in-all-positions n (cdr l))))))
(in-all-positions n (cdr l))))))
(define (permutations l)
(if (or (null? l)
(null? (cdr l)))
(null? (cdr l)))
(list l)
(apply
append
(map (lambda (lol)
(in-all-positions (car l) lol))
(permutations (cdr l))))))
(in-all-positions (car l) lol))
(permutations (cdr l))))))
(define perms (permutations '(1 2 3 4 5 6 7 8)))
(for-each (lambda (l)
(let ([t (new-tree)])
(for-each (lambda (i)
(fetch-insert! t (list i)))
l)
(unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8)))
(error 'perms "bad: ~a" l))
(for-each (lambda (i)
(fetch-delete! t i))
l)
(unless (equal? (fetch-tree->list t) '())
(error 'perms "remove bad: ~a" l))))
perms)
(let ([t (new-tree)])
(for-each (lambda (i)
(fetch-insert! t (list i)))
l)
(unless (equal? (fetch-tree->list t) '((1) (2) (3) (4) (5) (6) (7) (8)))
(error 'perms "bad: ~a" l))
(for-each (lambda (i)
(fetch-delete! t i))
l)
(unless (equal? (fetch-tree->list t) '())
(error 'perms "remove bad: ~a" l))))
perms)
|#

10
collects/net/qp.ss
View File

@ -1,8 +1,8 @@
;;;
;;; <qp.ss> ---- Quoted Printable Encoding/Decoding
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
;;;
;;; This file is part of mime-plt.
@ -26,12 +26,10 @@
;; Commentary:
(module qp mzscheme
(require (lib "unit.ss")
"qp-sig.ss"
"qp-unit.ss")
(require (lib "unit.ss") "qp-sig.ss" "qp-unit.ss")
(define-values/invoke-unit/infer qp@)
(provide-signature-elements qp^))
;;; qp.ss ends here
;;; qp.ss ends here

4
collects/net/sendmail.ss
View File

@ -1,7 +1,5 @@
(module sendmail mzscheme
(require (lib "unit.ss")
"sendmail-sig.ss"
"sendmail-unit.ss")
(require (lib "unit.ss") "sendmail-sig.ss" "sendmail-unit.ss")
(define-values/invoke-unit/infer sendmail@)

172
collects/net/sendurl.ss
View File

@ -4,9 +4,9 @@
(lib "etc.ss")
(lib "port.ss")
(lib "sendevent.ss"))
(provide send-url unix-browser-list browser-preference? external-browser)
(define separate-by-default?
(get-preference 'new-browser-for-urls (lambda () #t)))
@ -22,122 +22,122 @@
(if (browser-preference? x)
x
(error 'external-browser "~a is not a valid browser preference" x)))))
; send-url : str [bool] -> void
(define send-url
(opt-lambda (url-str [separate-window? separate-by-default?])
(cond
[(procedure? (external-browser))
((external-browser) url-str)]
((external-browser) url-str)]
[(eq? (system-type) 'macos)
(if (regexp-match "Blue Box" (system-type 'machine))
;; Classic inside OS X:
(let loop ([l '("MSIE" "NAVG")])
(if (null? l)
(error 'send-url "couldn't start Internet Explorer or Netscape")
(with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))])
(subprocess #f #f #f "by-id" (car l))
(let loop ([retries 2]) ;; <<< Yuck <<<
(if (zero? retries)
(error "enough already") ; caught above
(with-handlers ([exn:fail? (lambda (x)
(loop (sub1 retries)))])
(let ([t (thread (lambda ()
(send-event (car l) "GURL" "GURL" url-str)))])
(sync/timeout 1 t) ;; <<< Yuck (timeout) <<<
(when (thread-running? t)
(kill-thread t)
(error "timeout")))))))))
;; Normal OS Classic:
(send-event "MACS" "GURL" "GURL" url-str))]
(if (regexp-match "Blue Box" (system-type 'machine))
;; Classic inside OS X:
(let loop ([l '("MSIE" "NAVG")])
(if (null? l)
(error 'send-url "couldn't start Internet Explorer or Netscape")
(with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))])
(subprocess #f #f #f "by-id" (car l))
(let loop ([retries 2]) ;; <<< Yuck <<<
(if (zero? retries)
(error "enough already") ; caught above
(with-handlers ([exn:fail? (lambda (x)
(loop (sub1 retries)))])
(let ([t (thread (lambda ()
(send-event (car l) "GURL" "GURL" url-str)))])
(sync/timeout 1 t) ;; <<< Yuck (timeout) <<<
(when (thread-running? t)
(kill-thread t)
(error "timeout")))))))))
;; Normal OS Classic:
(send-event "MACS" "GURL" "GURL" url-str))]
[(or (eq? (system-type) 'macosx)
(equal? "ppc-darwin" (system-library-subpath)))
;; not sure what changed, but this is wrong now.... -robby
;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))
(browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
(equal? "ppc-darwin" (system-library-subpath)))
;; not sure what changed, but this is wrong now.... -robby
;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))
(browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
[(eq? (system-type) 'windows)
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
[(eq? (system-type) 'unix)
(let ([preferred (or (external-browser) (get-preference 'external-browser))])
(cond
[(use-browser 'opera preferred)
=>
(lambda (browser-path)
;; opera may not return -- always open asyncronously
;; opera starts a new browser automatically, if it can't find one
(browser-process* browser-path "-remote"
(format "openURL(~a)"
(if separate-window?
(format "~a,new-window" url-str)
url-str))))]
[(use-browser 'galeon preferred)
=>
(lambda (browser-path)
(browser-process* browser-path
(if separate-window? "-w" "-x")
url-str))]
[(or (use-browser 'netscape preferred)
(use-browser 'mozilla preferred))
=>
(lambda (browser-path)
;; netscape's -remote returns with an error code, if no
;; netscape is around. start a new netscape in that case.
(or (system* browser-path "-remote"
(format "openURL(~a)"
(if separate-window?
(format "~a,new-window" url-str)
url-str)))
(browser-process* browser-path url-str)))]
[(use-browser 'dillo preferred)
=>
(lambda (browser-path)
(browser-process* browser-path url-str))]
[(custom-browser? preferred)
(let ([cmd (string-append (car preferred)
url-str
(cdr preferred))])
(browser-process cmd))]
[else
(error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))]
(let ([preferred (or (external-browser) (get-preference 'external-browser))])
(cond
[(use-browser 'opera preferred)
=>
(lambda (browser-path)
;; opera may not return -- always open asyncronously
;; opera starts a new browser automatically, if it can't find one
(browser-process* browser-path "-remote"
(format "openURL(~a)"
(if separate-window?
(format "~a,new-window" url-str)
url-str))))]
[(use-browser 'galeon preferred)
=>
(lambda (browser-path)
(browser-process* browser-path
(if separate-window? "-w" "-x")
url-str))]
[(or (use-browser 'netscape preferred)
(use-browser 'mozilla preferred))
=>
(lambda (browser-path)
;; netscape's -remote returns with an error code, if no
;; netscape is around. start a new netscape in that case.
(or (system* browser-path "-remote"
(format "openURL(~a)"
(if separate-window?
(format "~a,new-window" url-str)
url-str)))
(browser-process* browser-path url-str)))]
[(use-browser 'dillo preferred)
=>
(lambda (browser-path)
(browser-process* browser-path url-str))]
[(custom-browser? preferred)
(let ([cmd (string-append (car preferred)
url-str
(cdr preferred))])
(browser-process cmd))]
[else
(error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))]
[else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))
; : tst -> bool
(define (custom-browser? x)
(and (pair? x) (string? (car x)) (string? (cdr x))))
(define unix-browser-list '(opera galeon netscape mozilla dillo))
; : (cons tst (listof tst)) -> str
(define (orify l)
(cond
[(null? (cdr l)) (format "~a" (car l))]
[(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))]
[else
[else
(let loop ([l l])
(cond
[(null? (cdr l)) (format "or ~a" (car l))]
[else (string-append (format "~a, " (car l)) (loop (cdr l)))]))]))
; : sym sym -> (U #f str)
; to find the path for the named browser, unless another browser is preferred
(define (use-browser browser-name preferred)
(and (or (not preferred)
(eq? preferred browser-name))
(find-executable-path (symbol->string browser-name) #f)))
(eq? preferred browser-name))
(find-executable-path (symbol->string browser-name) #f)))
;; run-browser : process-proc list-of-strings -> void
(define (run-browser process*/ports args)
(let-values ([(stdout stdin pid stderr control)
(apply values (apply process*/ports
(open-output-nowhere)
#f
(current-error-port)
args))])
(apply values (apply process*/ports
(open-output-nowhere)
#f
(current-error-port)
args))])
(close-output-port stdin)
(thread (lambda ()
(control 'wait)
(when (eq? 'done-error (control 'status))
(error 'run-browser "process execute failed: ~e" args))))
(control 'wait)
(when (eq? 'done-error (control 'status))
(error 'run-browser "process execute failed: ~e" args))))
(void)))
(define (browser-process* . args)

4
collects/net/smtp.ss
View File

@ -1,7 +1,5 @@
(module smtp mzscheme
(require (lib "unit.ss")
"smtp-sig.ss"
"smtp-unit.ss")
(require (lib "unit.ss") "smtp-sig.ss" "smtp-unit.ss")
(define-values/invoke-unit/infer smtp@)

106
collects/net/ssl-tcp-unit.ss
View File

@ -2,62 +2,62 @@
(provide make-ssl-tcp@)
(require (lib "unit.ss")
"tcp-sig.ss"
(lib "mzssl.ss" "openssl")
(lib "etc.ss"))
(define (make-ssl-tcp@
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
client-cert-file client-key-file client-root-cert-files)
(unit
(import)
(export tcp^)
(define ctx (ssl-make-client-context))
(when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
(lib "mzssl.ss" "openssl")
(lib "etc.ss"))
(define (tcp-abandon-port p)
(if (input-port? p)
(close-input-port p)
(close-output-port p)))
(define (make-ssl-tcp@
server-cert-file server-key-file server-root-cert-files server-suggest-auth-file
client-cert-file client-key-file client-root-cert-files)
(unit
(import)
(export tcp^)
(define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break)
(define ctx (ssl-make-client-context))
(when client-cert-file
(ssl-load-certificate-chain! ctx client-cert-file))
(when client-key-file
(ssl-load-private-key! ctx client-key-file))
(when client-root-cert-files
(ssl-set-verify! ctx #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! ctx f))
client-root-cert-files))
;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p)
#f)
(define (tcp-abandon-port p)
(if (input-port? p)
(close-input-port p)
(close-output-port p)))
(define tcp-addresses ssl-addresses)
(define tcp-close ssl-close)
(define tcp-connect
(opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define tcp-accept ssl-accept)
(define tcp-accept/enable-break ssl-accept/enable-break)
(define tcp-listen
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
(when server-key-file
(ssl-load-private-key! l server-key-file))
(when server-root-cert-files
(ssl-set-verify! l #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! l f))
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
;; accept-ready? doesn't really work for SSL:
(define (tcp-accept-ready? p)
#f)
(define tcp-listener? ssl-listener?))))
(define tcp-addresses ssl-addresses)
(define tcp-close ssl-close)
(define tcp-connect
(opt-lambda (hostname port-k)
(ssl-connect hostname port-k ctx)))
(define tcp-connect/enable-break
(opt-lambda (hostname port-k)
(ssl-connect/enable-break hostname port-k ctx)))
(define tcp-listen
(opt-lambda (port [allow-k 4] [reuse? #f] [hostname #f])
(let ([l (ssl-listen port allow-k reuse? hostname)])
(when server-cert-file
(ssl-load-certificate-chain! l server-cert-file))
(when server-key-file
(ssl-load-private-key! l server-key-file))
(when server-root-cert-files
(ssl-set-verify! l #t)
(map (lambda (f)
(ssl-load-verify-root-certificates! l f))
server-root-cert-files))
(when server-suggest-auth-file
(ssl-load-suggested-certificate-authorities! l server-suggest-auth-file))
l)))
(define tcp-listener? ssl-listener?))))

44
collects/net/tcp-redirect.ss
View File

@ -1,14 +1,14 @@
(module tcp-redirect mzscheme
(provide tcp-redirect)
(require (lib "unit.ss")
(lib "async-channel.ss")
(lib "etc.ss")
"tcp-sig.ss")
(define raw:tcp-abandon-port tcp-abandon-port)
(define raw:tcp-accept tcp-accept)
(define raw:tcp-accept/enable-break tcp-accept/enable-break)
(define raw:tcp-accept tcp-accept)
(define raw:tcp-accept/enable-break tcp-accept/enable-break)
(define raw:tcp-accept-ready? tcp-accept-ready?)
(define raw:tcp-addresses tcp-addresses)
(define raw:tcp-close tcp-close)
@ -16,11 +16,11 @@
(define raw:tcp-connect/enable-break tcp-connect/enable-break)
(define raw:tcp-listen tcp-listen)
(define raw:tcp-listener? tcp-listener?)
; For tcp-listeners, we use an else branch in the conds since
; (instead of a contract) I want the same error message as the raw
; primitive for bad inputs.
; : (listof nat) -> (unit/sig () -> net:tcp^)
(define tcp-redirect
(opt-lambda (redirected-ports [redirected-address "127.0.0.1"])
@ -29,12 +29,12 @@
(export tcp^)
; : (make-pipe-listener nat (channel (cons iport oport)))
(define-struct pipe-listener (port channel))
; : port -> void
(define (tcp-abandon-port tcp-port)
(when (tcp-port? tcp-port)
(raw:tcp-abandon-port tcp-port)))
; : listener -> iport oport
(define (tcp-accept tcp-listener)
(cond
@ -42,7 +42,7 @@
(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(values (car in-out) (cdr in-out)))]
[else (raw:tcp-accept tcp-listener)]))
; : listener -> iport oport
(define (tcp-accept/enable-break tcp-listener)
(cond
@ -56,20 +56,20 @@
#;(let ([in-out (async-channel-get (pipe-listener-channel tcp-listener))])
(values (car in-out) (cdr in-out)))
[else (raw:tcp-accept/enable-break tcp-listener)]))
; : tcp-listener -> iport oport
; FIX - check channel queue size
(define (tcp-accept-ready? tcp-listener)
(cond
[(pipe-listener? tcp-listener) #t]
[else (raw:tcp-accept-ready? tcp-listener)]))
; : tcp-port -> str str
(define (tcp-addresses tcp-port)
(if (tcp-port? tcp-port)
(raw:tcp-addresses tcp-port)
(values redirected-address redirected-address)))
; : port -> void
(define (tcp-close tcp-listener)
(if (tcp-listener? tcp-listener)
@ -77,7 +77,7 @@
(hash-table-remove!
port-table
(pipe-listener-port tcp-listener))))
; : (str nat -> iport oport) -> str nat -> iport oport
(define (gen-tcp-connect raw)
(lambda (hostname-string port)
@ -99,13 +99,13 @@
(cons to-in to-out))
(values from-in from-out))
(raw hostname-string port))))
; : str nat -> iport oport
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
; : str nat -> iport oport
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
; FIX - support the reuse? flag.
(define tcp-listen
(opt-lambda (port [max-allow-wait 4] [reuse? #f] [hostname-string #f])
@ -118,22 +118,22 @@
(hash-table-put! port-table port listener)
listener)
(raw:tcp-listen port max-allow-wait reuse? hostname-string))))))
; : tst -> bool
(define (tcp-listener? x)
(or (pipe-listener? x) (raw:tcp-listener? x)))
; ---------- private ----------
; : (hash-table nat[port] -> tcp-listener)
(define port-table (make-hash-table))
(define redirect-table
(let ([table (make-hash-table)])
(for-each (lambda (x) (hash-table-put! table x #t))
redirected-ports)
table))
; : nat -> bool
(define (redirect? port)
(hash-table-get redirect-table port (lambda () #f)))))))
(hash-table-get redirect-table port (lambda () #f)))))))

20
collects/net/tcp-sig.ss
View File

@ -1,11 +1,11 @@
(module tcp-sig (lib "a-signature.ss")
tcp-abandon-port
tcp-accept
tcp-accept/enable-break
tcp-accept-ready?
tcp-addresses
tcp-close
tcp-connect
tcp-connect/enable-break
tcp-listen
tcp-listener?)
tcp-abandon-port
tcp-accept
tcp-accept/enable-break
tcp-accept-ready?
tcp-addresses
tcp-close
tcp-connect
tcp-connect/enable-break
tcp-listen
tcp-listener?)

5
collects/net/tcp-unit.ss
View File

@ -1,7 +1,6 @@
(module tcp-unit mzscheme
(provide tcp@)
(require (lib "unit.ss")
"tcp-sig.ss")
(require (lib "unit.ss") "tcp-sig.ss")
(define-unit-from-context tcp@ tcp^))

157
collects/net/unihead.ss
View File

@ -1,53 +1,53 @@
(module unihead mzscheme
(require (lib "base64.ss" "net")
(lib "qp.ss" "net")
(lib "string.ss"))
(lib "qp.ss" "net")
(lib "string.ss"))
(provide encode-for-header
decode-for-header
generalize-encoding)
decode-for-header
generalize-encoding)
(define re:ascii #rx"^[\u0-\u7F]*$")
(define (encode-for-header s)
(if (regexp-match? re:ascii s)
s
(let ([l (regexp-split #rx"\r\n" s)])
(apply string-append
(map encode-line-for-header l)))))
s
(let ([l (regexp-split #rx"\r\n" s)])
(apply string-append
(map encode-line-for-header l)))))
(define (encode-line-for-header s)
(define (loop s string->bytes charset encode encoding)
;; Find ASCII (and no "=") prefix before a space
(let ([m (regexp-match #rx"^([\u0-\u3c\u3e-\u7F]* )(.*)$" s)])
(if m
(string-append
(cadr m)
(loop (caddr m) string->bytes charset encode encoding))
;; Find ASCII (and no "=") suffix after a space
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
(if m
(string-append
(loop (cadr m) string->bytes charset encode encoding)
(caddr m))
(format "=?~a?~a?~a?="
charset encoding
(regexp-replace* #rx#"[\r\n]+$"
(encode (string->bytes s))
#"")))))))
(if m
(string-append
(cadr m)
(loop (caddr m) string->bytes charset encode encoding))
;; Find ASCII (and no "=") suffix after a space
(let ([m (regexp-match #rx"^(.*?)( [\u0-\u3c\u3e-\u7F]*)$" s)])
(if m
(string-append
(loop (cadr m) string->bytes charset encode encoding)
(caddr m))
(format "=?~a?~a?~a?="
charset encoding
(regexp-replace* #rx#"[\r\n]+$"
(encode (string->bytes s))
#"")))))))
(cond
[(regexp-match? re:ascii s)
;; ASCII - do nothing
s]
[(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
[else
;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")]))
[(regexp-match? re:ascii s)
;; ASCII - do nothing
s]
[(regexp-match? #rx"[^\u0-\uFF]" s)
;; Not Latin-1, so use UTF-8
(loop s string->bytes/utf-8 "UTF-8" base64-encode "B")]
[else
;; use Latin-1
(loop s string->bytes/latin-1 "ISO-8859-1"
(lambda (s)
(regexp-replace #rx#" " (qp-encode s) #"_"))
"Q")]))
;; ----------------------------------------
@ -73,45 +73,46 @@
(define (decode-for-header s)
(and s
(let ([m (regexp-match re:encoded
(let ([m (regexp-match re:encoded
(string->bytes/latin-1 s (char->integer #\?)))])
(if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling
(lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64:
base64-decode)
(cadddr (cdr m)))]
[encoding (caddr m)])
(string-append
(decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)])
(cond
[(regexp-match? re:utf-8 encoding)
(bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding) "UTF-8")])
(if c
(let-values ([(r got status)
(bytes-convert c s)])
(bytes-close-converter c)
(if (eq? status 'complete)
(bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s)))
(bytes->string/latin-1 s)))]))
(let ([rest (cadddr (cddr m))])
(let ([rest
;; A CR-LF-space-encoding sequence means that we
;; should drop the space.
(if (and (> (bytes-length rest) 4)
(= 13 (bytes-ref rest 0))
(= 10 (bytes-ref rest 1))
(= 32 (bytes-ref rest 2))
(let ([m (regexp-match-positions
re:encoded rest)])
(and m (= (caaddr m) 5))))
(subbytes rest 3)
rest)])
(decode-for-header (bytes->string/latin-1 rest))))))
s)))))
(if m
(let ([s ((if (member (cadddr m) '(#"q" #"Q"))
;; quoted-printable, with special _ handling
(lambda (x)
(qp-decode (regexp-replace* #rx#"_" x #" ")))
;; base64:
base64-decode)
(cadddr (cdr m)))]
[encoding (caddr m)])
(string-append
(decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)])
(cond
[(regexp-match? re:utf-8 encoding)
(bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding)
"UTF-8")])
(if c
(let-values ([(r got status)
(bytes-convert c s)])
(bytes-close-converter c)
(if (eq? status 'complete)
(bytes->string/utf-8 r #\?)
(bytes->string/latin-1 s)))
(bytes->string/latin-1 s)))]))
(let ([rest (cadddr (cddr m))])
(let ([rest
;; A CR-LF-space-encoding sequence means that we
;; should drop the space.
(if (and (> (bytes-length rest) 4)
(= 13 (bytes-ref rest 0))
(= 10 (bytes-ref rest 1))
(= 32 (bytes-ref rest 2))
(let ([m (regexp-match-positions
re:encoded rest)])
(and m (= (caaddr m) 5))))
(subbytes rest 3)
rest)])
(decode-for-header (bytes->string/latin-1 rest))))))
s)))))