153 lines
6.2 KiB
Scheme
153 lines
6.2 KiB
Scheme
(module sendurl mzscheme
|
|
(require (lib "process.ss")
|
|
(lib "file.ss")
|
|
(lib "kw.ss")
|
|
(lib "port.ss")
|
|
(lib "sendevent.ss"))
|
|
|
|
(provide send-url unix-browser-list browser-preference? external-browser)
|
|
|
|
(define separate-by-default?
|
|
(get-preference 'new-browser-for-urls (lambda () #t)))
|
|
|
|
; : any -> bool
|
|
(define (custom-browser? x)
|
|
(and (pair? x) (string? (car x)) (string? (cdr x))))
|
|
|
|
; : any -> bool
|
|
(define (browser-preference? x)
|
|
(or (not x) (eq? 'plt x) (memq x unix-browser-list) (custom-browser? x)
|
|
(procedure? x)))
|
|
|
|
(define external-browser
|
|
(make-parameter
|
|
#f ; #f means "consult the preferences file"
|
|
(lambda (x)
|
|
(if (browser-preference? x)
|
|
x
|
|
(error 'external-browser "~a is not a valid browser preference" x)))))
|
|
|
|
(define osx-browser?
|
|
(delay (or (eq? (system-type) 'macosx)
|
|
(equal? "ppc-darwin" (path->string (system-library-subpath))))))
|
|
|
|
; send-url : str [bool] -> void
|
|
(define/kw (send-url url-str
|
|
#:optional [separate-window? separate-by-default?])
|
|
(define external (external-browser))
|
|
(define stype (system-type))
|
|
(cond
|
|
[(procedure? external) (external url-str)]
|
|
[(force osx-browser?)
|
|
;; not sure what changed, but this is wrong now.... -robby
|
|
;; (browser-process (format "osascript -e 'open location \"~a\"'"
|
|
;; (regexp-replace* "%" url-str "%25")))
|
|
(browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
|
|
[(eq? stype 'windows)
|
|
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
|
|
[(eq? stype 'unix)
|
|
(let ([preferred (or external (get-preference 'external-browser))])
|
|
(cond
|
|
[(use-browser 'opera preferred)
|
|
=>
|
|
(lambda (exe)
|
|
;; opera may not return -- always open asyncronously
|
|
;; opera starts a new browser automatically, if it can't find one
|
|
(browser-process* exe "-remote"
|
|
(format "openURL(~a)"
|
|
(if separate-window?
|
|
(format "~a,new-window" url-str)
|
|
url-str))))]
|
|
[(use-browser 'galeon preferred)
|
|
=>
|
|
(lambda (exe)
|
|
(browser-process* exe (if separate-window? "-w" "-x") url-str))]
|
|
[(or (use-browser 'netscape preferred)
|
|
(use-browser 'mozilla preferred))
|
|
=>
|
|
(lambda (exe)
|
|
;; netscape's -remote returns with an error code, if no
|
|
;; netscape is around. start a new netscape in that case.
|
|
(or (system* exe "-remote"
|
|
(format "openURL(~a)"
|
|
(if separate-window?
|
|
(format "~a,new-window" url-str)
|
|
url-str)))
|
|
(browser-process* exe url-str)))]
|
|
[(use-browser 'dillo preferred)
|
|
=>
|
|
(lambda (exe) (browser-process* exe url-str))]
|
|
[(custom-browser? preferred)
|
|
(let ([cmd (string-append (car preferred)
|
|
url-str
|
|
(cdr preferred))])
|
|
(browser-process cmd))]
|
|
[else
|
|
(error 'send-url "Couldn't find ~a to open URL: ~e"
|
|
(orify unix-browser-list) url-str)]))]
|
|
#; ; macos is dead -- this code should be removed if nobody shouts
|
|
[(eq? stype 'macos)
|
|
(if (regexp-match "Blue Box" (system-type 'machine))
|
|
;; Classic inside OS X:
|
|
(let loop ([l '("MSIE" "NAVG")])
|
|
(if (null? l)
|
|
(error 'send-url "couldn't start Internet Explorer or Netscape")
|
|
(with-handlers ([exn:fail? (lambda (x) (loop (cdr l)))])
|
|
(subprocess #f #f #f "by-id" (car l))
|
|
(let loop ([retries 2]) ;; <<< Yuck <<<
|
|
(if (zero? retries)
|
|
(error "enough already") ; caught above
|
|
(with-handlers ([exn:fail?
|
|
(lambda (x) (loop (sub1 retries)))])
|
|
(let ([t (thread
|
|
(lambda ()
|
|
(send-event (car l) "GURL" "GURL" url-str)))])
|
|
(sync/timeout 1 t) ;; <<< Yuck (timeout) <<<
|
|
(when (thread-running? t)
|
|
(kill-thread t)
|
|
(error "timeout")))))))))
|
|
;; Normal OS Classic:
|
|
(send-event "MACS" "GURL" "GURL" url-str))]
|
|
[else (error 'send-url
|
|
"don't know how to open URL on platform: ~s" stype)]))
|
|
|
|
(define unix-browser-list '(opera galeon netscape mozilla dillo))
|
|
|
|
; : (cons tst (listof tst)) -> str
|
|
(define (orify l)
|
|
(cond
|
|
[(null? (cdr l)) (format "~a" (car l))]
|
|
[(null? (cddr l)) (format "~a or ~a" (car l) (cadr l))]
|
|
[else
|
|
(let loop ([l l])
|
|
(cond
|
|
[(null? (cdr l)) (format "or ~a" (car l))]
|
|
[else (string-append (format "~a, " (car l)) (loop (cdr l)))]))]))
|
|
|
|
; : sym sym -> (U #f str)
|
|
; to find the path for the named browser, unless another browser is preferred
|
|
(define (use-browser browser-name preferred)
|
|
(and (or (not preferred)
|
|
(eq? preferred browser-name))
|
|
(find-executable-path (symbol->string browser-name) #f)))
|
|
|
|
;; 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
|
|
(open-output-nowhere) #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)))
|
|
|
|
(define (browser-process* . args)
|
|
(run-browser process*/ports args))
|
|
|
|
(define (browser-process . args)
|
|
(run-browser process/ports args)))
|