Eli Barzilay
parent
50108948b0
commit
88a4e688bf
|
|
@ -1,142 +1,141 @@
|
|||
;; 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"))
|
||||
#lang scheme/base
|
||||
|
||||
(provide send-url unix-browser-list browser-preference? external-browser)
|
||||
(require scheme/system
|
||||
scheme/file
|
||||
scheme/promise
|
||||
scheme/port)
|
||||
|
||||
(define separate-by-default?
|
||||
(get-preference 'new-browser-for-urls (lambda () #t)))
|
||||
(provide send-url unix-browser-list browser-preference? external-browser)
|
||||
|
||||
(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 (custom-browser? x)
|
||||
(and (pair? x) (string? (car x)) (string? (cdr x))))
|
||||
(define unix-browser-list
|
||||
'(gnome-open firefox galeon opera netscape mozilla dillo))
|
||||
|
||||
;; : any -> bool
|
||||
(define (browser-preference? x)
|
||||
(or (not x) (eq? 'plt x) (memq x unix-browser-list) (custom-browser? x)
|
||||
(procedure? x)))
|
||||
;; : any -> bool
|
||||
(define (custom-browser? x)
|
||||
(and (pair? x) (string? (car x)) (string? (cdr 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)))))
|
||||
;; : any -> bool
|
||||
(define (browser-preference? x)
|
||||
(or (not x) (eq? 'plt x) (memq x unix-browser-list) (custom-browser? x)
|
||||
(procedure? 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]))))
|
||||
(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)))))
|
||||
|
||||
; 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 "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))
|
||||
;; 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]))))
|
||||
|
||||
;; 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)))
|
||||
;; send-url : str [bool] -> void
|
||||
(define (send-url url-str [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 "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*/ports args))
|
||||
;; 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))
|
||||
|
||||
(define (browser-process . args)
|
||||
(run-browser process/ports args))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user