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 (module sendurl mzscheme
(require (lib "process.ss") (require (lib "process.ss")
(lib "file.ss")) (lib "file.ss"))
(provide send-url) (provide send-url)
; send-url : str -> void
(define (send-url str) (define (send-url str)
(case (system-type) (parameterize ([current-input-port null-input]
[(macos macosx) [current-error-port null-output] ; comment out this line to see error messages
(send-event "MACS" "GURL" "GURL" str)] ;; actually, I think GURL means something slightly different... [current-output-port null-output])
[(windows) (case (system-type)
;; Try to get a MrEd function... [(macos macosx)
(let ([get-res (with-handlers ([not-break-exn? (lambda (x) #f)]) ;; actually, I think GURL means something slightly different...
(dynamic-require '(lib "mred.ss" "mred") 'get-resource))]) (send-event "MACS" "GURL" "GURL" str)]
(if get-res [(windows)
(let ([b (box "")]) ;; Try to get a MrEd function...
(unless (get-res "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command" b) (let ([get-res (with-handlers ([not-break-exn? (lambda (x) #f)])
(error 'send-url "couldn't find URL opener in the registry")) (dynamic-require '(lib "mred.ss" "mred") 'get-resource))])
(let-values ([(out in id err status) (apply (if get-res
values (let ([b (box "")])
(process (format "~a ~a" (unbox b) str)))]) (unless (get-res "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command" b)
(close-output-port in) (error 'send-url "couldn't find URL opener in the registry"))
(close-input-port out) (let-values ([(out in id err status) (apply
(close-input-port err))) values
(error 'send-url "don't know how to open URL in Windows without MrEd")))] (process (format "~a ~a" (unbox b) str)))])
[(unix) (close-output-port in)
(let ([preferred (get-preference 'external-browser (lambda () #f))]) (close-input-port out)
(cond (close-input-port err)))
[(and (or (not preferred) (error 'send-url "don't know how to open URL in Windows without MrEd")))]
(eq? preferred 'opera)) [(unix)
(find-executable-path "opera" #f)) (let ([preferred (get-preference 'external-browser (lambda () #f))])
=> (cond
(lambda (browser-path) [(and (or (not preferred)
;; opera may not return -- always open asyncronously (eq? preferred 'opera))
;; opera starts a new browser automatically, if it can't find one (find-executable-path "opera" #f))
(let-values ([(out in id err status) =>
(apply (lambda (browser-path)
values ;; opera may not return -- always open asyncronously
(process* browser-path "-remote" (format "openURL(~a,new-window)" str)))]) ;; opera starts a new browser automatically, if it can't find one
(close-output-port in) ;; We no longer pass ,new-window since the teachpack always calls send-url now.
(close-input-port out) (process*/close-ports browser-path "-remote" (format "openURL(~a)" str)))]
(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)) =>
=> (lambda (browser-path)
(lambda (browser-path) ;; 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)) (process*/close-ports browser-path str)))]
(let-values ([(out in id err status) (apply values (process* browser-path str))]) [else
(close-output-port in) (error 'open-url "Couldn't find Netscape or Opera to open URL: ~e" str)]))]
(close-input-port out) [else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))])))
(close-input-port err))))]
[else ; null-input : iport
(error 'open-url "Couldn't find Netscape or Opera to open URL: ~e" str)]))] (define null-input
[else (error 'send-url "don't know how to open URL on platform: ~s" (system-type))]))) (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)))))