121 lines
4.7 KiB
Scheme
121 lines
4.7 KiB
Scheme
;; The main client of this module is browser/external.ss
|
|
;; (others just use the (send-url url [new?]) interface.)
|
|
|
|
(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)))
|
|
|
|
(define unix-browser-list '(firefox galeon opera netscape mozilla dillo))
|
|
|
|
;; : 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 "~e is not a valid browser preference" x)))))
|
|
|
|
;; like (system-type), but return the real OS for OSX with XonX
|
|
;; (could do the same for Cygwin, but that it doesn't have shell-execute)
|
|
(define systype
|
|
(delay (let ([t (system-type)])
|
|
(cond [(not (eq? t 'unix)) t]
|
|
[(regexp-match? #rx"-darwin($|/)"
|
|
(path->string (system-library-subpath)))
|
|
'macosx]
|
|
[else t]))))
|
|
|
|
; send-url : str [bool] -> void
|
|
(define/kw (send-url url-str
|
|
#:optional [separate-window? separate-by-default?])
|
|
(define stupid-internal-define-syntax1
|
|
(unless (string? url-str)
|
|
(error 'send-url "expected a string, got ~e" url-str)))
|
|
(define external (external-browser))
|
|
(define stype (force systype))
|
|
(define preferred '|? ? ?|)
|
|
(define (use-browser browser-name)
|
|
(when (eq? preferred '|? ? ?|)
|
|
(set! preferred (or external (get-preference 'external-browser))))
|
|
(and (or (not preferred) (eq? preferred browser-name))
|
|
(find-executable-path (symbol->string browser-name) #f)))
|
|
(cond
|
|
[(procedure? external) (external url-str)]
|
|
[(eq? stype 'macosx)
|
|
(browser-process (format "open \"~a\"" url-str))]
|
|
[(eq? stype 'windows)
|
|
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL)]
|
|
[(not (eq? stype 'unix))
|
|
(error 'send-url "don't know how to open URL on platform: ~s" stype)]
|
|
;; unix
|
|
[(use-browser 'opera)
|
|
=> (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)
|
|
=> (lambda (exe)
|
|
(browser-process* exe (if separate-window? "-w" "-x") url-str))]
|
|
[(or (use-browser 'netscape)
|
|
(use-browser 'mozilla)
|
|
(use-browser 'firefox))
|
|
=> (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)
|
|
=> (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 browser to open URL: ~e" url-str)]))
|
|
|
|
;; 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)))
|