From 0153e122b7423d578acc480904f7a0fcfd52f46d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Apr 2008 19:05:35 +0000 Subject: [PATCH] change -q to config option, fix unlikely race condition in wake-on-signal, add path->url and url->path, and adjust URL parsing svn: r9239 --- collects/drscheme/syncheck.ss | 17 +- collects/games/crazy8s/info.ss | 1 + collects/games/ginrummy/info.ss | 1 + collects/games/gofish/info.ss | 1 + collects/games/mines/info.ss | 1 + collects/net/scribblings/url.scrbl | 73 ++++++++- collects/net/url-sig.ss | 3 + collects/net/url-unit.ss | 157 ++++++++++++++----- collects/net/url.ss | 6 +- collects/scribblings/reference/reader.scrbl | 8 +- collects/scribblings/reference/startup.scrbl | 8 +- collects/scribblings/reference/struct.scrbl | 24 ++- collects/scribblings/reference/syntax.scrbl | 16 +- collects/scribblings/scribble/reader.scrbl | 4 +- collects/tests/mzscheme/net.ss | 67 +++++--- src/mzscheme/cmdline.inc | 3 +- src/mzscheme/src/port.c | 6 +- src/mzscheme/src/struct.c | 37 ++++- 18 files changed, 331 insertions(+), 102 deletions(-) diff --git a/collects/drscheme/syncheck.ss b/collects/drscheme/syncheck.ss index 04e4f22419..15913ba7bb 100644 --- a/collects/drscheme/syncheck.ss +++ b/collects/drscheme/syncheck.ss @@ -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)))))))))))))))))))))) diff --git a/collects/games/crazy8s/info.ss b/collects/games/crazy8s/info.ss index 003130fc51..62d046aaed 100644 --- a/collects/games/crazy8s/info.ss +++ b/collects/games/crazy8s/info.ss @@ -1,4 +1,5 @@ #lang setup/infotab +(define name "Crazy 8s") (define game "crazy8s.ss") (define game-set "Card Games") diff --git a/collects/games/ginrummy/info.ss b/collects/games/ginrummy/info.ss index 90795a5c30..656fb15e49 100644 --- a/collects/games/ginrummy/info.ss +++ b/collects/games/ginrummy/info.ss @@ -1,4 +1,5 @@ #lang setup/infotab +(define name "Rummy") (define game "ginrummy.ss") (define game-set "Card Games") diff --git a/collects/games/gofish/info.ss b/collects/games/gofish/info.ss index 55b27526ba..ccefee6ff6 100644 --- a/collects/games/gofish/info.ss +++ b/collects/games/gofish/info.ss @@ -1,4 +1,5 @@ #lang setup/infotab +(define name "Go Fish") (define game "gofish.ss") (define game-set "Card Games") diff --git a/collects/games/mines/info.ss b/collects/games/mines/info.ss index 36d3a5f3ec..8b286af017 100644 --- a/collects/games/mines/info.ss +++ b/collects/games/mines/info.ss @@ -1,4 +1,5 @@ #lang setup/infotab +(define name "Minesweeper") (define game-set "Puzzle Games") (define game "mines.ss") diff --git a/collects/net/scribblings/url.scrbl b/collects/net/scribblings/url.scrbl index 7ad210140f..f0aa400672 100644 --- a/collects/net/scribblings/url.scrbl +++ b/collects/net/scribblings/url.scrbl @@ -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?] diff --git a/collects/net/url-sig.ss b/collects/net/url-sig.ss index 6360a8535b..dd77c5fa51 100644 --- a/collects/net/url-sig.ss +++ b/collects/net/url-sig.ss @@ -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 diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index c185a1b736..cffa75dfe6 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -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))) - (apply build-path - (string-append "\\\\" (car elts) "\\" (cadr elts)) - (cddr elts))))))) - (apply build-path (if abs? (cons "/" elts) 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->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)) - (set! path (string-append host ":" path)) - (set! host #f)) - (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)] - [query (if query (form-urlencoded->alist query) '())] - [fragment (uri-decode/maybe fragment)]) - (make-url scheme user host port abs? path query fragment))) + (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! 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? (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)))) (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) + ;; \\?\: 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)) diff --git a/collects/net/url.ss b/collects/net/url.ss index c0aa5325c5..cd1ce2e526 100644 --- a/collects/net/url.ss +++ b/collects/net/url.ss @@ -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)))) ) diff --git a/collects/scribblings/reference/reader.scrbl b/collects/scribblings/reference/reader.scrbl index 0159ff838b..0175ab3390 100644 --- a/collects/scribblings/reference/reader.scrbl +++ b/collects/scribblings/reference/reader.scrbl @@ -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 diff --git a/collects/scribblings/reference/startup.scrbl b/collects/scribblings/reference/startup.scrbl index 3d06195017..e16c988afc 100644 --- a/collects/scribblings/reference/startup.scrbl +++ b/collects/scribblings/reference/startup.scrbl @@ -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.} diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 9a43b1caa6..c6664f15b4 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -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?]{ diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index bd57de6edf..071dbc46d3 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -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}.} diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index f9157843b5..4fffb4f43c 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -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 diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 6bec67a8a8..c467128119 100644 --- a/collects/tests/mzscheme/net.ss +++ b/collects/tests/mzscheme/net.ss @@ -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,26 +290,56 @@ ;; 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) - ;; different parse for file://foo:/... - (test #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f) + (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")) + (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! 'windows) - (test #("file" #f #f #f #f (#("foo:") #("abc") #("def.html")) () #f) + (test #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) string->url/vec - "file://foo:/abc/def.html") - (set-url:os-type! 'unix) - ;; but no effect on http://foo:/... - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) + "file://c:/abc/def.html") + (test #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f) string->url/vec - "http://foo:/abc/def.html") - (set-url:os-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) + "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")) + (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")) + + (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) "http://foo.bar/baz?ugh") diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index a622428eb5..5a82470a05 100644 --- a/src/mzscheme/cmdline.inc +++ b/src/mzscheme/cmdline.inc @@ -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 \"\"))' 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 : Set to \n" " -X , --collects : Main collects at relative to " PROGRAM "\n" " -S , --search : More collects at relative to " PROGRAM "\n" diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index d7c018f235..227f01a25a 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -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 diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index c5a27e1656..96c52905fe 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -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,