Eli Barzilay
parent
e6fc4d4027
commit
c276d448fe
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
(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^)
|
||||
|
||||
|
|
|
|||
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
(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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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^)
|
||||
|
|
|
|||
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -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,164 +33,164 @@
|
|||
|
||||
(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!)
|
||||
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
|
||||
|
|
@ -208,13 +208,13 @@
|
|||
;; left-rotate-adjust!
|
||||
(lambda (t old-right)
|
||||
(set-tree-left-count! old-right (+ 1
|
||||
(tree-left-count old-right)
|
||||
(tree-left-count t))))
|
||||
(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)
|
||||
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -26,9 +26,7 @@
|
|||
;; 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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -28,77 +28,77 @@
|
|||
(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
|
||||
|
|
@ -122,22 +122,22 @@
|
|||
; 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)
|
||||
|
|
|
|||
|
|
@ -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@)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,62 +2,62 @@
|
|||
(provide make-ssl-tcp@)
|
||||
(require (lib "unit.ss")
|
||||
"tcp-sig.ss"
|
||||
(lib "mzssl.ss" "openssl")
|
||||
(lib "etc.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)
|
||||
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^)
|
||||
(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))
|
||||
(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))
|
||||
|
||||
(define (tcp-abandon-port p)
|
||||
(if (input-port? p)
|
||||
(close-input-port p)
|
||||
(close-output-port p)))
|
||||
(define (tcp-abandon-port p)
|
||||
(if (input-port? p)
|
||||
(close-input-port p)
|
||||
(close-output-port p)))
|
||||
|
||||
(define tcp-accept ssl-accept)
|
||||
(define tcp-accept/enable-break ssl-accept/enable-break)
|
||||
(define tcp-accept ssl-accept)
|
||||
(define tcp-accept/enable-break ssl-accept/enable-break)
|
||||
|
||||
;; accept-ready? doesn't really work for SSL:
|
||||
(define (tcp-accept-ready? p)
|
||||
#f)
|
||||
;; accept-ready? doesn't really work for SSL:
|
||||
(define (tcp-accept-ready? p)
|
||||
#f)
|
||||
|
||||
(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-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-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?))))
|
||||
(define tcp-listener? ssl-listener?))))
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -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^))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user