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

I eliminated junk output from browser that looked ugly and interacted poorly

Browse Source 
with DrScheme's IO.

I also fixed the way ports are closed so netscape on ccs.neu.edu works.

original commit: 17adf03ccc4f3150fed816ffb47f708435c791ac
This commit is contained in:
Paul Graunke 2002-02-15 17:44:47 +00:00
parent f45a994a2a
commit 549c0585aa
1 changed files with 91 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

142
collects/net/sendurl.ss
View File

@ -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)))))