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 (module cgi mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "cgi-sig.ss" "cgi-unit.ss")
"cgi-sig.ss"
"cgi-unit.ss")
(define-values/invoke-unit/infer cgi@) (define-values/invoke-unit/infer cgi@)

4
collects/net/cookie.ss
View File

@ -1,7 +1,5 @@
(module cookie mzscheme (module cookie mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "cookie-sig.ss" "cookie-unit.ss")
"cookie-sig.ss"
"cookie-unit.ss")
(provide-signature-elements cookie^) (provide-signature-elements cookie^)

4
collects/net/dns.ss
View File

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

4
collects/net/ftp.ss
View File

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

5
collects/net/imap.ss
View File

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

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

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

4
collects/net/mime.ss
View File

@ -34,8 +34,8 @@
"qp.ss" "qp.ss"
"base64-sig.ss" "base64-sig.ss"
"base64.ss" "base64.ss"
"head-sig.ss" "head-sig.ss"
"head.ss") "head.ss")
(define-unit-from-context base64@ base64^) (define-unit-from-context base64@ base64^)
(define-unit-from-context qp@ qp^) (define-unit-from-context qp@ qp^)

4
collects/net/nntp.ss
View File

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

5
collects/net/pop3.ss
View File

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

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

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

4
collects/net/qp.ss
View File

@ -26,9 +26,7 @@
;; Commentary: ;; Commentary:
(module qp mzscheme (module qp mzscheme
(require (lib "unit.ss") (require (lib "unit.ss") "qp-sig.ss" "qp-unit.ss")
"qp-sig.ss"
"qp-unit.ss")
(define-values/invoke-unit/infer qp@) (define-values/invoke-unit/infer qp@)

4
collects/net/sendmail.ss
View File

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

154
collects/net/sendurl.ss
View File

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

4
collects/net/smtp.ss
View File

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

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

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

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

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

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

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

153
collects/net/unihead.ss
View File

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