Syncerating the countryside
Syncerating the peasants Syncerating all the peoples in the thatched-roof COTTAGES! THATCHED-ROOF COTTAGES! svn: r12578
This commit is contained in:
Stevie Strickland
commit
702c1b7af2
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "21nov2008")
|
||||
#lang scheme/base (provide stamp) (define stamp "24nov2008")
|
||||
|
|
|
|||
|
|
@ -32,21 +32,7 @@
|
|||
s)))))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Regexp helpers
|
||||
|
||||
(define (bstring-length s)
|
||||
(if (bytes? s) (bytes-length s) (string-length s)))
|
||||
|
||||
(define (bstring->regexp name pattern)
|
||||
(cond [(regexp? pattern) pattern]
|
||||
[(byte-regexp? pattern) pattern]
|
||||
[(string? pattern) (regexp pattern)]
|
||||
[(bytes? pattern) (byte-regexp pattern)]
|
||||
[else (raise-type-error
|
||||
name "regexp, byte regexp, string, or byte string" pattern)]))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Regexp helpers
|
||||
;; Regexp utilities
|
||||
|
||||
(define regexp-quote-chars:s #rx"[][.*?+|(){}\\$^]")
|
||||
(define regexp-quote-chars:b #rx#"[][.*?+|(){}\\$^]")
|
||||
|
|
@ -69,6 +55,34 @@
|
|||
[else (raise-type-error 'regexp-replace-quote
|
||||
"string or byte string" s)]))
|
||||
|
||||
(define (make-regexp-tweaker tweaker)
|
||||
(let ([t (make-weak-hasheq)])
|
||||
(lambda (rx)
|
||||
(define-syntax-rule (->str x) (if (bytes? x) (bytes->string/utf-8 x) x))
|
||||
(define-syntax-rule (->bts x) (if (bytes? x) x (string->bytes/utf-8 x)))
|
||||
(define-syntax-rule (tweak unwrap wrap convert)
|
||||
(let ([tweaked (tweaker (unwrap rx))])
|
||||
;; the tweaker is allowed to return a regexp
|
||||
(if (or (regexp? tweaked) (byte-regexp? tweaked))
|
||||
tweaked
|
||||
(wrap (convert tweaked)))))
|
||||
(define (run-tweak)
|
||||
(cond [(pregexp? rx) (tweak object-name pregexp ->str)]
|
||||
[(regexp? rx) (tweak object-name regexp ->str)]
|
||||
[(byte-pregexp? rx) (tweak object-name byte-pregexp ->bts)]
|
||||
[(byte-regexp? rx) (tweak object-name byte-regexp ->bts)]
|
||||
;; allow getting a string, so if someone needs to go
|
||||
;; from a string to a regexp, there's no penalty
|
||||
;; because of the intermediate regexp being recreated
|
||||
[(string? rx) (tweak (lambda (x) x) regexp ->str)]
|
||||
[(bytes? rx) (tweak (lambda (x) x) byte-regexp ->bts)]
|
||||
[else (raise-type-error
|
||||
'regexp-tweaker
|
||||
"regexp, byte regexp, string, or byte string"
|
||||
rx)]))
|
||||
(or (hash-ref t rx #f)
|
||||
(let ([rx* (run-tweak)]) (hash-set! t rx rx*) rx*)))))
|
||||
|
||||
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f])
|
||||
(unless (input-port? input-port)
|
||||
(raise-type-error 'regexp-try-match
|
||||
|
|
@ -91,156 +105,111 @@
|
|||
(and p (subbytes s (- (car p) drop) (- (cdr p) drop))))
|
||||
(cdr m))))))))
|
||||
|
||||
;; Helper macro for the regexp functions below.
|
||||
(define-syntax regexp-loop
|
||||
(syntax-rules ()
|
||||
[(regexp-loop name loop start end rx string
|
||||
success-choose failure-k
|
||||
port-success-k port-success-choose port-failure-k
|
||||
need-leftover? peek?)
|
||||
(let ([len (cond [(string? string) (string-length string)]
|
||||
[(bytes? string) (bytes-length string)]
|
||||
[else #f])])
|
||||
(if peek?
|
||||
(unless (input-port? string)
|
||||
(raise-type-error 'name "input port" string))
|
||||
(unless (or len (input-port? string))
|
||||
(raise-type-error
|
||||
'name "string, byte string or input port" string)))
|
||||
(unless (and (number? start) (exact? start) (integer? start)
|
||||
(start . >= . 0))
|
||||
(raise-type-error 'name "non-negative exact integer" start))
|
||||
(unless (or (not end)
|
||||
(and (number? end) (exact? end) (integer? end)
|
||||
(end . >= . 0)))
|
||||
(raise-type-error 'name "non-negative exact integer or false" end))
|
||||
(unless (or (input-port? string) (and len (start . <= . len)))
|
||||
(raise-mismatch-error
|
||||
'name
|
||||
(format "starting offset index out of range [0,~a]: " len)
|
||||
start))
|
||||
(unless (or (not end)
|
||||
(and (start . <= . end)
|
||||
(or (input-port? string)
|
||||
(and len (end . <= . len)))))
|
||||
(raise-mismatch-error
|
||||
'name
|
||||
(format "ending offset index out of range [~a,~a]: " start len)
|
||||
end))
|
||||
(reverse
|
||||
(let loop ([acc '()] [start start] [end end])
|
||||
;; Helper macro for the regexp functions below, with some utilities.
|
||||
(define (bstring-length s)
|
||||
(if (bytes? s) (bytes-length s) (string-length s)))
|
||||
(define no-empty-edge-matches
|
||||
(make-regexp-tweaker (lambda (rx) (format "(?=.)(?:~a)(?<=.)" rx))))
|
||||
(define (bstring->no-edge-regexp name pattern)
|
||||
(if (or (regexp? pattern) (byte-regexp? pattern)
|
||||
(string? pattern) (bytes? pattern))
|
||||
(no-empty-edge-matches pattern)
|
||||
(raise-type-error
|
||||
name "regexp, byte regexp, string, or byte string" pattern)))
|
||||
(define-syntax-rule (regexp-loop
|
||||
name loop start end rx string
|
||||
success-choose failure-k
|
||||
port-success-k port-success-choose port-failure-k
|
||||
need-leftover? peek?)
|
||||
(let ([len (cond [(string? string) (string-length string)]
|
||||
[(bytes? string) (bytes-length string)]
|
||||
[else #f])])
|
||||
(if peek?
|
||||
(unless (input-port? string)
|
||||
(raise-type-error 'name "input port" string))
|
||||
(unless (or len (input-port? string))
|
||||
(raise-type-error
|
||||
'name "string, byte string or input port" string)))
|
||||
(unless (and (number? start) (exact? start) (integer? start)
|
||||
(start . >= . 0))
|
||||
(raise-type-error 'name "non-negative exact integer" start))
|
||||
(unless (or (not end)
|
||||
(and (number? end) (exact? end) (integer? end)
|
||||
(end . >= . 0)))
|
||||
(raise-type-error 'name "non-negative exact integer or false" end))
|
||||
(unless (or (input-port? string) (and len (start . <= . len)))
|
||||
(raise-mismatch-error
|
||||
'name
|
||||
(format "starting offset index out of range [0,~a]: " len)
|
||||
start))
|
||||
(unless (or (not end)
|
||||
(and (start . <= . end)
|
||||
(or (input-port? string) (and len (end . <= . len)))))
|
||||
(raise-mismatch-error
|
||||
'name
|
||||
(format "ending offset index out of range [~a,~a]: " start len)
|
||||
end))
|
||||
(reverse
|
||||
(let loop ([acc '()] [start start] [end end])
|
||||
|
||||
(if (and port-success-choose (input-port? string))
|
||||
(if (and port-success-choose (input-port? string))
|
||||
|
||||
;; Input port match, get string
|
||||
(let* ([_ (when (positive? start)
|
||||
;; Skip start chars:
|
||||
(let ([s (make-bytes 4096)])
|
||||
(let loop ([n 0])
|
||||
(unless (= n start)
|
||||
(let ([m (read-bytes-avail!
|
||||
s string 0 (min (- start n) 4096))])
|
||||
(unless (eof-object? m) (loop (+ n m))))))))]
|
||||
[discarded/leftovers (if need-leftover? #f 0)]
|
||||
[spitout (if need-leftover?
|
||||
(open-output-bytes)
|
||||
(make-output-port
|
||||
'counter always-evt
|
||||
(lambda (s start end flush? breakable?)
|
||||
(let ([c (- end start)])
|
||||
(set! discarded/leftovers
|
||||
(+ c discarded/leftovers))
|
||||
c))
|
||||
void))]
|
||||
[end (and end (- end start))]
|
||||
[m (regexp-match rx string 0 end spitout)]
|
||||
;; re-match if we get a zero-length match at the
|
||||
;; beginning
|
||||
[m (if (and m ; we have a match
|
||||
;; and it's an empty one
|
||||
(zero? (bstring-length (car m)))
|
||||
;; and it's at the beginning
|
||||
(zero? (if need-leftover?
|
||||
(file-position spitout)
|
||||
discarded/leftovers))
|
||||
;; and we still have stuff to match
|
||||
(if end
|
||||
(< 0 end)
|
||||
(not (eof-object? (peek-byte string)))))
|
||||
(regexp-match rx string 1 end spitout)
|
||||
m)]
|
||||
[m (and m (car m))]
|
||||
[discarded/leftovers (if need-leftover?
|
||||
(get-output-bytes spitout)
|
||||
discarded/leftovers)]
|
||||
[end (and end m
|
||||
(- end (if need-leftover?
|
||||
(bstring-length discarded/leftovers)
|
||||
discarded/leftovers)
|
||||
(bstring-length m)))])
|
||||
;; drop matches that are both empty and at the end
|
||||
(if (and m (or (< 0 (bstring-length m))
|
||||
(if end
|
||||
(< 0 end)
|
||||
(not (eof-object? (peek-byte string))))))
|
||||
(loop (cons (port-success-choose m discarded/leftovers) acc)
|
||||
0 end)
|
||||
(port-failure-k acc discarded/leftovers)))
|
||||
;; Input port match, get string
|
||||
(let* ([_ (when (positive? start)
|
||||
;; Skip start chars:
|
||||
(let ([s (make-bytes 4096)])
|
||||
(let loop ([n 0])
|
||||
(unless (= n start)
|
||||
(let ([m (read-bytes-avail!
|
||||
s string 0 (min (- start n) 4096))])
|
||||
(unless (eof-object? m) (loop (+ n m))))))))]
|
||||
[discarded/leftovers (if need-leftover? #f 0)]
|
||||
[spitout (if need-leftover?
|
||||
(open-output-bytes)
|
||||
(make-output-port
|
||||
'counter always-evt
|
||||
(lambda (s start end flush? breakable?)
|
||||
(let ([c (- end start)])
|
||||
(set! discarded/leftovers
|
||||
(+ c discarded/leftovers))
|
||||
c))
|
||||
void))]
|
||||
[end (and end (- end start))]
|
||||
[m (regexp-match rx string 0 end spitout)]
|
||||
[m (and m (car m))]
|
||||
[discarded/leftovers (if need-leftover?
|
||||
(get-output-bytes spitout)
|
||||
discarded/leftovers)]
|
||||
[end (and end m
|
||||
(- end (if need-leftover?
|
||||
(bstring-length discarded/leftovers)
|
||||
discarded/leftovers)
|
||||
(bstring-length m)))])
|
||||
(if m
|
||||
(loop (cons (port-success-choose m discarded/leftovers) acc)
|
||||
0 end)
|
||||
(port-failure-k acc discarded/leftovers)))
|
||||
|
||||
;; String/port match, get positions
|
||||
(let* ([match (if peek?
|
||||
regexp-match-peek-positions
|
||||
regexp-match-positions)]
|
||||
[m (match rx string start end)])
|
||||
(if (not m)
|
||||
(failure-k acc start end)
|
||||
(let* ([mstart (caar m)]
|
||||
[mend (cdar m)]
|
||||
;; re-match if we get a zero-length match at the
|
||||
;; beginning, and we can continue
|
||||
[m (if (and (= mstart mend start)
|
||||
(cond
|
||||
[end (< start end)]
|
||||
[len (< start len)]
|
||||
[(input-port? string)
|
||||
(not (eof-object? (peek-byte string)))]
|
||||
[else (error "internal error (str)")]))
|
||||
(if (or peek? (not (input-port? string)))
|
||||
(match rx string (add1 start) end)
|
||||
;; rematching on a port requires adding `start'
|
||||
;; offsets
|
||||
(let ([m (match rx string 1 end)])
|
||||
(if (and m (positive? start))
|
||||
(list (cons (+ start (caar m))
|
||||
(+ start (cdar m))))
|
||||
m)))
|
||||
m)])
|
||||
;; fail if rematch failed
|
||||
(if (not m)
|
||||
(failure-k acc start end)
|
||||
(let ([mstart (caar m)]
|
||||
[mend (cdar m)])
|
||||
;; or if we have a zero-length match at the end
|
||||
(if (and (= mstart mend)
|
||||
(cond [end (= mend end)]
|
||||
[len (= mend len)]
|
||||
[(input-port? string)
|
||||
(eof-object?
|
||||
(peek-byte string (if peek? mend 0)))]
|
||||
[else (error "internal error (str)")]))
|
||||
(failure-k acc start end)
|
||||
(if port-success-k
|
||||
(port-success-k
|
||||
(lambda (acc new-start new-end)
|
||||
(loop acc new-start new-end))
|
||||
acc start end mstart mend)
|
||||
(loop (cons (success-choose start mstart mend) acc)
|
||||
mend end))))))))))))]))
|
||||
;; String/port match, get positions
|
||||
(let ([m (if peek?
|
||||
(regexp-match-peek-positions rx string start end)
|
||||
(regexp-match-positions rx string start end))])
|
||||
(if (not m)
|
||||
(failure-k acc start end)
|
||||
(let ([mstart (caar m)] [mend (cdar m)])
|
||||
(if port-success-k
|
||||
(port-success-k
|
||||
(lambda (acc new-start new-end)
|
||||
(loop acc new-start new-end))
|
||||
acc start end mstart mend)
|
||||
(loop (cons (success-choose start mstart mend) acc)
|
||||
mend end))))))))))
|
||||
|
||||
;; Returns all the positions at which the pattern matched.
|
||||
(define (regexp-match-positions* pattern string [start 0] [end #f])
|
||||
(define rx (bstring->regexp 'regexp-match-positions* pattern))
|
||||
(regexp-loop regexp-match-positions* loop start end rx string
|
||||
(regexp-loop
|
||||
regexp-match-positions* loop start end
|
||||
(bstring->no-edge-regexp 'regexp-match-positions* pattern) string
|
||||
;; success-choose:
|
||||
(lambda (start mstart mend) (cons mstart mend))
|
||||
;; failure-k:
|
||||
|
|
@ -262,8 +231,9 @@
|
|||
|
||||
;; Returns all the positions at which the pattern matched.
|
||||
(define (regexp-match-peek-positions* pattern string [start 0] [end #f])
|
||||
(define rx (bstring->regexp 'regexp-match-peek-positions* pattern))
|
||||
(regexp-loop regexp-match-peek-positions* loop start end rx string
|
||||
(regexp-loop
|
||||
regexp-match-peek-positions* loop start end
|
||||
(bstring->no-edge-regexp 'regexp-match-peek-positions* pattern) string
|
||||
;; success-choose:
|
||||
(lambda (start mstart mend) (cons mstart mend))
|
||||
;; failure-k:
|
||||
|
|
@ -278,7 +248,7 @@
|
|||
;; Splits a string into a list by removing any piece which matches
|
||||
;; the pattern.
|
||||
(define (regexp-split pattern string [start 0] [end #f])
|
||||
(define rx (bstring->regexp 'regexp-split pattern))
|
||||
(define rx (bstring->no-edge-regexp 'regexp-split pattern))
|
||||
(define buf (if (and (string? string) (byte-regexp? rx))
|
||||
(string->bytes/utf-8 string (char->integer #\?))
|
||||
string))
|
||||
|
|
@ -300,7 +270,7 @@
|
|||
|
||||
;; Returns all the matches for the pattern in the string.
|
||||
(define (regexp-match* pattern string [start 0] [end #f])
|
||||
(define rx (bstring->regexp 'regexp-match* pattern))
|
||||
(define rx (bstring->no-edge-regexp 'regexp-match* pattern))
|
||||
(define buf (if (and (string? string) (byte-regexp? rx))
|
||||
(string->bytes/utf-8 string (char->integer #\?))
|
||||
string))
|
||||
|
|
|
|||
|
|
@ -165,21 +165,19 @@ setup/infotab
|
|||
]
|
||||
then the same collection would be expected to contain a
|
||||
@File{tool.ss} file. It might contain something like this:
|
||||
@schemeblock[
|
||||
(module tool mzscheme
|
||||
(require (lib "tool.ss" "drscheme")
|
||||
mred
|
||||
mzlib/unit)
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define (phase1) (message-box "tool example" "phase1"))
|
||||
(define (phase2) (message-box "tool example" "phase2"))
|
||||
(message-box "tool example" "unit invoked"))))
|
||||
@schememod[
|
||||
scheme/gui
|
||||
(require drscheme/tool)
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(define tool@
|
||||
(unit
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define (phase1) (message-box "tool example" "phase1"))
|
||||
(define (phase2) (message-box "tool example" "phase2"))
|
||||
(message-box "tool example" "unit invoked")))
|
||||
]
|
||||
This tool just opens a few windows to indicate that it has
|
||||
been loaded and that the @scheme[phase1] and @scheme[phase2]
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@
|
|||
(define (->b x)
|
||||
(cond [(list? x) (map ->b x)]
|
||||
[(string? x) (string->bytes/utf-8 x)]
|
||||
[(pregexp? x) (byte-pregexp (->b (object-name x)))]
|
||||
[else x]))
|
||||
(define fun* #f)
|
||||
(define t
|
||||
|
|
@ -126,8 +127,8 @@
|
|||
(t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 #f)
|
||||
(t '((0 . 1) (2 . 3) (4 . 5)) "a b c" "[abc]" "a b c" 0 5)
|
||||
;; ---------- tests with zero-length matches ----------
|
||||
;; Many of these tests can be repeated with Perl. To try something
|
||||
;; in Perl, put this code in a file:
|
||||
;; Many of these tests can be repeated with Perl. To try something in Perl,
|
||||
;; put this code in a file:
|
||||
;; #!/usr/bin/perl
|
||||
;; sub test {
|
||||
;; my ($rx,$str) = @_; @words = split /$rx/, $str;
|
||||
|
|
@ -136,15 +137,16 @@
|
|||
;; print ") eof \"$rx\" \"$str\")\n";
|
||||
;; };
|
||||
;; test("[abc]","1a2b3");
|
||||
;; and it will print a test that does what perl is doing. Tests
|
||||
;; that differ from Perl have explanations.
|
||||
;; and it will print a test that does what perl is doing. Tests that differ
|
||||
;; from Perl have explanations.
|
||||
;;
|
||||
(t regexp-split)
|
||||
;; test("a","a");
|
||||
;; (t '() eof "a" "a")
|
||||
;; perl returns an empty list, we return '("" ""), and this is a
|
||||
;; difference that is unrelated to dealing with empty matches,
|
||||
;; just the way that perl's split throws out some empty matches.
|
||||
;; perl returns an empty list, we return '("" ""), and this is a difference
|
||||
;; that is unrelated to dealing with empty matches, just the way that
|
||||
;; perl's split throws out some empty matches (it throws empty matches at
|
||||
;; the end (but not at the beginning for some reason...))
|
||||
(t '("" "") eof "a" "a")
|
||||
;; test("3","123");
|
||||
;; (t '("12") eof "3" "123")
|
||||
|
|
@ -162,49 +164,51 @@
|
|||
(t '("1" "2" "3" "4") eof " *" "12 34")
|
||||
;; test(" *"," 12 34 ");
|
||||
;; (t '("" "1" "2" "3" "4") eof " *" " 12 34 ")
|
||||
;; perl drops the last empty string, we don't -- unrelated to
|
||||
;; empty matches (same as the <"a","a"> case above)
|
||||
;; again, perl drops the last empty string but we don't
|
||||
(t '("" "1" "2" "3" "4" "") eof " *" " 12 34 ")
|
||||
;; test("2|", "1234");
|
||||
(t '("1" "3" "4") eof "2|" "1234")
|
||||
;; test("1|", "1234");
|
||||
(t '("" "2" "3" "4") eof "1|" "1234")
|
||||
;; test("4|", "1234");
|
||||
;; perl drops the last empty string, we don't, same as above
|
||||
;; (t '("1" "2" "3") eof "4|" "1234")
|
||||
;; perl perl drops the last empty string again
|
||||
(t '("1" "2" "3" "") eof "4|" "1234")
|
||||
;; test("|2", "1234");
|
||||
;; (t '("1" "" "3" "4") eof "|2" "1234")
|
||||
;; perl will find the "2", we can't do that since we'll always
|
||||
;; find the empty match first, so it's just like using "" (to do
|
||||
;; the perl thing, we'll need a hook into the matcher's C code, or
|
||||
;; some way of saying `match this pattern but prefer a non-empty
|
||||
;; match if possible')
|
||||
(t '("1" "2" "3" "4") eof "|2" "1234")
|
||||
(t '("1" "" "3" "4") eof "|2" "1234")
|
||||
;; test("2|3", "1234");
|
||||
(t '("1" "" "4") eof "2|3" "1234")
|
||||
;; test("2|3|4", "12345");
|
||||
(t '("1" "" "" "5") eof "2|3|4" "12345")
|
||||
;; test("1|2", "1234");
|
||||
(t '("" "" "34") eof "1|2" "1234")
|
||||
;; test("3|4", "1234");
|
||||
;; (t '("12") eof "3|4" "1234")
|
||||
;; again, perl dumps empty matches at the end, even two
|
||||
;; perl perl drops the last empty string again -- even two here
|
||||
(t '("12" "" "") eof "3|4" "1234")
|
||||
;; test("2|3|4", "1234");
|
||||
;; (t '("1") eof "2|3|4" "1234")
|
||||
;; ...and even three in this example
|
||||
(t '("1" "" "" "") eof "2|3|4" "1234")
|
||||
;; test('$',"123");
|
||||
(t '("123") eof "$" "123")
|
||||
;; test('^',"123");
|
||||
;; (t '("123") eof "^" "123")
|
||||
;; this is a technicality: perl matches "^" once, but mzscheme
|
||||
;; matches on whatever `start' may be; perl is treating it as a
|
||||
;; beginning-of-line instead of a ...-of-string behind your back
|
||||
;; "since it isn't much use otherwise"
|
||||
;; (http://perldoc.perl.org/functions/split.html); so our correct
|
||||
;; test is:
|
||||
(t '("1" "2" "3") eof "^" "123")
|
||||
;; and we can get the same with "(m?:^)":
|
||||
(t '("123") eof "(m?:^)" "123")
|
||||
;; this is a technicality: perl matches "^" once, but mzscheme matches on
|
||||
;; whatever `start' may be; perl is treating it as a beginning-of-line
|
||||
;; instead of a beginning-of-string behind your back "since it isn't much
|
||||
;; use otherwise" (http://perldoc.perl.org/functions/split.html); but we
|
||||
;; don't allow empty matches at the beginning, so a `^' will never match,
|
||||
;; and we get the same behavior anyway:
|
||||
(t '("123") eof "^" "123")
|
||||
;; test('^',"123\n456");
|
||||
;; (t '("123\n" "456") eof "^" "123\n456")
|
||||
;; we can get the same behavior as perl's with "(m?:^)":
|
||||
(t '("123\n" "456") eof "(?m:^)" "123\n456")
|
||||
;; test("\\b", "123 456");
|
||||
(t '("123" " " "456") eof #px"\\b" "123 456")
|
||||
;; test("^|a", "abc");
|
||||
;; (t '("" "bc") eof "^|a" "abc")
|
||||
;; same deal here, use "(m?:^)":
|
||||
(t '("" "bc") eof "(m?:^|a)" "abc")
|
||||
(t '("" "bc") eof "^|a" "abc")
|
||||
;; some tests with bounds (these have no perl equivalences)
|
||||
(t '("1" "2" " " "3" "4") eof "" "12 34" 0)
|
||||
(t '("1" "2" " " "3" "4") eof "" "12 34" 0 #f)
|
||||
|
|
@ -244,12 +248,13 @@
|
|||
(apply (if (string? (car s)) string-append bytes-append)
|
||||
(car s)
|
||||
(append-map list m (cdr s)))))))
|
||||
(t "12 34" #f " " "12 34")
|
||||
(t "12 34" #f " " "12 34")
|
||||
(t " 12 34 " #f " " " 12 34 ")
|
||||
(t "12 34" #f " *" "12 34")
|
||||
(t "12 34" #f " *" "12 34")
|
||||
(t " 12 34 " #f " *" " 12 34 ")
|
||||
(t "12 34" #f "" "12 34")
|
||||
(t " 12 34 " #f "" " 12 34 "))
|
||||
(t "12 34" #f "" "12 34")
|
||||
(t " 12 34 " #f "" " 12 34 ")
|
||||
)
|
||||
|
||||
;; ---------- string-append* ----------
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
[read-range-header (-> (listof header?) (or/c (listof pair?) false/c))]
|
||||
[make
|
||||
(->* (#:url->path url->path/c)
|
||||
(#:path->mime-type (path? . -> . bytes?)
|
||||
(#:path->mime-type (path-string? . -> . bytes?)
|
||||
#:indices (listof path-string?))
|
||||
dispatcher/c)])
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@
|
|||
[make-basic-denied?/path
|
||||
(authorized?/c . -> . denied?/c)]
|
||||
[password-file->authorized?
|
||||
(path? . -> . (values (-> void)
|
||||
(path-string? . -> . (values (-> void)
|
||||
authorized?/c))])
|
||||
|
||||
(define interface-version 'v1)
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
|
||||
(provide/contract
|
||||
[url->path/c contract?]
|
||||
[make-url->path (path? . -> . url->path/c)]
|
||||
[make-url->path (path-string? . -> . url->path/c)]
|
||||
[make-url->valid-path (url->path/c . -> . url->path/c)]
|
||||
[filter-url->path (regexp? url->path/c . -> . url->path/c)])
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
(provide/contract
|
||||
[rename ext:output-response output-response (connection? response? . -> . void)]
|
||||
[rename ext:output-response/method output-response/method (connection? response? symbol? . -> . void)]
|
||||
[rename ext:output-file output-file (connection? path? symbol? bytes? (or/c pair? false/c) . -> . void)])
|
||||
[rename ext:output-file output-file (connection? path-string? symbol? bytes? (or/c pair? false/c) . -> . void)])
|
||||
|
||||
;; Table 1. head responses:
|
||||
; ------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -15,10 +15,7 @@
|
|||
(provide/contract
|
||||
[static-files-path (path-string? . -> . void?)])
|
||||
(define (static-files-path path)
|
||||
(set! extra-files-path
|
||||
(if (path? path)
|
||||
path
|
||||
(string->path path))))
|
||||
(set! extra-files-path path))
|
||||
|
||||
(provide/contract
|
||||
[no-web-browser (-> void)])
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@
|
|||
|
||||
(provide/contract
|
||||
[file-box? (any/c . -> . boolean?)]
|
||||
[file-box (path? serializable? . -> . file-box?)]
|
||||
[file-box (path-string? serializable? . -> . file-box?)]
|
||||
[file-unbox (file-box? . -> . serializable?)]
|
||||
[file-box-set? (file-box? . -> . boolean?)]
|
||||
[file-box-set! (file-box? serializable? . -> . void)])
|
||||
|
|
|
|||
|
|
@ -742,7 +742,7 @@
|
|||
[copy-conf
|
||||
(lambda (from to)
|
||||
(let ([to-path (build-path-unless-absolute conf to)])
|
||||
; more here - check existance of from path?
|
||||
; more here - check existance of from path
|
||||
(copy-file* (build-path from-conf from) to-path)))])
|
||||
(copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages))
|
||||
(copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(require file/md5)
|
||||
|
||||
(provide/contract
|
||||
[md5-home (parameter/c path?)]
|
||||
[md5-home (parameter/c path-string?)]
|
||||
[md5-store (bytes? . -> . bytes?)]
|
||||
[md5-lookup (bytes? . -> . bytes?)])
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@
|
|||
([custodian custodian?]
|
||||
[namespace namespace?]
|
||||
[manager manager?]
|
||||
[directory path?]
|
||||
[directory path-string?]
|
||||
[handler (request? . -> . response?)])]
|
||||
[struct execution-context
|
||||
([request request?])]
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
xml/xml
|
||||
net/url)
|
||||
(define path-element?
|
||||
(or/c string? path? (symbols 'up 'same)))
|
||||
(or/c path-string? (symbols 'up 'same)))
|
||||
|
||||
(define port-number? (between/c 1 65535))
|
||||
|
||||
|
|
@ -16,13 +16,13 @@
|
|||
[port-number? contract?]
|
||||
[pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)]
|
||||
[url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)]
|
||||
[explode-path* (path? . -> . (listof path-element?))]
|
||||
[path-without-base (path? path? . -> . (listof path-element?))]
|
||||
[explode-path* (path-string? . -> . (listof path-element?))]
|
||||
[path-without-base (path-string? path-string? . -> . (listof path-element?))]
|
||||
[list-prefix? (list? list? . -> . boolean?)]
|
||||
[strip-prefix-ups ((listof path-element?) . -> . (listof path-element?))]
|
||||
[url-path->string ((listof path/param?) . -> . string?)]
|
||||
[network-error ((symbol? string?) (listof any/c) . ->* . (void))]
|
||||
[directory-part (path? . -> . path?)]
|
||||
[directory-part (path-string? . -> . path?)]
|
||||
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
|
||||
[exn->string ((or/c exn? any/c) . -> . string?)]
|
||||
[build-path-unless-absolute (path-string? path-string? . -> . path?)]
|
||||
|
|
|
|||
|
|
@ -99,7 +99,7 @@ URLs to paths on the filesystem.
|
|||
The returned @scheme[path?] is the path on disk. The list is the list of
|
||||
path elements that correspond to the path of the URL.}
|
||||
|
||||
@defproc[(make-url->path (base path?))
|
||||
@defproc[(make-url->path (base path-string?))
|
||||
url->path/c]{
|
||||
The @scheme[url-path/c] returned by this procedure considers the root
|
||||
URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL
|
||||
|
|
|
|||
|
|
@ -181,6 +181,13 @@ provides the unit that actually implements a dispatching server.
|
|||
|
||||
}
|
||||
|
||||
@subsection{Threads and Custodians}
|
||||
|
||||
The dispatching server runs in a dedicated thread. Every time a connection is initiated, a new thread is started to handle it.
|
||||
Connection threads are created inside a dedicated custodian that is a child of the server's custodian. When the server is used to
|
||||
provide servlets, each servlet also receives a new custodian that is a child of the server's custodian @bold{not} the connection
|
||||
custodian.
|
||||
|
||||
@; ------------------------------------------------------------
|
||||
@section[#:tag "closure.ss"]{Serializable Closures}
|
||||
@(require (for-label web-server/private/closure)
|
||||
|
|
@ -293,13 +300,13 @@ functions.
|
|||
@filepath{private/mime-types.ss} provides function for dealing with @filepath{mime.types}
|
||||
files.
|
||||
|
||||
@defproc[(read-mime-types [p path?])
|
||||
@defproc[(read-mime-types [p path-string?])
|
||||
(hash-table/c symbol? bytes?)]{
|
||||
Reads the @filepath{mime.types} file from @scheme[p] and constructs a
|
||||
hash table mapping extensions to MIME types.
|
||||
}
|
||||
|
||||
@defproc[(make-path->mime-type [p path?])
|
||||
@defproc[(make-path->mime-type [p path-string?])
|
||||
(path? . -> . bytes?)]{
|
||||
Uses a @scheme[read-mime-types] with @scheme[p] and constructs a
|
||||
function from paths to their MIME type.
|
||||
|
|
@ -371,7 +378,7 @@ needs. They are provided by @filepath{private/util.ss}.
|
|||
|
||||
@subsection{Contracts}
|
||||
@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].}
|
||||
@defthing[path-element? contract?]{Equivalent to @scheme[(or/c string? path? (symbols 'up 'same))].}
|
||||
@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].}
|
||||
|
||||
@subsection{Lists}
|
||||
@defproc[(list-prefix? [l list?]
|
||||
|
|
@ -395,19 +402,19 @@ needs. They are provided by @filepath{private/util.ss}.
|
|||
}
|
||||
|
||||
@subsection{Paths}
|
||||
@defproc[(explode-path* [p path?])
|
||||
@defproc[(explode-path* [p path-string?])
|
||||
(listof path-element?)]{
|
||||
Like @scheme[normalize-path], but does not resolve symlinks.
|
||||
}
|
||||
|
||||
@defproc[(path-without-base [base path?]
|
||||
[p path?])
|
||||
@defproc[(path-without-base [base path-string?]
|
||||
[p path-string?])
|
||||
(listof path-element?)]{
|
||||
Returns, as a list, the portion of @scheme[p] after @scheme[base],
|
||||
assuming @scheme[base] is a prefix of @scheme[p].
|
||||
}
|
||||
|
||||
@defproc[(directory-part [p path?])
|
||||
@defproc[(directory-part [p path-string?])
|
||||
path?]{
|
||||
Returns the directory part of @scheme[p], returning @scheme[(current-directory)]
|
||||
if it is relative.
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ The following API is provided to customize the server instance:
|
|||
@onscreen["Run"].
|
||||
}
|
||||
|
||||
@defproc[(static-files-path [path path?]) void]{
|
||||
@defproc[(static-files-path [path path-string?]) void]{
|
||||
This instructs the Web server to serve static files, such as stylesheet and images, from @scheme[path].
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -98,10 +98,10 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
|
|||
[#:stateless? stateless? boolean? #f]
|
||||
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
|
||||
[#:servlet-namespace servlet-namespace (listof module-path?) empty]
|
||||
[#:server-root-path server-root-path path? default-server-root-path]
|
||||
[#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))]
|
||||
[#:servlets-root servlets-root path? (build-path server-root-path "htdocs")]
|
||||
[#:servlet-current-directory servlet-current-directory path? servlets-root]
|
||||
[#:server-root-path server-root-path path-string? default-server-root-path]
|
||||
[#:extra-files-paths extra-files-paths (listof path-string?) (list (build-path server-root-path "htdocs"))]
|
||||
[#:servlets-root servlets-root path-string? (build-path server-root-path "htdocs")]
|
||||
[#:servlet-current-directory servlet-current-directory path-string? servlets-root]
|
||||
[#:file-not-found-responder file-not-found-responder
|
||||
(request? . -> . response?)
|
||||
(gen-file-not-found-responder
|
||||
|
|
@ -109,9 +109,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
|
|||
server-root-path
|
||||
"conf"
|
||||
"not-found.html"))]
|
||||
[#:mime-types-path mime-types-path path?
|
||||
...]
|
||||
[#:log-file log-file path? #f]
|
||||
[#:mime-types-path mime-types-path path-string?
|
||||
....]
|
||||
[#:log-file log-file (or/c false/c path-string?) #f]
|
||||
[#:log-format log-format symbol? 'apache-default])
|
||||
void]{
|
||||
This sets up and starts a fairly default server instance.
|
||||
|
|
|
|||
|
|
@ -12,21 +12,21 @@
|
|||
|
||||
This module is used internally to build and load servlets. It may be useful to those who are trying to extend the server.
|
||||
|
||||
@defproc[(make-v1.servlet [directory path?]
|
||||
@defproc[(make-v1.servlet [directory path-string?]
|
||||
[timeout integer?]
|
||||
[start (request? . -> . response?)])
|
||||
servlet?]{
|
||||
Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler.
|
||||
}
|
||||
|
||||
@defproc[(make-v2.servlet [directory path?]
|
||||
@defproc[(make-v2.servlet [directory path-string?]
|
||||
[manager manager?]
|
||||
[start (request? . -> . response?)])
|
||||
servlet?]{
|
||||
Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler.
|
||||
}
|
||||
|
||||
@defproc[(make-stateless.servlet [directory path?]
|
||||
@defproc[(make-stateless.servlet [directory path-string?]
|
||||
[start (request? . -> . response?)])
|
||||
servlet?]{
|
||||
Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler.
|
||||
|
|
@ -62,7 +62,7 @@ Equivalent to @scheme[(path? . -> . servlet?)].
|
|||
@defstruct[servlet ([custodian custodian?]
|
||||
[namespace namespace?]
|
||||
[manager manager?]
|
||||
[directory path?]
|
||||
[directory path-string?]
|
||||
[handler (request? . -> . response?)])
|
||||
#:mutable]{
|
||||
Instances of this structure hold the necessary parts of a servlet:
|
||||
|
|
|
|||
|
|
@ -268,7 +268,7 @@ the template to be unescaped, then create a @scheme[cdata] structure:
|
|||
Expands into
|
||||
@schemeblock[
|
||||
(for/list ([x xs])
|
||||
(list e ...))
|
||||
(begin/text e ...))
|
||||
]
|
||||
|
||||
Template Example:
|
||||
|
|
@ -466,7 +466,7 @@ The code associated with these templates is very simple as well:
|
|||
|
||||
(define-struct post (title body comments))
|
||||
|
||||
(define posts ...)
|
||||
(define posts ....)
|
||||
|
||||
(define (template section body)
|
||||
(list TEXT/HTML-MIME-TYPE
|
||||
|
|
|
|||
|
|
@ -615,7 +615,7 @@ To do this, we set aside a path to store these files, and then tell
|
|||
the web server where that directory is. The function
|
||||
@scheme[static-files-path],
|
||||
|
||||
@defthing[static-files-path (path? -> void)]
|
||||
@defthing[static-files-path (path-string? -> void)]
|
||||
|
||||
tells the web server to look in the given path when it receives a URL
|
||||
that looks like a static resource request.
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ Provides contains the following identifiers.
|
|||
|
||||
@defmodule[web-server/web-config-unit]{
|
||||
|
||||
@defproc[(configuration-table->web-config@ [path path?]
|
||||
@defproc[(configuration-table->web-config@ [path path-string?]
|
||||
[#:port port (or/c false/c port-number?) #f]
|
||||
[#:listen-ip listen-ip (or/c false/c string?) #f]
|
||||
[#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)])
|
||||
|
|
@ -68,10 +68,12 @@ Provides contains the following identifiers.
|
|||
}
|
||||
|
||||
@defproc[(configuration-table-sexpr->web-config@ [sexpr list?]
|
||||
[#:web-server-root web-server-root path? (directory-part default-configuration-table-path)]
|
||||
[#:web-server-root web-server-root path-string?
|
||||
(directory-part default-configuration-table-path)]
|
||||
[#:port port (or/c false/c port-number?) #f]
|
||||
[#:listen-ip listen-ip (or/c false/c string?) #f]
|
||||
[#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c (make-make-servlet-namespace)])
|
||||
[#:make-servlet-namespace make-servlet-namespace make-servlet-namespace/c
|
||||
(make-make-servlet-namespace)])
|
||||
(unit? web-config^)]{
|
||||
Parses @scheme[sexpr] as a configuration-table and constructs a @scheme[web-config^] unit.
|
||||
}
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ functions of interest for the servlet developer.
|
|||
(lambda (req)
|
||||
`(html (head (title "Custom Expiration!"))))])
|
||||
(send/suspend
|
||||
...))
|
||||
....))
|
||||
]
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ boxes in a safe way.
|
|||
@defproc[(file-box? [v any/c])
|
||||
boolean?]{Checks if @scheme[v] is a file-box.}
|
||||
|
||||
@defproc[(file-box [p path?]
|
||||
@defproc[(file-box [p path-string?]
|
||||
[v serializable?])
|
||||
file-box?]{
|
||||
Creates a file-box that is stored at @scheme[p], with the default
|
||||
|
|
|
|||
|
|
@ -52,15 +52,15 @@
|
|||
#:ssl? boolean?
|
||||
#:manager manager?
|
||||
#:servlet-namespace (listof module-path?)
|
||||
#:server-root-path path?
|
||||
#:server-root-path path-string?
|
||||
#:stateless? boolean?
|
||||
#:extra-files-paths (listof path?)
|
||||
#:servlets-root path?
|
||||
#:extra-files-paths (listof path-string?)
|
||||
#:servlets-root path-string?
|
||||
#:file-not-found-responder (request? . -> . response?)
|
||||
#:mime-types-path path?
|
||||
#:mime-types-path path-string?
|
||||
#:servlet-path string?
|
||||
#:servlet-regexp regexp?
|
||||
#:log-file (or/c false/c path?))
|
||||
#:log-file (or/c false/c path-string?))
|
||||
. ->* .
|
||||
void)])
|
||||
|
||||
|
|
|
|||
|
|
@ -97,9 +97,9 @@
|
|||
servlet-module-specs
|
||||
lang-module-specs))
|
||||
(provide/contract
|
||||
[make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)]
|
||||
[make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)]
|
||||
[make-stateless.servlet (path? (request? . -> . response?) . -> . servlet?)]
|
||||
[make-v1.servlet (path-string? integer? (request? . -> . response?) . -> . servlet?)]
|
||||
[make-v2.servlet (path-string? manager? (request? . -> . response?) . -> . servlet?)]
|
||||
[make-stateless.servlet (path-string? (request? . -> . response?) . -> . servlet?)]
|
||||
[default-module-specs (listof module-path?)])
|
||||
|
||||
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
(syntax-rules ()
|
||||
[(_ x xs e ...)
|
||||
(for/list ([x xs])
|
||||
(list e ...))]))
|
||||
(begin/text e ...))]))
|
||||
|
||||
(provide include-template
|
||||
in)
|
||||
Loading…
Reference in New Issue
Block a user