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

64
collects/net/sendurl.ss
View File

@ -5,10 +5,15 @@
(provide send-url) (provide send-url)
; send-url : str -> void
(define (send-url str) (define (send-url str)
(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) (case (system-type)
[(macos macosx) [(macos macosx)
(send-event "MACS" "GURL" "GURL" str)] ;; actually, I think GURL means something slightly different... ;; actually, I think GURL means something slightly different...
(send-event "MACS" "GURL" "GURL" str)]
[(windows) [(windows)
;; Try to get a MrEd function... ;; Try to get a MrEd function...
(let ([get-res (with-handlers ([not-break-exn? (lambda (x) #f)]) (let ([get-res (with-handlers ([not-break-exn? (lambda (x) #f)])
@ -34,13 +39,8 @@
(lambda (browser-path) (lambda (browser-path)
;; opera may not return -- always open asyncronously ;; opera may not return -- always open asyncronously
;; opera starts a new browser automatically, if it can't find one ;; opera starts a new browser automatically, if it can't find one
(let-values ([(out in id err status) ;; We no longer pass ,new-window since the teachpack always calls send-url now.
(apply (process*/close-ports browser-path "-remote" (format "openURL(~a)" str)))]
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) [(and (and (or (not preferred)
(eq? preferred 'netscape))) (eq? preferred 'netscape)))
(find-executable-path "netscape" #f)) (find-executable-path "netscape" #f))
@ -49,10 +49,50 @@
;; netscape's -remote returns with an error code, if no ;; netscape's -remote returns with an error code, if no
;; netscape is around. start a new netscape in that case. ;; netscape is around. start a new netscape in that case.
(or (system* browser-path "-remote" (format "openURL(~a)" str)) (or (system* browser-path "-remote" (format "openURL(~a)" str))
(let-values ([(out in id err status) (apply values (process* browser-path str))]) (process*/close-ports browser-path str)))]
(close-output-port in)
(close-input-port out)
(close-input-port err))))]
[else [else
(error 'open-url "Couldn't find Netscape or Opera to open URL: ~e" str)]))] (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))]))) [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)))))