Eli Barzilay
parent
50108948b0
commit
88a4e688bf
|
|
@ -1,142 +1,141 @@
|
||||||
;; The main client of this module is browser/external.ss
|
;; The main client of this module is browser/external.ss
|
||||||
;; (others just use the (send-url url [new?]) interface.)
|
;; (others just use the (send-url url [new?]) interface.)
|
||||||
|
|
||||||
(module sendurl mzscheme
|
#lang scheme/base
|
||||||
(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)
|
(require scheme/system
|
||||||
|
scheme/file
|
||||||
|
scheme/promise
|
||||||
|
scheme/port)
|
||||||
|
|
||||||
(define separate-by-default?
|
(provide send-url unix-browser-list browser-preference? external-browser)
|
||||||
(get-preference 'new-browser-for-urls (lambda () #t)))
|
|
||||||
|
|
||||||
(define unix-browser-list '(gnome-open firefox galeon opera netscape mozilla dillo))
|
(define separate-by-default?
|
||||||
|
(get-preference 'new-browser-for-urls (lambda () #t)))
|
||||||
|
|
||||||
;; : any -> bool
|
(define unix-browser-list
|
||||||
(define (custom-browser? x)
|
'(gnome-open firefox galeon opera netscape mozilla dillo))
|
||||||
(and (pair? x) (string? (car x)) (string? (cdr x))))
|
|
||||||
|
|
||||||
;; : any -> bool
|
;; : any -> bool
|
||||||
(define (browser-preference? x)
|
(define (custom-browser? x)
|
||||||
(or (not x) (eq? 'plt x) (memq x unix-browser-list) (custom-browser? x)
|
(and (pair? x) (string? (car x)) (string? (cdr x))))
|
||||||
(procedure? x)))
|
|
||||||
|
|
||||||
(define external-browser
|
;; : any -> bool
|
||||||
(make-parameter
|
(define (browser-preference? x)
|
||||||
#f ; #f means "consult the preferences file"
|
(or (not x) (eq? 'plt x) (memq x unix-browser-list) (custom-browser? x)
|
||||||
(lambda (x)
|
(procedure? 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
|
(define external-browser
|
||||||
;; (could do the same for Cygwin, but that it doesn't have shell-execute)
|
(make-parameter
|
||||||
(define systype
|
#f ; #f means "consult the preferences file"
|
||||||
(delay (let ([t (system-type)])
|
(lambda (x)
|
||||||
(cond [(not (eq? t 'unix)) t]
|
(if (browser-preference? x)
|
||||||
[(regexp-match? #rx"-darwin($|/)"
|
x
|
||||||
(path->string (system-library-subpath)))
|
(error 'external-browser "~e is not a valid browser preference" x)))))
|
||||||
'macosx]
|
|
||||||
[else t]))))
|
|
||||||
|
|
||||||
; send-url : str [bool] -> void
|
;; like (system-type), but return the real OS for OSX with XonX
|
||||||
(define/kw (send-url url-str
|
;; (could do the same for Cygwin, but that it doesn't have shell-execute)
|
||||||
#:optional [separate-window? separate-by-default?])
|
(define systype
|
||||||
(define stupid-internal-define-syntax1
|
(delay (let ([t (system-type)])
|
||||||
(unless (string? url-str)
|
(cond [(not (eq? t 'unix)) t]
|
||||||
(error 'send-url "expected a string, got ~e" url-str)))
|
[(regexp-match? #rx"-darwin($|/)"
|
||||||
(define external (external-browser))
|
(path->string (system-library-subpath)))
|
||||||
(define stype (force systype))
|
'macosx]
|
||||||
(define preferred '|? ? ?|)
|
[else t]))))
|
||||||
(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 "osascript -e 'open location \"~a\"'" url-str))]
|
|
||||||
[(eq? stype 'windows)
|
|
||||||
(let ([simple
|
|
||||||
(lambda ()
|
|
||||||
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL))])
|
|
||||||
(if (regexp-match #rx"#" url-str)
|
|
||||||
;; complex case: need to launch the browser directly,
|
|
||||||
;; otherwise the fragment is ignored. Use `ftype' to discover
|
|
||||||
;; the browser...
|
|
||||||
(let ([p (process "ftype htmlfile")])
|
|
||||||
(close-output-port (cadr p))
|
|
||||||
(let ([s (read-line (car p) 'return-linefeed)])
|
|
||||||
(close-input-port (car p))
|
|
||||||
(close-input-port (cadddr p))
|
|
||||||
(let ([m (regexp-match #rx"^htmlfile=(.*)" s)])
|
|
||||||
(if m
|
|
||||||
(browser-process (string-append (cadr m) " " url-str))
|
|
||||||
;; give up and use simple mode
|
|
||||||
(simple)))))
|
|
||||||
;; simple case: no fragment
|
|
||||||
(simple)))]
|
|
||||||
[(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))]
|
|
||||||
[(use-browser 'gnome-open)
|
|
||||||
=> (lambda (exe)
|
|
||||||
(browser-process* exe 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)])
|
|
||||||
(void))
|
|
||||||
|
|
||||||
;; run-browser : process-proc list-of-strings -> void
|
;; send-url : str [bool] -> void
|
||||||
(define (run-browser process*/ports args)
|
(define (send-url url-str [separate-window? separate-by-default?])
|
||||||
(let-values ([(stdout stdin pid stderr control)
|
(define stupid-internal-define-syntax1
|
||||||
(apply values
|
(unless (string? url-str)
|
||||||
(apply process*/ports
|
(error 'send-url "expected a string, got ~e" url-str)))
|
||||||
(open-output-nowhere) #f (current-error-port)
|
(define external (external-browser))
|
||||||
args))])
|
(define stype (force systype))
|
||||||
(close-output-port stdin)
|
(define preferred '|? ? ?|)
|
||||||
(thread (lambda ()
|
(define (use-browser browser-name)
|
||||||
(control 'wait)
|
(when (eq? preferred '|? ? ?|)
|
||||||
(when (eq? 'done-error (control 'status))
|
(set! preferred (or external (get-preference 'external-browser))))
|
||||||
(error 'run-browser "process execute failed: ~e" args))))
|
(and (or (not preferred) (eq? preferred browser-name))
|
||||||
(void)))
|
(find-executable-path (symbol->string browser-name) #f)))
|
||||||
|
(cond
|
||||||
|
[(procedure? external) (external url-str)]
|
||||||
|
[(eq? stype 'macosx)
|
||||||
|
(browser-process (format "osascript -e 'open location \"~a\"'" url-str))]
|
||||||
|
[(eq? stype 'windows)
|
||||||
|
(let ([simple
|
||||||
|
(lambda ()
|
||||||
|
(shell-execute #f url-str "" (current-directory) 'SW_SHOWNORMAL))])
|
||||||
|
(if (regexp-match #rx"#" url-str)
|
||||||
|
;; complex case: need to launch the browser directly,
|
||||||
|
;; otherwise the fragment is ignored. Use `ftype' to discover
|
||||||
|
;; the browser...
|
||||||
|
(let ([p (process "ftype htmlfile")])
|
||||||
|
(close-output-port (cadr p))
|
||||||
|
(let ([s (read-line (car p) 'return-linefeed)])
|
||||||
|
(close-input-port (car p))
|
||||||
|
(close-input-port (cadddr p))
|
||||||
|
(let ([m (regexp-match #rx"^htmlfile=(.*)" s)])
|
||||||
|
(if m
|
||||||
|
(browser-process (string-append (cadr m) " " url-str))
|
||||||
|
;; give up and use simple mode
|
||||||
|
(simple)))))
|
||||||
|
;; simple case: no fragment
|
||||||
|
(simple)))]
|
||||||
|
[(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))]
|
||||||
|
[(use-browser 'gnome-open)
|
||||||
|
=> (lambda (exe) (browser-process* exe 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)])
|
||||||
|
(void))
|
||||||
|
|
||||||
(define (browser-process* . args)
|
;; run-browser : process-proc list-of-strings -> void
|
||||||
(run-browser process*/ports args))
|
(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)
|
(define (browser-process* . args)
|
||||||
(run-browser process/ports args)))
|
(run-browser process*/ports args))
|
||||||
|
|
||||||
|
(define (browser-process . args)
|
||||||
|
(run-browser process/ports args))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user