From 549c0585aa06b712ab7de50096de5d2b15e93d26 Mon Sep 17 00:00:00 2001 From: Paul Graunke Date: Fri, 15 Feb 2002 17:44:47 +0000 Subject: [PATCH] I eliminated junk output from browser that looked ugly and interacted poorly with DrScheme's IO. I also fixed the way ports are closed so netscape on ccs.neu.edu works. original commit: 17adf03ccc4f3150fed816ffb47f708435c791ac --- collects/net/sendurl.ss | 142 +++++++++++++++++++++++++--------------- 1 file changed, 91 insertions(+), 51 deletions(-) diff --git a/collects/net/sendurl.ss b/collects/net/sendurl.ss index 2aedbe5e54..99a8ab9d3b 100644 --- a/collects/net/sendurl.ss +++ b/collects/net/sendurl.ss @@ -2,57 +2,97 @@ (module sendurl mzscheme (require (lib "process.ss") (lib "file.ss")) - + (provide send-url) + ; send-url : str -> void (define (send-url str) - (case (system-type) - [(macos macosx) - (send-event "MACS" "GURL" "GURL" str)] ;; actually, I think GURL means something slightly different... - [(windows) - ;; Try to get a MrEd function... - (let ([get-res (with-handlers ([not-break-exn? (lambda (x) #f)]) - (dynamic-require '(lib "mred.ss" "mred") 'get-resource))]) - (if get-res - (let ([b (box "")]) - (unless (get-res "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command" b) - (error 'send-url "couldn't find URL opener in the registry")) - (let-values ([(out in id err status) (apply - values - (process (format "~a ~a" (unbox b) str)))]) - (close-output-port in) - (close-input-port out) - (close-input-port err))) - (error 'send-url "don't know how to open URL in Windows without MrEd")))] - [(unix) - (let ([preferred (get-preference 'external-browser (lambda () #f))]) - (cond - [(and (or (not preferred) - (eq? preferred 'opera)) - (find-executable-path "opera" #f)) - => - (lambda (browser-path) - ;; opera may not return -- always open asyncronously - ;; opera starts a new browser automatically, if it can't find one - (let-values ([(out in id err status) - (apply - values - (process* browser-path "-remote" (format "openURL(~a,new-window)" str)))]) - (close-output-port in) - (close-input-port out) - (close-input-port err)))] - [(and (and (or (not preferred) - (eq? preferred 'netscape))) - (find-executable-path "netscape" #f)) - => - (lambda (browser-path) - ;; netscape's -remote returns with an error code, if no - ;; netscape is around. start a new netscape in that case. - (or (system* browser-path "-remote" (format "openURL(~a)" str)) - (let-values ([(out in id err status) (apply values (process* browser-path str))]) - (close-output-port in) - (close-input-port out) - (close-input-port err))))] - [else - (error 'open-url "Couldn't find Netscape or Opera to open URL: ~e" str)]))] - [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))]))) + (parameterize ([current-input-port null-input] + [current-error-port null-output] ; comment out this line to see error messages + [current-output-port null-output]) + (case (system-type) + [(macos macosx) + ;; actually, I think GURL means something slightly different... + (send-event "MACS" "GURL" "GURL" str)] + [(windows) + ;; Try to get a MrEd function... + (let ([get-res (with-handlers ([not-break-exn? (lambda (x) #f)]) + (dynamic-require '(lib "mred.ss" "mred") 'get-resource))]) + (if get-res + (let ([b (box "")]) + (unless (get-res "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command" b) + (error 'send-url "couldn't find URL opener in the registry")) + (let-values ([(out in id err status) (apply + values + (process (format "~a ~a" (unbox b) str)))]) + (close-output-port in) + (close-input-port out) + (close-input-port err))) + (error 'send-url "don't know how to open URL in Windows without MrEd")))] + [(unix) + (let ([preferred (get-preference 'external-browser (lambda () #f))]) + (cond + [(and (or (not preferred) + (eq? preferred 'opera)) + (find-executable-path "opera" #f)) + => + (lambda (browser-path) + ;; opera may not return -- always open asyncronously + ;; opera starts a new browser automatically, if it can't find one + ;; We no longer pass ,new-window since the teachpack always calls send-url now. + (process*/close-ports browser-path "-remote" (format "openURL(~a)" str)))] + [(and (and (or (not preferred) + (eq? preferred 'netscape))) + (find-executable-path "netscape" #f)) + => + (lambda (browser-path) + ;; netscape's -remote returns with an error code, if no + ;; netscape is around. start a new netscape in that case. + (or (system* browser-path "-remote" (format "openURL(~a)" str)) + (process*/close-ports browser-path str)))] + [else + (error 'open-url "Couldn't find Netscape or Opera to open URL: ~e" str)]))] + [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))]))) + + ; null-input : iport + (define null-input + (make-input-port (lambda () eof) + (lambda () #t) + void)) + + ; null-output : oport + (define null-output + (make-output-port void void)) + + (define dev-null "/dev/null") ; unix specific, so slashes are okay + + ; process*/close-ports : [arg]* -> void + ; This is a funny hack. Closing unused scheme pipe ports right away closes + ; 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)))))