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

original commit: 0153e122b7423d578acc480904f7a0fcfd52f46d

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

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)
+    (define (file://->path url [kind (system-path-convention-type)])
-      ;; remove all ""s
+      (let ([strs (map path/param-path (url-path url))]
-      (let ([elts (remove* '("") (map path/param-path (url-path url)))]
+            [string->path-element/same
-            [abs? (url-path-absolute? url)])
+             (lambda (e)
-        ;; See the discussion in PR8060 for an explanation
+               (if (symbol? e)
-        (if (eq? 'windows url:os-type)
+                   e
-          (let ([host (or (url-host url) "")])
+                   (if (string=? e "")
-            (unless (equal? "" host) (set! elts (cons host elts)))
+                       'same
-            (if (null? elts)
+                       (bytes->path-element (string->bytes/locale e) kind))))]
-              (build-path) ; make it throw the error
+            [string->path/win (lambda (s)
-              (let* ([fst (car elts)] [len (string-length fst)])
+                                (bytes->path (string->bytes/utf-8 s) 'windows))])
-                (if (or (not abs?) (eq? #\: (string-ref fst (sub1 len))))
+        (if (and (url-path-absolute? url)
-                  (apply build-path elts)
+                 (eq? 'windows kind))
-                  (if (null? (cdr elts))
+            ;; If initial path is "", then build UNC path.
-                    (build-path (string-append "\\\\" (car elts)))
+            (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))
+                     (string->path/win
-                           (cddr elts)))))))
+                      (string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\"))
-          (apply build-path (if abs? (cons "/" elts) elts)))))
+                     (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)
+         (let ([win-file? (and (or (equal? "" port) 
-                    (eq? 'windows url:os-type))
+                                   (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)]
+                  [abs?     (or (equal? "file" scheme)
-                [path     (separate-path-strings path)]
+                                (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))