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

change -q to config option, fix unlikely race condition in wake-on-signal, add path->url and url->path, and adjust URL parsing

Browse Source 
svn: r9239
This commit is contained in:
Matthew Flatt 2008-04-10 19:05:35 +00:00
parent 6c4ab3dad7
commit 0153e122b7
18 changed files with 331 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/drscheme/syncheck.ss
View File

@ -2399,11 +2399,18 @@ If the namespace does not, they are colored the unbound color.
(label (fw:gui-utils:format-literal-label (string-constant cs-view-docs) (exported-index-desc-name (entry-desc index-entry))))
(callback
(λ (x y)
(send-url (format "file://~a~a"
(path->string path)
(if tag
(string-append "#" (uri-encode tag))
""))))))))))))))))))))))
(let* ([url (path->url path)]
[url2 (if tag
(make-url (url-scheme url)
(url-user url)
(url-host url)
(url-port url)
(url-path-absolute? url)
(url-path url)
(url-query url)
tag)
url)])
(send-url (url->string url2))))))))))))))))))))))

1
collects/games/crazy8s/info.ss
View File

@ -1,4 +1,5 @@
#lang setup/infotab
(define name "Crazy 8s")
(define game "crazy8s.ss")
(define game-set "Card Games")

1
collects/games/ginrummy/info.ss
View File

@ -1,4 +1,5 @@
#lang setup/infotab
(define name "Rummy")
(define game "ginrummy.ss")
(define game-set "Card Games")

1
collects/games/gofish/info.ss
View File

@ -1,4 +1,5 @@
#lang setup/infotab
(define name "Go Fish")
(define game "gofish.ss")
(define game-set "Card Games")

1
collects/games/mines/info.ss
View File

@ -1,4 +1,5 @@
#lang setup/infotab
(define name "Minesweeper")
(define game-set "Puzzle Games")
(define game "mines.ss")

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

@ -73,7 +73,16 @@ URL that ends in a slash. For example, the result of
@scheme[(string->url "http://www.drscheme.org/a/")] has a
@scheme[path] field with strings @scheme["a"] and @scheme[""], while
the result of @scheme[(string->url "http://www.drscheme.org/a")] has a
@scheme[path] field with only the string @scheme["a"].}
@scheme[path] field with only the string @scheme["a"].
When a @scheme["file"] URL is represented by a @scheme[url] structure,
the @scheme[path] field is mostly a list of path elements. For Unix
paths, the root directory is not included in @scheme[path]; its
presence or absence is implicit in the @scheme[path-absolute?] flag.
For Windows paths, the first element typically represents a drive, but
a UNC path is represented by a first element that is @scheme[""] and
then successive elements complete the drive components that are
separated by @litchar{/} or @litchar{\}.}
@defstruct[path/param ([path (or/c string? (one-of/c 'up 'same))]
[param (listof string?)])]{
@ -95,7 +104,26 @@ Parses the URL specified by @scheme[str] into a @scheme[url]
struct. The @scheme[string->url] procedure uses
@scheme[form-urlencoded->alist] when parsing the query, so it is
sensitive to the @scheme[current-alist-separator-mode] parameter for
determining the association separator.}
determining the association separator.
If @scheme[str] starts with @scheme["file:"], then the path is always
parsed as an absolute path, and the parsing details depend on
@scheme[file-url-path-convention-type]:
@itemize[
@item{@scheme['unix] : If @scheme["file:"] is followed by
@litchar{//} and a non-@litchar{/}, then the first element
after the @litchar{//} is parsed as a host (and maybe port);
otherwise, the first element starts the path, and the host is
@scheme[""].}
@item{@scheme['windows] : If @scheme["file:"] is followed by
@litchar{//}, then the @litchar{//} is stripped; the remainder
parsed as a Windows path. The host is always @scheme[""] and
the port is always @scheme[#f].}
]}
@defproc[(combine-url/relative [base url?] [relative string?]) url?]{
@ -117,17 +145,50 @@ scheme @scheme["http"].}
@defproc[(url->string [URL url?]) string?]{
Generates a string corresponding to the contents of a @scheme[url] struct.
For a @scheme["file:"] URL, empty strings in the path list are treated as
@scheme['same] for @scheme[build-path].
Generates a string corresponding to the contents of a @scheme[url]
struct. For a @scheme["file:"] URL, the URL must not be relative, the
result always starts @litchar{file://}, and the interpretation of the
path depends on the value of @scheme[file-url-path-convention-type]:
@itemize[
@item{@scheme['unix] : Elements in @scheme[URL] are treated as path
elements. Empty strings in the path list are treated like
@scheme['same].}
@item{@scheme['windows] : If the first element is @scheme[""] then
the next two elements define the UNC root, and the rest of the
elements are treated as path elements. Empty strings in the
path list are treated like @scheme['same].}
]
The @scheme[url->string] procedure uses
@scheme[alist->form-urlencoded] when formatting the query, so it it
@scheme[alist->form-urlencoded] when formatting the query, so it is
sensitive to the @scheme[current-alist-separator-mode] parameter for
determining the association separator. The default is to separate
associations with a @litchar{&}.}
@defproc[(path->url [path (or/c path-string? path-for-some-system?)])
url?]{
Converts a path to a @scheme[url].}
@defproc[(url->path [URL url?]
[kind (one-of/c 'unix 'windows) (system-path-convention-type)])
path-for-some-system?]{
Converts @scheme[URL], which is assumed to be a @scheme["file"] URL,
to a path.}
@defparam[file-url-path-convention-type kind (one-of/c 'unix 'windows)]{
Determines the default conversion to and from strings for
@scheme["file"] URLs. See @scheme[string->url] and @scheme[url->string].}
@deftogether[(
@defproc[(get-pure-port [URL url?]

3
collects/net/url-sig.ss
View File

@ -15,7 +15,10 @@ purify-port
netscape/string->url
string->url
url->string
path->url
url->path
call/input-url
combine-url/relative
url-exception?
current-proxy-servers
file-url-path-convention-type

141
collects/net/url-unit.ss
View File

@ -9,7 +9,7 @@
;; "impure" = they have text waiting
;; "pure" = the MIME headers have been read
(module url-unit mzscheme
(module url-unit scheme/base
(require mzlib/file
mzlib/unit
mzlib/port
@ -22,17 +22,14 @@
"tcp-sig.ss")
(provide url@)
;; undocumented hook to allow testing
(provide set-url:os-type!)
(define url:os-type (system-type))
(define (set-url:os-type! new) (set! url:os-type new))
(define-unit url@
(import tcp^)
(export url^)
(define-struct (url-exception exn:fail) ())
(define file-url-path-convention-type (make-parameter (system-path-convention-type)))
(define current-proxy-servers
(make-parameter null
(lambda (v)
@ -73,6 +70,11 @@
[query (url-query url)]
[fragment (url-fragment url)]
[sa string-append])
(when (and (equal? scheme "file")
(not (url-path-absolute? url)))
(raise-mismatch-error "url->string"
"cannot convert relative file URL to a string: "
url))
(sa (if scheme (sa scheme ":") "")
(if (or user host port)
(sa "//"
@ -82,7 +84,9 @@
;; There used to be a "/" here, but that causes an
;; extra leading slash -- wonder why it ever worked!
)
"")
(if (equal? "file" scheme) ; always need "//" for "file" URLs
"//"
""))
(combine-path-strings (url-path-absolute? url) path)
;; (if query (sa "?" (uri-encode query)) "")
(if (null? query) "" (sa "?" (alist->form-urlencoded query)))
@ -131,25 +135,37 @@
(tcp-abandon-port client->server)
server->client))
(define (file://->path url)
;; remove all ""s
(let ([elts (remove* '("") (map path/param-path (url-path url)))]
[abs? (url-path-absolute? url)])
;; See the discussion in PR8060 for an explanation
(if (eq? 'windows url:os-type)
(let ([host (or (url-host url) "")])
(unless (equal? "" host) (set! elts (cons host elts)))
(if (null? elts)
(build-path) ; make it throw the error
(let* ([fst (car elts)] [len (string-length fst)])
(if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
(apply build-path elts)
(if (null? (cdr elts))
(build-path (string-append "\\\\" (car elts)))
(define (file://->path url [kind (system-path-convention-type)])
(let ([strs (map path/param-path (url-path url))]
[string->path-element/same
(lambda (e)
(if (symbol? e)
e
(if (string=? e "")
'same
(bytes->path-element (string->bytes/locale e) kind))))]
[string->path/win (lambda (s)
(bytes->path (string->bytes/utf-8 s) 'windows))])
(if (and (url-path-absolute? url)
(eq? 'windows kind))
;; If initial path is "", then build UNC path.
(cond
[(not (url-path-absolute? url))
(apply build-path (map string->path-element/same strs))]
[(and ((length strs) . >= . 3)
(equal? (car strs) ""))
(apply build-path
(string-append "\\\\" (car elts) "\\" (cadr elts))
(cddr elts)))))))
(apply build-path (if abs? (cons "/" elts) elts)))))
(string->path/win
(string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\"))
(map string->path-element/same (cdddr strs)))]
[(pair? strs)
(apply build-path (string->path/win (car strs))
(map string->path-element/same (cdr strs)))]
[else (build-path)]) ; error
(let ([elems (map string->path-element/same strs)])
(if (url-path-absolute? url)
(apply build-path "/" elems)
(apply build-path elems))))))
;; file://get-pure-port : url -> in-port
(define (file://get-pure-port url)
@ -362,19 +378,33 @@
scheme)))
(url-error "Invalid URL string; bad scheme ~e: ~e" scheme str))
;; Windows => "file://xxx:/...." specifies a "xxx:/..." path
(when (and (equal? "" port) (equal? "file" scheme)
(eq? 'windows url:os-type))
(let ([win-file? (and (or (equal? "" port)
(not port))
(equal? "file" scheme)
(eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))])
(when win-file?
(if (equal? "" port)
(set! path (string-append host ":" path))
(set! host #f))
(set! path (if path
(if host
(string-append host "/" path)
path)
host)))
(set! port #f)
(set! host ""))
(let* ([scheme (and scheme (string-downcase scheme))]
[host (and host (string-downcase host))]
[user (uri-decode/maybe user)]
[port (and port (string->number port))]
[abs? (regexp-match? #rx"^/" path)]
[path (separate-path-strings path)]
[abs? (or (equal? "file" scheme)
(regexp-match? #rx"^/" path))]
[path (if win-file?
(separate-windows-path-strings path)
(separate-path-strings path))]
[query (if query (form-urlencoded->alist query) '())]
[fragment (uri-decode/maybe fragment)])
(make-url scheme user host port abs? path query fragment)))
(make-url scheme user host port abs? path query fragment))))
(cdr (or (regexp-match url-rx str)
(url-error "Invalid URL string: ~e" str)))))
@ -389,6 +419,9 @@
(let ([strs (regexp-split #rx"/" str)])
(map separate-params (if (string=? "" (car strs)) (cdr strs) strs))))
(define (separate-windows-path-strings str)
(url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows))))
(define (separate-params s)
(let ([lst (map path-segment-decode (regexp-split #rx";" s))])
(make-path/param (car lst) (cdr lst))))
@ -423,6 +456,52 @@
(apply string-append (reverse r))
(loop (cdr strings) (list* (car strings) sep r))))]))
(define (path->url path)
(let ([url-path (let loop ([path (simplify-path path #f)][accum null])
(let-values ([(base name dir?) (split-path path)])
(cond
[(not base)
(append (map
(lambda (s)
(make-path/param s null))
(if (eq? (path-convention-type path) 'windows)
;; For Windows, massage the root:
(let ([s (regexp-replace
#rx"[/\\\\]$"
(bytes->string/utf-8
(path->bytes name))
"")])
(cond
[(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s)
;; \\?\<drive>: path:
(regexp-split #rx"[/\\]+" (substring s 4))]
[(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s)
;; \\?\ UNC path:
(regexp-split #rx"[/\\]+" (substring s 7))]
[(regexp-match? #rx"^[/\\]" s)
;; UNC path:
(regexp-split #rx"[/\\]+" s)]
[else
(list s)]))
;; On other platforms, we drop the root:
null))
accum)]
[else
(let ([accum (cons (make-path/param
(if (symbol? name)
name
(bytes->string/utf-8
(path-element->bytes name)))
null)
accum)])
(if (eq? base 'relative)
accum
(loop base accum)))])))])
(make-url "file" #f "" #f (absolute-path? path) url-path '() #f)))
(define (url->path url [kind (system-path-convention-type)])
(file://->path url kind))
;; delete-pure-port : url [x list (str)] -> in-port
(define/kw (delete-pure-port url #:optional [strings '()])
(method-pure-port 'delete url #f strings))

6
collects/net/url.ss
View File

@ -26,7 +26,9 @@
(provide/contract
(string->url ((or/c bytes? string?) . -> . url?))
(path->url ((or/c path-string? path-for-some-system?) . -> . url?))
(url->string (url? . -> . string?))
(url->path ((url?) ((one-of/c 'unix 'windows)) . opt-> . path-for-some-system?))
(get-pure-port (opt-> (url?) ((listof string?)) input-port?))
(get-impure-port (opt-> (url?) ((listof string?)) input-port?))
@ -54,6 +56,8 @@
(combine-url/relative (url? string? . -> . url?))
(url-exception? (any/c . -> . boolean?))
(current-proxy-servers
(parameter/c (or/c false/c (listof (list/c string? string? number?))))))
(parameter/c (or/c false/c (listof (list/c string? string? number?)))))
(file-url-path-convention-type
(parameter/c (one-of/c 'unix 'windows))))
)

8
collects/scribblings/reference/reader.scrbl
View File

@ -804,10 +804,10 @@ of alphanumeric ASCII, @litchar{+}, @litchar{-}, @litchar{_}, and/or
@litchar{/} characters terminated by
@schemelink[char-whitespace?]{whitespace} or an end-of-file. The
sequence must not start or end with @litchar{/}. A sequence
@litchar{#lang }@nonterm{name} is equivalent to
@litchar{#reader }@nonterm{name}@litchar{/lang/reader}, except that
the terminating whitespace (if any) is consumed before the external
reading procedure is called.
@litchar["#lang\u20"]@nonterm{name} is equivalent to
@litchar["#reader\u20"]@nonterm{name}@litchar{/lang/reader}, except
that the terminating whitespace (if any) is consumed before the
external reading procedure is called.
Finally, @as-index{@litchar{#!}} followed by alphanumeric ASCII,
@litchar{+}, @litchar{-}, or @litchar{_} is a synonym for

8
collects/scribblings/reference/startup.scrbl
View File

@ -174,10 +174,6 @@ flags:
@Flag{i}/@DFlag{repl}, but uses @scheme[read-eval-print-loop]
instead of @scheme[graphical-read-eval-print-loop].}
@item{@FlagFirst{q} or @DFlagFirst{no-init-file} : Skips loading
@scheme[(find-system-path 'init-file)] for
@Flag{i}/@DFlag{repl} or @Flag{z}/@DFlag{text-repl}.}
@item{@FlagFirst{n} or @DFlagFirst{no-lib} : Skips requiring the
initialization library (i.e., @schememodname[scheme/init] or
@schememodname[scheme/gui/init], unless it is changed with the
@ -204,6 +200,10 @@ flags:
of compiled byte-code @filepath{.zo} files, by initializing
@scheme[current-compiled-file-paths] to @scheme[null].}
@item{@FlagFirst{q} or @DFlagFirst{no-init-file} : Skips loading
@scheme[(find-system-path 'init-file)] for
@Flag{i}/@DFlag{repl} or @Flag{z}/@DFlag{text-repl}.}
@item{@FlagFirst{I} @nonterm{path} : Sets @scheme[(lib #,
@nontermstr{path})] as the path to @scheme[require] to initialize
the namespace, unless namespace initialization is disabled.}

24
collects/scribblings/reference/struct.scrbl
View File

@ -112,7 +112,8 @@ The resulting structure type has
addition to any fields from @scheme[super-type]), but only
@scheme[init-field-cnt] constructor arguments (in addition to any
constructor arguments from @scheme[super-type]). The remaining fields
are initialized with @scheme[auto-v].
are initialized with @scheme[auto-v]. The total field count (including
@scheme[super-type] fields) must be no more than 32768.
The @scheme[props] argument is a list of pairs, where the @scheme[car]
of each pair is a structure type property descriptor, and the
@ -439,8 +440,9 @@ used instead of a list that contains only a symbol (in the case that
the structure type has no supertype, no automatic fields, and no
mutable fields).
If the number of fields indicated by @scheme[key] is inconsistent with
the number of supplied @scheme[v]s, the @exnraise[exn:fail:contract].
The total field count must be no more than 32768. If the number of
fields indicated by @scheme[key] is inconsistent with the number of
supplied @scheme[v]s, the @exnraise[exn:fail:contract].
@examples[
(make-prefab-struct 'clown "Binky" "pie")
@ -450,6 +452,14 @@ the number of supplied @scheme[v]s, the @exnraise[exn:fail:contract].
(make-prefab-struct '(clown 1 (1 #f) #(0)) "Binky" "pie")
]}
@defproc[(prefab-key->struct-type [key (or/c symbol? list?)]
[field-count (integer-in 0 32768)])
struct-type?]{
Returns a @tech{structure type descriptor} for the @tech{prefab}
structure type specified by the combination of @scheme[key] and
@scheme[field-count].}
@;------------------------------------------------------------------------
@section[#:tag "structinfo"]{Structure Type Transformer Binding}
@ -540,10 +550,10 @@ procedure encapsulated by @scheme[make-struct-info].}
@defproc[(checked-struct-info? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a structure encapsulated by
@scheme[make-struct-info] and produced by @scheme[define-struct]. Such
values may be relied upon to accurately represent a structure and have
correct super-type information.}
Returns @scheme[#t] if @scheme[v] is a procedure encapsulated by
@scheme[make-struct-info] and produced by @scheme[define-struct], but
only when no parent type is specified or the parent type is also
specified through a transformer binding to such a value).}
@defproc[(make-struct-info [thunk (-> (and/c struct-info? list?))])
struct-info?]{

16
collects/scribblings/reference/syntax.scrbl
View File

@ -1307,6 +1307,7 @@ Legal only in a @tech{module begin context}, and handled by the
id
(file string)
(planet id)
(planet string)
(planet rel-string
(user-string pkg-string vers ...)
rel-string ...)]
@ -1475,12 +1476,13 @@ corresponds to the default @tech{module name resolver}.
current platform's path conventions.}
@defsubform*[((planet id)
(planet string)
(planet rel-string (user-string pkg-string vers ...)
rel-string ...))]{
Specifies a library available via the @PLaneT server.
The first form is a shorthand for the second, where the @scheme[id]'s
The first form is a shorthand for the last one, where the @scheme[id]'s
character sequence must match the following @nonterm{spec} grammar:
@BNF[
@ -1504,9 +1506,17 @@ corresponds to the default @tech{module name resolver}.
and where an @nonterm{elem} is a non-empty sequence of characters
that are ASCII letters, ASCII digits, @litchar{-}, @litchar{+}, or
@litchar{_}, and an @nonterm{int} is a non-empty sequence of ASCII
digits.
digits. As this shorthand is expended, a @filepath{.plt} extension is
added to @nonterm{pkg}, and a @filepath{.ss} extension is added to
@scheme{path}; if no @nonterm{path} is included, @filepath{main.ss}
is used in the expansion.
In the more general second form of a @scheme[planet] module path, the
A @scheme[(planet string)] form is like a @scheme[(planet id)] form
with the identifier converted to a string, except that the
@scheme[string] can optionally end with a file extension for a
@nonterm{path}.
In the more general last form of a @scheme[planet] module path, the
@scheme[rel-string]s are similar to the @scheme[lib] form, except
that the @scheme[(user-string pkg-string vers ...)] names a
@|PLaneT|-based package instead of a @tech{collection}.}

4
collects/scribblings/scribble/reader.scrbl
View File

@ -284,8 +284,8 @@ are valid text.
As described above, the text turns to a sequence of string arguments
for the resulting form. Spaces at the beginning and end of lines are
discarded, and newlines turn to individual @scheme["\n"] strings
(i.e., they are not merged with other body parts). (See also the
information about newlines and indentation below.) Spaces are
(i.e., they are not merged with other body parts); see also the
information about newlines and indentation below. Spaces are
@italic{not} discarded if they appear after the open @litchar["{"]
(before the closing @litchar["}"]) when there is also text that
follows (precedes) it; specifically, they are preserved in a

55
collects/tests/mzscheme/net.ss
View File

@ -11,7 +11,6 @@
(require net/url
net/uri-codec
mzlib/string
net/url-unit ; to get set-url:os-type!
)
(test "%Pq" uri-decode "%Pq")
@ -280,8 +279,10 @@
(err/rt-test (string->url "a b://www.foo.com/") url-exception?)
;; test file: urls
(test-s->u #("file" #f #f #f #t (#("abc") #("def.html")) () #f)
"file:/abc/def.html")
(test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f)
"file:///abc/def.html")
(test "file:///abc/def.html" url->string (string->url "file:///abc/def.html"))
(test "file://a/b" url->string (string->url "file://a/b"))
(test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f)
"file://localhost/abc/def.html")
@ -289,25 +290,55 @@
;; test files: urls with colons, and the different parsing on Windows
(test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f)
"file://localhost:123/abc/def.html")
(set-url:os-type! 'unix)
(parameterize ([file-url-path-convention-type 'unix])
;; different parse for file://foo:/...
(test #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f)
string->url/vec
"file://foo:/abc/def.html")
(set-url:os-type! 'windows)
(test #("file" #f #f #f #f (#("foo:") #("abc") #("def.html")) () #f)
"file://foo:/abc/def.html"))
(parameterize ([file-url-path-convention-type 'windows])
(test #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f)
string->url/vec
"file://foo:/abc/def.html")
(set-url:os-type! 'unix)
(test #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f)
string->url/vec
"file://c:/abc/def.html")
(test #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f)
string->url/vec
"file:\\\\d\\c\\abc\\def.html"))
(parameterize ([file-url-path-convention-type 'unix])
;; but no effect on http://foo:/...
(test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f)
string->url/vec
"http://foo:/abc/def.html")
(set-url:os-type! 'windows)
"http://foo:/abc/def.html"))
(parameterize ([file-url-path-convention-type 'windows])
(test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f)
string->url/vec
"http://foo:/abc/def.html")
(set-url:os-type! 'unix)
"http://foo:/abc/def.html"))
(test "file:///c:/a/b"
url->string (path->url (bytes->path #"c:\\a\\b" 'windows)))
(test "file:///c:/a/b"
url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)))
(test #"/a/b/c" path->bytes
(url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix))
(test #"a/b/c" path->bytes
(url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix))
(test #"c:\\a\\b" path->bytes
(url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows))
(test #"a\\b" path->bytes
(url->path (path->url (bytes->path #"a/b" 'windows)) 'windows))
(test #"\\\\d\\c\\a" path->bytes
(url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows))
(test #"c:\\a\\b" path->bytes
(url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows))
(test #"\\\\d\\c\\a\\b" path->bytes
(url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows))
(test #"\\\\?\\c:\\a/x\\b" path->bytes
(url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows))
(test #"\\\\?\\UNC\\d\\c\\a/x\\b" path->bytes
(url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows))
;; see PR8809 (value-less keys in the query part)
(test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f)) #f)

3
src/mzscheme/cmdline.inc
View File

@ -833,6 +833,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
break;
case 'q':
no_init_file = 1;
was_config_flag = 1;
break;
case 'n':
no_init_ns = 1;
@ -1073,7 +1074,6 @@ static int run_from_cmd_line(int argc, char *_argv[],
# ifdef CMDLINE_STDIO_FLAG
" -z, --text-repl : Like -i, but use text read-eval-print loop\n"
# endif
" -q, --no-init-file : Skip load of " INIT_FILENAME " for " REPL_FLAGS "\n"
" -n, --no-lib : Skip `(require (lib \"<init-lib>\"))' for " REPL_FLAGS "/-e/-f/-r\n"
" -v, --version : Show version\n"
# ifdef CMDLINE_STDIO_FLAG
@ -1084,6 +1084,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
# endif
" Configuration options:\n"
" -c, --no-compiled : Disable loading of compiled files\n"
" -q, --no-init-file : Skip load of " INIT_FILENAME " for " REPL_FLAGS "\n"
" -I <path> : Set <init-lib> to <path>\n"
" -X <dir>, --collects <dir> : Main collects at <dir> relative to " PROGRAM "\n"
" -S <dir>, --search <dir> : More collects at <dir> relative to " PROGRAM "\n"

6
src/mzscheme/src/port.c
View File

@ -286,7 +286,7 @@ int scheme_force_port_closed;
static int flush_out, flush_err;
#if defined(FILES_HAVE_FDS)
static int external_event_fd, put_external_event_fd, event_fd_set;
static int external_event_fd, put_external_event_fd;
#endif
static void register_port_wait();
@ -7961,7 +7961,6 @@ static void default_sleep(float v, void *fds)
if (external_event_fd) {
char buf[10];
read(external_event_fd, buf, 10);
event_fd_set = 0;
}
#endif
}
@ -7980,8 +7979,7 @@ void scheme_signal_received(void)
/* Ensure that MzScheme wakes up if asleep. */
{
#if defined(FILES_HAVE_FDS)
if (put_external_event_fd && !event_fd_set) {
event_fd_set = 1;
if (put_external_event_fd) {
write(put_external_event_fd, "!", 1);
}
#endif

37
src/mzscheme/src/struct.c
View File

@ -1784,14 +1784,19 @@ static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[])
return scheme_make_prefab_struct_instance(stype, vec);
}
#define MAX_STRUCT_FIELD_COUNT 32768
#define MAX_STRUCT_FIELD_COUNT_STR "32768"
static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[])
{
Scheme_Struct_Type *stype;
int v;
if (!SCHEME_INTP(argv[1]))
if (SCHEME_INTP(argv[1])) {
v = SCHEME_INT_VAL(argv[1]);
else
if (v > MAX_STRUCT_FIELD_COUNT)
v = -1;
} else
v = -1;
stype = scheme_lookup_prefab_type(argv[0], (v >= 0) ? v : -1);
@ -1800,7 +1805,15 @@ static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[])
scheme_wrong_type("make-prefab-struct", "prefab key", 0, argc, argv);
if (v < 0)
scheme_wrong_type("make-prefab-struct", "non-negative fixnum", 1, argc, argv);
scheme_wrong_type("make-prefab-struct",
"integer in [0, " MAX_STRUCT_FIELD_COUNT_STR "]",
1, argc, argv);
if (stype->num_slots != v) {
scheme_arg_mismatch("make-prefab-struct",
"prefab key field count does not match supplied count: ",
argv[1]);
}
return (Scheme_Object *)stype;
}
@ -2661,17 +2674,17 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
if (parent_type)
struct_type->proc_attr = parent_type->proc_attr;
/* Check for integer overflow or total more than 32768: */
/* Check for integer overflow or total more than MAX_STRUCT_FIELD_COUNT: */
if ((num_fields < 0) || (num_uninit_fields < 0)
|| (num_fields > 32768)
|| (num_uninit_fields > 32768)
|| (num_uninit_fields + num_fields > 32768)
|| (num_fields > MAX_STRUCT_FIELD_COUNT)
|| (num_uninit_fields > MAX_STRUCT_FIELD_COUNT)
|| (num_uninit_fields + num_fields > MAX_STRUCT_FIELD_COUNT)
|| (parent_type
&& ((struct_type->num_slots < parent_type->num_slots)
|| (struct_type->num_islots < parent_type->num_islots)))) {
/* Too many fields. */
scheme_raise_exn(MZEXN_FAIL,
"too many fields for struct-type; maximum total field count is 32768");
"too many fields for struct-type; maximum total field count is " MAX_STRUCT_FIELD_COUNT_STR);
return NULL;
}
@ -3276,6 +3289,9 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
if (scheme_proper_list_length(key) < 0)
return NULL;
if (field_count > MAX_STRUCT_FIELD_COUNT)
field_count = MAX_STRUCT_FIELD_COUNT;
if (prefab_table) {
a = scheme_lookup_in_table(prefab_table, (const char *)key);
if (a)
@ -3329,6 +3345,8 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
return NULL;
} else {
icnt = SCHEME_INT_VAL(a);
if (icnt > MAX_STRUCT_FIELD_COUNT)
return NULL;
key = SCHEME_CDR(key);
}
@ -3371,6 +3389,9 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
prev++;
}
if (parent && (icnt + parent->num_slots > MAX_STRUCT_FIELD_COUNT))
return NULL;
parent = (Scheme_Struct_Type *)_make_struct_type(name, NULL, 0,
(Scheme_Object *)parent,
scheme_false,