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

Recketizing much in `net/*', mass ".ss" -> ".rkt" conversion in .scrbl files.

Browse Source 
(Some other minor things here and there.)

original commit: debd1f9f1e
This commit is contained in:
Eli Barzilay 2011-06-20 04:00:14 -04:00
parent 7c644a8eac
commit dfc0ca2908
40 changed files with 357 additions and 449 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/net/cgi.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "cgi-sig.ss" "cgi-unit.ss")
#lang racket/base
(require racket/unit "cgi-sig.rkt" "cgi-unit.rkt")
(define-values/invoke-unit/infer cgi@)

4
collects/net/cookie.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "cookie-sig.ss" "cookie-unit.ss")
#lang racket/base
(require racket/unit "cookie-sig.rkt" "cookie-unit.rkt")
(provide-signature-elements cookie^)

4
collects/net/dns.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "dns-sig.ss" "dns-unit.ss")
#lang racket/base
(require racket/unit "dns-sig.rkt" "dns-unit.rkt")
(define-values/invoke-unit/infer dns@)

4
collects/net/imap.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit scheme/contract "imap-sig.ss" "imap-unit.ss")
#lang racket/base
(require racket/unit racket/contract "imap-sig.rkt" "imap-unit.rkt")
(define-values/invoke-unit/infer imap@)

30
collects/net/mime-util.rkt
View File

@ -1,5 +1,5 @@
;;;
;;; <mime-util.ss> ---- Extra utilities
;;; <mime-util.rkt> ---- Extra utilities
;;; Time-stamp: <01/05/07 17:41:12 solsona>
;;;
;;; Copyright (C) 2001 by Francisco Solsona.
@ -26,7 +26,7 @@
;;
;; Commentary:
#lang scheme/base
#lang racket/base
(provide string-tokenizer
trim-all-spaces
@ -55,19 +55,17 @@
(list s))))))
;; Trim all spaces, except those in quoted strings.
(define re:quote-start (regexp "\""))
(define re:space (regexp "[ \t\n\r\v]"))
(define (trim-all-spaces str)
;; 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)])
(let ([m (regexp-match-positions #rx"\"" 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)])
(let ([m (regexp-match-positions #rx"\"" rest)])
(if m
(let ([inside (substring rest 0 (caar m))]
[rest (substring rest (add1 (caar m)) (string-length rest))])
@ -78,8 +76,8 @@
;; 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) "")])
(let loop ([unquoted unquoted] [quoted quoted])
(let ([clean (regexp-replace* #rx"[ \t\n\r\v]" (car unquoted) "")])
(if (null? quoted)
(list clean)
(list* clean
@ -92,15 +90,15 @@
(regexp-replace #rx"^[ \t\r\n\v]+" str "")
""))
(define re:comments #rx"^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))")
(define (trim-comments 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 positions
(regexp-match-positions #rx"^[^\"]*(\"[^\"]*\")*[^\"]*(\\(.*\\))" str))
(if positions
(string-append (substring str 0 (caaddr positions))
(substring str (cdaddr positions) (string-length str)))
str))
(define (lowercase str) (string-downcase str))
(define lowercase string-downcase)
(define warning
void
@ -119,4 +117,4 @@
(fprintf out "~a\n" ln)
(loop (read-line in)))))
;;; mime-util.ss ends here
;;; mime-util.rkt ends here

14
collects/net/mime.rkt
View File

@ -1,5 +1,5 @@
;;;
;;; <mime.ss> ---- MIME support
;;; <mime.rkt> ---- MIME support
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Wish Computing.
@ -26,13 +26,9 @@
;;
;; Commentary:
#lang scheme/base
(require scheme/unit
"mime-sig.ss"
"mime-unit.ss"
"qp.ss"
"base64.ss"
"head.ss")
#lang racket/base
(require racket/unit
"mime-sig.rkt" "mime-unit.rkt" "qp.rkt" "base64.rkt" "head.rkt")
;(define-unit-from-context base64@ base64^)
;(define-unit-from-context qp@ qp^)
@ -44,4 +40,4 @@
(provide-signature-elements mime^)
;;; mime.ss ends here
;;; mime.rkt ends here

4
collects/net/nntp.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "nntp-sig.ss" "nntp-unit.ss")
#lang racket/base
(require racket/unit "nntp-sig.rkt" "nntp-unit.rkt")
(define-values/invoke-unit/infer nntp@)

6
collects/net/pop3.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "pop3-sig.ss" "pop3-unit.ss")
#lang racket/base
(require racket/unit "pop3-sig.rkt" "pop3-unit.rkt")
(define-values/invoke-unit/infer pop3@)
@ -7,7 +7,7 @@
#|
> (require-library "pop3.ss" "net")
> (require-library "pop3.rkt" "net")
> (define c (connect-to-server "cs.rice.edu"))
> (authenticate/plain-text "scheme" "********" c)
> (get-mailbox-status c)

489
collects/net/private/rbtree.rkt
View File

@ -1,3 +1,4 @@
#lang racket/base
;; Two variants of red-black trees.
@ -18,273 +19,265 @@
;; decremented by the node's key (recursively). This allows a ln-time
;; shift operation when a message is expunged.
(module rbtree mzscheme
(provide new-tree tree-empty?
expunge-insert! expunge-tree->list
fetch-insert! fetch-find fetch-delete! fetch-shift! fetch-tree->list)
(provide new-tree tree-empty?
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))
(define-struct tree (v red? left-count left right parent)
#:mutable #:transparent)
(define (new-tree)
(make-tree 'pre-root #f 0 #f #f #f))
(define (new-tree)
(make-tree 'pre-root #f 0 #f #f #f))
(define (tree-empty? t)
(not (tree-left t)))
(define (tree-empty? t)
(not (tree-left t)))
(define (k+ a b)
(cons (+ (car a) (if (number? b) b (car b)))
(cdr a)))
(define (k- a b)
(cons (- (car a) (if (number? b) b (car b)))
(cdr a)))
(define kv car)
(define (k+ a b)
(cons (+ (car a) (if (number? b) b (car b)))
(cdr a)))
(define (k- a b)
(cons (- (car a) (if (number? b) b (car b)))
(cdr a)))
(define kv car)
(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!))))
(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!))))
(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)))
(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)))
;; 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))))))]))))))))))
;; 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))))))]))))))))))
(define-values (expunge-insert! ---)
(mk-insert
;; sort-to-left?
(lambda (n t)
((+ n (tree-left-count t)) . < . (tree-v t)))
;; sort=?
(lambda (n t) #f)
;; right+
(lambda (n t)
(+ n 1 (tree-left-count t)))
;; left-insert-adjust!
(lambda (t)
(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))))
;; right-rotate-adjust!
(lambda (t old-left)
(set-tree-left-count! t (- (tree-left-count t)
(tree-left-count old-left)
1)))))
(define-values (expunge-insert! ---)
(mk-insert
;; sort-to-left?
(lambda (n t)
((+ n (tree-left-count t)) . < . (tree-v t)))
;; sort=?
(lambda (n t) #f)
;; right+
(lambda (n t)
(+ n 1 (tree-left-count t)))
;; left-insert-adjust!
(lambda (t)
(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))))
;; right-rotate-adjust!
(lambda (t old-left)
(set-tree-left-count! t (- (tree-left-count t)
(tree-left-count old-left)
1)))))
(define-values (fetch-insert! fetch-delete!)
(mk-insert
;; sort-to-left?
(lambda (n t)
((kv n) . < . (kv (tree-v t))))
;; sort=?
(lambda (n t)
(= (kv n) (kv (tree-v t))))
;; right+
(lambda (n t)
(k- n (tree-v t)))
;; left-insert-adjust!
void
;; left-rotate-adjust!
(lambda (t old-right)
(set-tree-v! old-right (k+ (tree-v old-right)
(tree-v t))))
;; right-rotate-adjust!
(lambda (t old-left)
(set-tree-v! t (k- (tree-v t)
(tree-v old-left))))))
(define-values (fetch-insert! fetch-delete!)
(mk-insert
;; sort-to-left?
(lambda (n t)
((kv n) . < . (kv (tree-v t))))
;; sort=?
(lambda (n t)
(= (kv n) (kv (tree-v t))))
;; right+
(lambda (n t)
(k- n (tree-v t)))
;; left-insert-adjust!
void
;; left-rotate-adjust!
(lambda (t old-right)
(set-tree-v! old-right (k+ (tree-v old-right)
(tree-v t))))
;; right-rotate-adjust!
(lambda (t old-left)
(set-tree-v! t (k- (tree-v t)
(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)))
(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)))
(define (fetch-find-node pre-root n)
(let loop ([t (tree-left pre-root)]
[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))))]))))
(define (fetch-find-node pre-root n)
(let loop ([t (tree-left pre-root)] [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))))]))))
(define (fetch-find pre-root n)
(let ([t (fetch-find-node pre-root n)])
(and t (tree-v t))))
(define (fetch-find pre-root n)
(let ([t (fetch-find-node pre-root n)])
(and t (tree-v t))))
(define (fetch-shift! pre-root n)
(fetch-delete! pre-root n)
(let loop ([t (tree-left pre-root)]
[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))))))))
(define (fetch-shift! pre-root n)
(fetch-delete! pre-root n)
(let loop ([t (tree-left pre-root)] [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))))))))
(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))))
(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)))
#|
Tests:
(require rbtree)
(require mzlib/pretty)
(require rbtree racket/pretty)
(print-struct #t)
(define t (new-tree))

8
collects/net/qp.rkt
View File

@ -1,5 +1,5 @@
;;;
;;; <qp.ss> ---- Quoted Printable Encoding/Decoding
;;; <qp.rkt> ---- Quoted Printable Encoding/Decoding
;;;
;;; Copyright (C) 2002 by PLT.
;;; Copyright (C) 2001 by Francisco Solsona.
@ -26,11 +26,11 @@
;;
;; Commentary:
#lang scheme/base
(require mzlib/unit "qp-sig.ss" "qp-unit.ss")
#lang racket/base
(require racket/unit "qp-sig.rkt" "qp-unit.rkt")
(define-values/invoke-unit/infer qp@)
(provide-signature-elements qp^)
;;; qp.ss ends here
;;; qp.rkt ends here

5
collects/net/scribblings/base64.scrbl
View File

@ -1,8 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/base64
net/base64-unit
net/base64-sig))
@(require "common.rkt" (for-label net/base64 net/base64-unit net/base64-sig))
@title[#:tag "base64"]{Base 64: Encoding and Decoding}

7
collects/net/scribblings/cgi.scrbl
View File

@ -1,9 +1,6 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/cgi
net/uri-codec
net/cgi-unit
net/cgi-sig))
@(require "common.rkt"
(for-label net/cgi net/uri-codec net/cgi-unit net/cgi-sig))
@title[#:tag "cgi"]{CGI Scripts}

8
collects/net/scribblings/common.rkt
View File

@ -1,9 +1,7 @@
#lang scheme/base
#lang racket/base
(require scribble/manual
(for-label scheme/base
scheme/contract))
(for-label racket/base racket/contract))
(provide (all-from-out scribble/manual)
(for-label (all-from-out scheme/base
scheme/contract)))
(for-label (all-from-out racket/base racket/contract)))

7
collects/net/scribblings/cookie.scrbl
View File

@ -1,9 +1,6 @@
#lang scribble/doc
@(require "common.ss"
scribble/eval
(for-label net/cookie
net/cookie-unit
net/cookie-sig))
@(require "common.rkt" scribble/eval
(for-label net/cookie net/cookie-unit net/cookie-sig))
@(define cookie-eval (make-base-eval))
@interaction-eval[#:eval cookie-eval (require net/cookie)]

5
collects/net/scribblings/dns.scrbl
View File

@ -1,8 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/dns
net/dns-unit
net/dns-sig))
@(require "common.rkt" (for-label net/dns net/dns-unit net/dns-sig))
@title[#:tag "dns"]{DNS: Domain Name Service Queries}

5
collects/net/scribblings/ftp.scrbl
View File

@ -1,8 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/ftp
net/ftp-unit
net/ftp-sig))
@(require "common.rkt" (for-label net/ftp net/ftp-unit net/ftp-sig))
@title[#:tag "ftp"]{FTP: Client Downloading}

8
collects/net/scribblings/head.scrbl
View File

@ -1,10 +1,6 @@
#lang scribble/doc
@(require "common.ss"
scribble/eval
scribble/struct
(for-label net/head
net/head-unit
net/head-sig))
@(require "common.rkt" scribble/eval scribble/struct
(for-label net/head net/head-unit net/head-sig))
@(define head-eval (make-base-eval))
@interaction-eval[#:eval head-eval (require net/head)]

8
collects/net/scribblings/imap.scrbl
View File

@ -1,10 +1,6 @@
#lang scribble/doc
@(require "common.ss"
scribble/eval
scribble/struct
(for-label net/imap
net/imap-unit
net/imap-sig))
@(require "common.rkt" scribble/eval scribble/struct
(for-label net/imap net/imap-unit net/imap-sig))
@(define (just-report)
@elem{This operation does not communicate with the server. It merely reports

7
collects/net/scribblings/mime.scrbl
View File

@ -1,9 +1,6 @@
#lang scribble/doc
@(require "common.ss"
scribble/struct
(for-label net/mime
net/mime-unit
net/mime-sig))
@(require "common.rkt" scribble/struct
(for-label net/mime net/mime-unit net/mime-sig))
@(define-syntax-rule (mime-table (type (sub-type0 ref0) (sub-type ref) ...) ...)
(let ([spacer (hspace 1)]

2
collects/net/scribblings/net.scrbl
View File

@ -1,5 +1,5 @@
#lang scribble/doc
@(require "common.ss")
@(require "common.rkt")
@title{@bold{Net}: Racket Networking Libraries}

5
collects/net/scribblings/nntp.scrbl
View File

@ -1,8 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/nntp
net/nntp-unit
net/nntp-sig))
@(require "common.rkt" (for-label net/nntp net/nntp-unit net/nntp-sig))
@title[#:tag "nntp"]{NNTP: Newsgroup Protocol}

7
collects/net/scribblings/pop3.scrbl
View File

@ -1,8 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/pop3
net/pop3-unit
net/pop3-sig))
@(require "common.rkt" (for-label net/pop3 net/pop3-unit net/pop3-sig))
@(define pt (tt ">"))
@ -150,7 +147,7 @@ Raised when the server does not gracefully disconnect.}
@defstruct[(malformed-server-response pop3) ([communicator communicator?])]{
Raised when the server produces a mal-formed response.}
Raised when the server produces a malformed response.}
@section{Example Session}

5
collects/net/scribblings/qp.scrbl
View File

@ -1,8 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/qp
net/qp-unit
net/qp-sig))
@(require "common.rkt" (for-label net/qp net/qp-unit net/qp-sig))
@title[#:tag "qp"]{Quoted-Printable: Encoding and Decoding}

6
collects/net/scribblings/sendmail.scrbl
View File

@ -1,8 +1,6 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/sendmail
net/sendmail-unit
net/sendmail-sig))
@(require "common.rkt"
(for-label net/sendmail net/sendmail-unit net/sendmail-sig))
@title[#:tag "sendmail"]{@exec{sendmail}: Sending E-Mail}

8
collects/net/scribblings/sendurl.scrbl
View File

@ -1,7 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/sendurl
scheme/file))
@(require "common.rkt" (for-label net/sendurl racket/file))
@title[#:tag "sendurl"]{Send URL: Opening a Web Browser}
@ -9,7 +7,7 @@
in the user's chosen web browser.}
See also @schememodname[browser/external], which requires
@scheme[scheme/gui], but can prompt the user for a browser if no
@scheme[racket/gui], but can prompt the user for a browser if no
browser preference is set.
@ -64,7 +62,7 @@ Similar to @scheme[send-url/file], but it consumes the contents of a
page to show, and displayes it from a temporary file.
If @scheme[delete-at] is a number, the temporary file is removed after
this many seconds. The deletion happens in a thread, so if mzscheme
this many seconds. The deletion happens in a thread, so if racket
exits before that it will not happen --- when this function is called
it scans old generated files (this happens randomly, not on every
call) and removes them to avoid cluttering the temporary directory.

8
collects/net/scribblings/smtp.scrbl
View File

@ -1,10 +1,6 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/smtp
net/smtp-unit
net/smtp-sig
scheme/tcp
openssl))
@(require "common.rkt"
(for-label net/smtp net/smtp-unit net/smtp-sig racket/tcp openssl))
@title[#:tag "smtp"]{SMTP: Sending E-Mail}

4
collects/net/scribblings/ssl-tcp-unit.scrbl
View File

@ -1,7 +1,5 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/ssl-tcp-unit
net/tcp-sig))
@(require "common.rkt" (for-label net/ssl-tcp-unit net/tcp-sig))
@title[#:tag "ssl-tcp-unit"]{SSL Unit: @scheme[tcp^] via SSL}

8
collects/net/scribblings/tcp-redirect.scrbl
View File

@ -1,21 +1,19 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/tcp-redirect
net/tcp-sig))
@(require "common.rkt" (for-label net/tcp-redirect net/tcp-sig))
@title[#:tag "tcp-redirect"]{TCP Redirect: @scheme[tcp^] via Channels}
@defmodule[net/tcp-redirect]{The @schememodname[net/tcp-redirect]
library provides a function for directing some TCP port numbers to use
buffered channels instead of the TCP support from
@schememodname[scheme/tcp].}
@schememodname[racket/tcp].}
@defproc[(tcp-redirect [port-numbers (listof (integer-in 0 65535))])
unit?]{
Returns a unit that implements @scheme[tcp^]. For port numbers not
listed in @scheme[port-numbers], the unit's implementations are the
@schememodname[scheme/tcp] implementations.
@schememodname[racket/tcp] implementations.
For the port numbers listed in @scheme[port-numbers] and for
connections to @scheme["127.0.0.1"], the unit's implementation does

40
collects/net/scribblings/tcp.scrbl
View File

@ -1,18 +1,14 @@
#lang scribble/doc
@(require "common.ss"
(for-label net/tcp-sig
net/tcp-unit
net/url-unit
net/tcp-redirect
net/ssl-tcp-unit
scheme/tcp))
@(require "common.rkt"
(for-label net/tcp-sig net/tcp-unit net/url-unit net/tcp-redirect
net/ssl-tcp-unit racket/tcp))
@title[#:tag "tcp"]{TCP: Unit and Signature}
The @schememodname[net/tcp-sig] and @schememodname[net/tcp-unit]
libraries define a @scheme[tcp^] signature and @scheme[tcp@]
implementation, where the implementation uses
@schememodname[scheme/tcp].
@schememodname[racket/tcp].
Some units in the @filepath{net} collection import @scheme[tcp^], so
that they can be used with transports other than plain TCP. For
@ -30,10 +26,10 @@ See also @scheme[tcp-redirect] and @scheme[make-ssl-tcp@].
(integer-in 1 65535))]
[max-allow-wait exact-nonnegative-integer? 4]
[reuse? any/c #f]
[hostname (or/c string? false/c) #f])
[hostname (or/c string? false/c) #f])
@#,sigelem[tcp^ tcp-listener?]]{
Like @scheme[tcp-listen] from @schememodname[scheme/tcp].}
Like @scheme[tcp-listen] from @schememodname[racket/tcp].}
@defproc[(tcp-connect [hostname string?]
[port-no (and/c exact-nonnegative-integer?
@ -45,7 +41,7 @@ Like @scheme[tcp-listen] from @schememodname[scheme/tcp].}
#f])
(values input-port? output-port?)]{
Like @scheme[tcp-connect] from @schememodname[scheme/tcp].}
Like @scheme[tcp-connect] from @schememodname[racket/tcp].}
@defproc[(tcp-connect/enable-break [hostname string?]
[port-no (and/c exact-nonnegative-integer?
@ -56,41 +52,41 @@ Like @scheme[tcp-connect] from @schememodname[scheme/tcp].}
false/c)])
(values input-port? output-port?)]{
Like @scheme[tcp-connect/enable-break] from @schememodname[scheme/tcp].}
Like @scheme[tcp-connect/enable-break] from @schememodname[racket/tcp].}
@defproc[(tcp-accept [listener @#,sigelem[tcp^ tcp-listener?]])
(values input-port? output-port?)]{
Like @scheme[tcp-accept] from @schememodname[scheme/tcp].}
Like @scheme[tcp-accept] from @schememodname[racket/tcp].}
@defproc[(tcp-accept/enable-break [listener @#,sigelem[tcp^ tcp-listener?]])
(values input-port? output-port?)]{
Like @scheme[tcp-accept/enable-break] from @schememodname[scheme/tcp].}
Like @scheme[tcp-accept/enable-break] from @schememodname[racket/tcp].}
@defproc[(tcp-accept-ready? [listener @#,sigelem[tcp^ tcp-listener?]]) boolean?]{
Like @scheme[tcp-accept-ready?] from @schememodname[scheme/tcp].}
Like @scheme[tcp-accept-ready?] from @schememodname[racket/tcp].}
@defproc[(tcp-close [listener @#,sigelem[tcp^ tcp-listener?]]) void?]{
Like @scheme[tcp-close] from @schememodname[scheme/tcp].}
Like @scheme[tcp-close] from @schememodname[racket/tcp].}
@defproc[(tcp-listener? [v any/c]) boolean?]{
Like @scheme[tcp-listener?] from @schememodname[scheme/tcp].}
Like @scheme[tcp-listener?] from @schememodname[racket/tcp].}
@defproc[(tcp-abandon-port [tcp-port port?]) void?]{
Like @scheme[tcp-abandon-port] from @schememodname[scheme/tcp].}
Like @scheme[tcp-abandon-port] from @schememodname[racket/tcp].}
@defproc[(tcp-addresses [tcp-port port?]
[port-numbers? any/c #f])
[port-numbers? any/c #f])
(or/c (values string? string?)
(values string? (integer-in 1 65535)
(values string? (integer-in 1 65535)
string? (integer-in 1 65535)))]{
Like @scheme[tcp-addresses] from @schememodname[scheme/tcp].}
Like @scheme[tcp-addresses] from @schememodname[racket/tcp].}
}
@ -101,4 +97,4 @@ Like @scheme[tcp-addresses] from @schememodname[scheme/tcp].}
@defthing[tcp@ unit?]{
Imports nothing and exports @scheme[tcp^], implemented using
@schememodname[scheme/tcp].}
@schememodname[racket/tcp].}

8
collects/net/scribblings/uri-codec.scrbl
View File

@ -1,11 +1,7 @@
#lang scribble/doc
@(require "common.ss"
scribble/bnf
scribble/eval
@(require "common.rkt" scribble/bnf scribble/eval
(for-label net/url
net/uri-codec
net/uri-codec-unit
net/uri-codec-sig))
net/uri-codec net/uri-codec-unit net/uri-codec-sig))
@(define uri-codec-eval (make-base-eval))
@interaction-eval[#:eval uri-codec-eval (require net/uri-codec)]

9
collects/net/scribblings/url.scrbl
View File

@ -1,11 +1,6 @@
#lang scribble/doc
@(require "common.ss"
scribble/bnf
(for-label net/url
net/url-unit
net/url-sig
net/head
net/uri-codec))
@(require "common.rkt" scribble/bnf
(for-label net/url net/url-unit net/url-sig net/head net/uri-codec))
@title[#:tag "url"]{URLs and HTTP}

7
collects/net/scribblings/websocket.scrbl
View File

@ -1,10 +1,7 @@
#lang scribble/doc
@(require "common.ss"
@(require "common.rkt"
scribble/bnf
(for-label net/url
unstable/contract
web-server/http
racket/list
(for-label net/url unstable/contract web-server/http racket/list
racket/async-channel
(prefix-in raw: (for-label net/tcp-unit))
net/websocket

4
collects/net/sendmail.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "sendmail-sig.ss" "sendmail-unit.ss")
#lang racket/base
(require racket/unit "sendmail-sig.rkt" "sendmail-unit.rkt")
(define-values/invoke-unit/infer sendmail@)

4
collects/net/sendurl.rkt
View File

@ -1,4 +1,4 @@
;; The main client of this module is browser/external.ss
;; The main client of this module is browser/external.rkt
;; (others just use the (send-url url [new?]) interface.)
#lang racket/base
@ -188,7 +188,7 @@
;; if it's a known browser, then it must be an existing one at this point
[(not exe) (error 'send-url "internal error")]
;; if it's gone throw an error (refiltering will break assumptions of
;; browser/external.ss, and we really mimic the Win/Mac case where there
;; browser/external.rkt, and we really mimic the Win/Mac case where there
;; should be some builtin facility that doesn't change)
[(not (file-exists? exe)) (error 'send-url "executable vanished: ~a" exe)]
;; finally, deal with the actual browser process

4
collects/net/smtp.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/unit "smtp-sig.ss" "smtp-unit.ss")
#lang racket/base
(require racket/unit "smtp-sig.rkt" "smtp-unit.rkt")
(define-values/invoke-unit/infer smtp@)

9
collects/net/ssl-tcp-unit.rkt
View File

@ -1,11 +1,10 @@
#lang scheme/base
#lang racket/base
(provide make-ssl-tcp@)
(require scheme/unit
"tcp-sig.ss"
openssl/mzssl)
(require racket/unit "tcp-sig.rkt" openssl/mzssl)
(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)
(unit
(import)

9
collects/net/tcp-redirect.rkt
View File

@ -1,10 +1,7 @@
#lang scheme/base
#lang racket/base
(provide tcp-redirect)
(require scheme/unit
scheme/tcp
scheme/async-channel
"tcp-sig.ss")
(require racket/unit racket/tcp racket/async-channel "tcp-sig.rkt")
(define raw:tcp-abandon-port tcp-abandon-port)
(define raw:tcp-accept tcp-accept)
@ -46,7 +43,7 @@
(define (tcp-accept/enable-break tcp-listener)
(cond
[(pipe-listener? tcp-listener)
;; XXX put this into async-channel.ss as async-channel-get/enable-break
;; XXX put this into async-channel.rkt as async-channel-get/enable-break
(sync/enable-break
(handle-evt
(pipe-listener-channel tcp-listener)

2
collects/net/tcp-sig.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/signature
#lang racket/signature
tcp-abandon-port
tcp-accept

4
collects/net/tcp-unit.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(provide tcp@)
(require scheme/unit scheme/tcp "tcp-sig.ss")
(require racket/unit racket/tcp "tcp-sig.rkt")
(define-unit-from-context tcp@ tcp^)

26
collects/net/unihead.rkt
View File

@ -1,11 +1,7 @@
#lang mzscheme
(require net/base64
net/qp
mzlib/string)
#lang racket/base
(require net/base64 net/qp racket/string)
(provide encode-for-header
decode-for-header
generalize-encoding)
(provide encode-for-header decode-for-header generalize-encoding)
(define re:ascii #rx"^[\u0-\u7F]*$")
@ -51,23 +47,17 @@
;; ----------------------------------------
(define re:us-ascii #rx#"^(?i:us-ascii)$")
(define re:iso #rx#"^(?i:iso-8859-1)$")
(define re:gb #rx#"^(?i:gb(?:2312)?)$")
(define re:ks_c #rx#"^(?i:ks_c_5601-1987)$")
(define re:utf-8 #rx#"^(?i:utf-8)$")
(define re:encoded #rx#"^(.*?)=[?]([^?]+)[?]([qQbB])[?](.*?)[?]=(.*)$")
(define (generalize-encoding encoding)
;; Treat Latin-1 as Windows-1252 and also threat GB and GB2312
;; as GBK, because some mailers are broken.
(cond [(or (regexp-match? re:iso encoding)
(regexp-match? re:us-ascii encoding))
(cond [(or (regexp-match? #rx#"^(?i:iso-8859-1)$" encoding)
(regexp-match? #rx#"^(?i:us-ascii)$" encoding))
(if (bytes? encoding) #"WINDOWS-1252" "WINDOWS-1252")]
[(regexp-match? re:gb encoding)
[(regexp-match? #rx#"^(?i:gb(?:2312)?)$" encoding)
(if (bytes? encoding) #"GBK" "GBK")]
[(regexp-match? re:ks_c encoding)
[(regexp-match? #rx#"^(?i:ks_c_5601-1987)$" encoding)
(if (bytes? encoding) #"CP949" "CP949")]
[else encoding]))
@ -88,7 +78,7 @@
(decode-for-header (bytes->string/latin-1 (cadr m)))
(let ([encoding (generalize-encoding encoding)])
(cond
[(regexp-match? re:utf-8 encoding)
[(regexp-match? #rx#"^(?i:utf-8)$" encoding)
(bytes->string/utf-8 s #\?)]
[else (let ([c (bytes-open-converter
(bytes->string/latin-1 encoding)