.

original commit: 77e5a9212e4e76382f0cadb82cf61e743927947b

collects/net/sendurl.ss

@@ -2,6 +2,7 @@
   (require (lib "process.ss")
            (lib "file.ss")
            (lib "etc.ss")
+           (lib "thread.ss")
            (lib "sendevent.ss"))
   
   (provide send-url unix-browser-list browser-preference? external-browser)
@@ -25,11 +26,6 @@
   ; send-url : str [bool] -> void
   (define send-url
     (opt-lambda (url-str [separate-window? separate-by-default?])
-      ; The with-handler reverts to the old error port before printing raised error messages.
-      (with-handlers ([void (lambda (exn) (raise exn))])
-        (parameterize ([current-input-port null-input]
-                       [current-error-port null-output]
-                       [current-output-port null-output])
       (cond
        [(procedure? (external-browser))
 	((external-browser) url-str)]
@@ -56,11 +52,9 @@
 	    (send-event "MACS" "GURL" "GURL" url-str))]
        [(or (eq? (system-type) 'macosx)
 	    (equal? "ppc-macosxonx" (system-library-subpath)))
-             
+	;; not sure what changed, but this is wrong now.... -robby
-             ; not sure what changed, but this is wrong now.... -robby
+	;;(browser-process (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))	
-             ;(system (format "osascript -e 'open location \"~a\"'" (regexp-replace* "%" url-str "%25")))
+	(browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
-             
-             (system (format "osascript -e 'open location \"~a\"'" url-str))]
        [(eq? (system-type) 'windows)
 	(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
        [(eq? (system-type) 'unix)
@@ -71,7 +65,7 @@
 	    (lambda (browser-path) 
 	      ;; opera may not return -- always open asyncronously
 	      ;; opera starts a new browser automatically, if it can't find one
-                    (process*/close-ports browser-path "-remote"
+	      (browser-process* browser-path "-remote"
 				(format "openURL(~a)"
 					(if separate-window?
 					    (format "~a,new-window" url-str)
@@ -79,7 +73,7 @@
 	   [(use-browser 'galeon preferred)
 	    =>
 	    (lambda (browser-path)
-                    (process*/close-ports browser-path
+	      (browser-process* browser-path
 				(if separate-window? "-w" "-x")
 				url-str))]
 	   [(or (use-browser 'netscape preferred)
@@ -93,25 +87,19 @@
 				   (if separate-window?
 				       (format "~a,new-window" url-str)
 				       url-str)))
-                        (process*/close-ports browser-path url-str)))]
+		  (browser-process* browser-path url-str)))]
 	   [(use-browser 'dillo preferred)
 	    =>
 	    (lambda (browser-path)
-                    (process*/close-ports browser-path url-str))]
+	      (browser-process* browser-path url-str))]
 	   [(custom-browser? preferred)
-		  (let ([cmd (parse-bash-command
+	    (let ([cmd (string-append (car preferred)
-			      (string-append (car preferred)
 				      url-str
-					     (cdr preferred)))])
+				      (cdr preferred))])
-		    (if (null? cmd)
+	      (browser-process cmd))]
-			(error 'send-url "no custom browser selected")
-			(let ([prog (find-executable-path (car cmd) #f)])
-			  (if prog
-			      (apply process*/close-ports prog (cdr cmd))
-			      (error 'send-url "cannot find custom browser ~e" (car cmd))))))]
 	   [else
 	    (error 'send-url "Couldn't find ~a to open URL: ~e" (orify unix-browser-list) url-str)]))]
-            [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))))
+       [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))
   
   ; : tst -> bool
   (define (custom-browser? x)
@@ -137,167 +125,27 @@
 	     (eq? preferred browser-name))
 	 (find-executable-path (symbol->string browser-name) #f)))
     
-  ; null-input : iport
-  (define null-input
-    (make-custom-input-port #f
-			    (lambda (s) eof)
-			    #f
-			    void))
-  
   ; null-output : oport
   (define null-output
     (make-custom-output-port #f (lambda (s start end flush?) (- end start)) void void))
 
-  (define dev-null "/dev/null") ; unix specific, so slashes are okay
+  ;; run-browser : process-proc list-of-strings -> void
+  (define (run-browser process*/ports args)
+    (let-values ([(stdout stdin pid stderr control)
+		  (apply values (apply process*/ports
+				       null-output
+				       #f
+				       (current-error-port)
+				       args))])
+      (close-output-port stdin)
+      (thread (lambda ()
+		(control 'wait)
+		(when (eq? 'done-error (control 'status))
+		  (error 'run-browser "process execute failed: ~e" args))))
+      (void)))
 
-  ; process*/close-ports : [arg]* -> void
+  (define (browser-process* . args)
-  ; This is a funny hack.  Closing unused scheme pipe ports right away closes
+    (run-browser process*/ports args))
-  ; the ports the browser is using, resulting in errors if they are read from or written
-  ; to.  However, closing file ports (i.e. to and from /dev/null) after the subprocess is
-  ; spawned does _not_ close the browser's ports since they are copied when the subprocess
-  ; loads.  Blech.
-  ; All this is necessary because system administrators replace netscape with a funny
-  ; perl/zsh/whatever script that prints out extra crud or does weird, system dependent
-  ; setup stuff before launching the original browser executable.
-  (define (process*/close-ports . args)
-    (if (and (memq (system-type) '(unix macosx))
-             ; we can't check for _the_ dev-null, so check what we can
-             (file-exists? dev-null)
-             (let ([perms (file-or-directory-permissions dev-null)])
-               (and (memq 'read perms)
-                    (memq 'write perms)))
-             (zero? (file-size dev-null)))
-        (let ([out (open-output-file dev-null 'append)]
-              [in (open-input-file dev-null)]
-              [err (open-output-file dev-null 'append)])
-          (let-values ([(false-out false-in id false-err status) 
-                        (apply values (apply process*/ports out in err args))])
-            (close-output-port out)
-            (close-input-port in)
-            (close-output-port err)))
-        (let-values ([(out in id err status) 
-                      (apply values (apply process*/ports #f #f #f args))])
-          (close-input-port out)
-          (close-output-port in)
-          (close-input-port err))))
 
-  ; parse-command : iport -> (listof str)
+  (define (browser-process cmd)
-  (define (parse-command.com in)
+    (run-browser process/ports (list cmd))))
-    (let parse ()
-      (cond
-        [(eof-object? (skip-space-tab in)) null]
-        [else (cons (list->string (parse-one #t in)) (parse))])))
-  
-  ; parse-one : bool iport -> (listof char)
-  (define (parse-one unquoted in)
-    (let parse-1 ([unquoted unquoted])
-      (let ([c (read-char in)])
-        (cond
-          [(eof-object? c) null]
-          [(eq? c #\\) (parse-backslashes 1 unquoted in)]
-          [(eq? c #\") (parse-1 (not unquoted))]
-          [(and unquoted (or (eq? #\space c) (eq? #\tab c))) null]
-          [else (cons c (parse-1 unquoted))]))))
-  
-  ; parse-backslashes : nat bool iport -> (listof char)
-  (define (parse-backslashes n unquoted in)
-    (let more ([n n])
-      (let ([c (read-char in)])
-        (cond
-          [(eq? c #\\) (more (add1 n))]
-          [(eq? c #\")
-           (if (even? n)
-               (cons-n-backslashes (/ n 2) (parse-one (not unquoted) in))
-               (cons-n-backslashes (/ (sub1 n) 2) (cons #\" (parse-one unquoted in))))]
-          [(and unquoted (or (eq? #\space c) (eq? #\tab c))) null]
-          [else (cons-n-backslashes n (cons c (parse-one unquoted in)))]))))
-  
-  ; cons-n-backslashes : nat (listof char) -> (listof char)
-  (define (cons-n-backslashes n l)
-    (cond
-      [(zero? n) l]
-      [else (cons-n-backslashes (sub1 n) (cons #\\ l))]))
-  
-  ; skip-space-tab : iport -> (U char eof)
-  ; to skip spaces and tabs
-  (define (skip-space-tab in)
-    (let loop ()
-      (let ([c (peek-char in)])
-        (cond
-          [(or (eq? #\space c) (eq? #\tab c))
-           (read-char in)
-           (loop)]
-          [else c]))))
-  
-  ; test-parse-command.com : -> bool
-  ; all but one of these tests is taken from MS's documentation
-  ; http://www.cygwin.com/ml/cygwin/1999-08/msg00701.html
-  (define (test-parse-command.com)
-    (and (equal? (parse-command.com (open-input-string "\"a b c\" d e"))
-                 '("a b c" "d" "e"))
-         (equal? (parse-command.com (open-input-string "\"ab\\\"c\" \"\\\\\" d"))
-                 '("ab\"c" "\\" "d"))
-         (equal? (parse-command.com (open-input-string "a\\\\\\b d\"e f\"g h"))
-                 '("a\\\\\\b" "de fg" "h"))
-         (equal? (parse-command.com (open-input-string "a\\\"b c d"))
-                 '("a\"b" "c" "d"))
-         (equal? (parse-command.com (open-input-string "a\\\\\\\"b c d"))
-                 '("a\\\"b" "c" "d"))
-         (equal? (parse-command.com (open-input-string "a\\\\\\\\\"b c\" d e"))
-                 '("a\\\\b c" "d" "e")))) ; : str -> (listof str)
-  ; to split a string into an argument list similar to how bash does.
-  ; It does not handle backquotes because it does not evaluate bash commands.
-  ; It does not expand shell variables, nor does it expand tilda paths.
-  (define (parse-bash-command line)
-    (let ([in (open-input-string line)])
-      (let loop ()
-        (let ([w (parse-word in)])
-          (if (zero? (string-length w))
-              null
-              (cons w (loop)))))))
-  
-  ; : iport -> str
-  ; backslashes are literal inside ''s, almost literal inside ""s, and always escape the next character when unquoted
-  (define (parse-word in)
-    (skip-space-tab in)
-    (list->string
-     (let parse-word ()
-       (let ([c (read-char in)])
-         (cond
-           [(eof-object? c) null]
-           [else
-            (case c
-              [(#\')
-               (let until-quote ()
-                 (let ([c (read-char in)])
-                   (cond
-                     [(eof-object? c) (error 'parse-word "missing close '")]
-                     [else (case c
-                             [(#\') (parse-word)]
-                             [else (cons c (until-quote))])])))]
-              [(#\")
-               (let until-double-quote ()
-                 (let ([c (read-char in)])
-                   (cond
-                     [(eof-object? c) (error 'parse-word "missing close \"")]
-                     [else (case c
-                             [(#\") (parse-word)]
-                             [(#\\)
-                              (let ([escaped-char (read-char in)])
-                                (cond
-                                  [(eof-object? escaped-char)
-                                   (error 'parse-word "backslash at end of string")]
-                                  [else (cons escaped-char (until-double-quote))]))]
-                             [else (cons c (until-double-quote))])])))]
-              [(#\\)
-               (let ([escaped-char (read-char in)])
-                 (cond
-                   [(eof-object? escaped-char)
-                    (error 'parse-word "backslash at end of string")]
-                   [else (cons escaped-char (parse-word))]))]
-              [(#\space #\tab) null]
-              [else (cons c (parse-word))])])))))
-  
-  ;  > (parse-word (open-input-string "a'b\\c\"d'ef\" g\\h\"\\i jkl"))
-  ; (#\a #\b #\\ #\c #\" #\d #\e #\f #\space #\g #\h #\i)
-  )