suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Added send-url/file that consumes a path and adds the file://, use

Browse Source 
that in places that show docs.

* Made send-url quote characters that are possibly dangerous for
  subprocesses (good uses should call it wil already quoted urls).
  Also a keyword argument that can disable this, if someone really
  wants to.

* IE7 bug workaround finally working (but will need to switch from
  regedit to mred, to avoid vista warning).

svn: r8467
This commit is contained in:
Eli Barzilay 2008-01-29 21:38:27 +00:00
parent 6ddbaba736
commit dbd27dafc6
3 changed files with 70 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/help/search.ss
View File

@ -18,11 +18,10 @@
[send-main-page (-> void?)])
(define (send-main-page)
(let ([user-dest-path (build-path (find-user-doc-dir) "index.html")]
[dest-path (build-path (find-doc-dir) "index.html")])
(send-url (format "file://~a" (path->string (if (file-exists? user-dest-path)
user-dest-path
dest-path))))))
(let* ([path (build-path (find-user-doc-dir) "index.html")]
[path (if (file-exists? path)
path (build-path (find-doc-dir) "index.html"))])
(send-url/file path)))
;; if there is exactly one exact match for this search key, go directly
;; to that place. Otherwise, go to a page that lists all of the matches.
@ -40,9 +39,7 @@
[else
(let ([match (car exact-matches)])
(let-values ([(path tag) (xref-tag->path+anchor x (entry-tag match))])
(send-url (format "file://~a~a"
(path->string path)
(if tag (string-append "#" (uri-encode tag)) "")))))])))
(send-url/file path #:fragment (uri-encode tag))))])))
(define (generate-search-results search-keys)
(let ([file (next-search-results-file)]
@ -75,7 +72,7 @@
(build-itemization "Exact matches" exact-matches)
(build-itemization "Containing matches" inexact-matches))]))))
file)
(send-url (format "file://~a" (path->string file)))
(send-url/file file)
(void))))
(define (make-extra-content desc)

83
collects/net/sendurl.ss
View File

@ -8,7 +8,8 @@
scheme/promise
scheme/port)
(provide send-url unix-browser-list browser-preference? external-browser)
(provide send-url send-url/file
unix-browser-list browser-preference? external-browser)
(define separate-by-default?
;; internal configuration, 'browser-default lets some browsers decide
@ -66,22 +67,25 @@
'macosx]
[else t]))))
;; used for quoting characters that will not work well in shell quotes
(define (quote-url url)
(define (escape str)
(apply string-append
(map (lambda (b)
(string-append
"%" (if (< b 16) "0" "") (number->string b 16)))
(bytes->list (string->bytes/utf-8 str)))))
(regexp-replace* #px"(?:[^[:graph:]]|[\"'`\\\\])" url escape))
(define (%escape str)
(apply string-append
(map (lambda (b)
(string-append "%" (if (< b 16) "0" "") (number->string b 16)))
(bytes->list (string->bytes/utf-8 str)))))
;; Used for quoting characters that will not work well in shell quotes, and
;; only these characters. This is only for protection when passing arguments
;; to subprocesses, it's best to pass properly escaped urls to `send-url'.
(define (escape-url url)
(regexp-replace* #px"(?:[^[:graph:]]|[\"'`\\\\])" url %escape))
;; send-url : str [bool] -> void
(define (send-url url-str [separate-window? separate-by-default?])
(define (send-url url-str [separate-window? separate-by-default?]
#:escape? [escape? #t])
(define stype (force systype))
(unless (string? url-str)
(error 'send-url "expected a string, got ~e" url-str))
(let ([url-str (quote-url url-str)])
(let ([url-str (if escape? (escape-url url-str) url-str)])
(if (procedure? (external-browser))
((external-browser) url-str)
(case stype
@ -92,6 +96,27 @@
"don't know how to open URL on platform: ~s" stype)])))
(void))
(define (send-url/file path [separate-window? separate-by-default?]
#:fragment [fragment #f] #:query [query #f])
(let* ([path (path->string (path->complete-path path))]
[path (if (eq? 'windows (force systype))
;; see http://msdn2.microsoft.com/en-us/library/ms775098.aspx
(let* ([path (regexp-replace* #rx"\\\\" path "/")]
[slashes (cdar (regexp-match-positions #rx"^/*" path))])
(case slashes
[(0) (string-append "/" path)]
[(1) (error 'send-url/file
"unexpected path, please submit a bug: ~s"
path)]
[else (substring path 2)]))
path)]
[path (regexp-replace* #rx"[^A-Za-z0-9_./:-]" path %escape)]
[path (string-append "file://" path)]
[path (if query (string-append path "?" (escape-url query)) path)]
[path (if fragment (string-append path "#" (escape-url fragment))
path)])
(send-url path separate-window? #:escape? #f)))
(define osascript (delay (find-exe "osascript")))
(define (send-url/mac url)
(browser-run (force osascript) "-e" (format "open location \"~a\"" url)))
@ -156,25 +181,36 @@
(define (using-ie7?)
(define (bytes0 bs)
(list->bytes (apply append (map (lambda (b) (list b 0)) (bytes->list bs)))))
(define (run cmd)
(define out (open-output-string))
(parameterize ([current-output-port out]
[current-input-port (open-input-string "")]
[current-error-port (open-output-nowhere)])
;; just return #f on errors, since we can still use
;; shell-execute in this case -- better a dropped anchor than no
;; help at all
(and (system cmd) (get-output-string out))))
(define (get-regdata)
(define regfile (make-temporary-file "registry-data-~a"))
(and (system (format "regedit /e \"~a\" \"~a" regfile
(regexp-replace* #rx"/" keypath "\\\\")))
(let ([x (file-size regfile)])
(begin0 (with-input-from-file regfile (lambda () (read-bytes x)))
(delete-file regfile)))))
(dynamic-wind
void
(lambda ()
(and (run (format "regedit /e \"~a\" \"~a\""
regfile
(regexp-replace* #rx"/" keypath "\\\\")))
(let ([n (file-size regfile)])
(with-input-from-file regfile (lambda () (read-bytes n))))))
(lambda () (delete-file regfile))))
(define keypath
"HKEY_LOCAL_MACHINE/Software/Microsoft/Internet Explorer/Version Vector")
(define version-rx
(bytes-append (bytes0 #"\r\n\"IE\"=\"") #"([0-9.\0]+)" (bytes0 #"\"\r\n")))
(and
;; Is IE the default browser?
(let ([p (process "ftype http")])
(close-output-port (cadr p))
(let ([s (read-line (car p) 'return-linefeed)])
(close-input-port (car p))
(close-input-port (cadddr p))
(regexp-match? #px"^(?i:http=\"(.*\\\\|)iexplore.exe\")" s)))
(cond [(run "ftype http")
=> (lambda (s)
(regexp-match? #px"^(?i:http=\"(.*\\\\|)iexplore.exe\")" s))]
[else #f])
;; Get the registry data and check the version. We could convert the UTF-16
;; result to UTF-8, but we're looking for a simple pattern, so just search
;; for the expected UTF-16 sequence directly.
@ -185,6 +221,7 @@
(define send-url/win-proc
(delay (let ([explorer (and (using-ie7?) (find-exe "explorer.exe"))])
(if explorer
;; looks like explorer.exe always returns an error code
(lambda (url) (browser-run #:ignore-exit-code #t explorer url))
(lambda (url)
(shell-execute #f url "" (current-directory) 'SW_SHOWNORMAL))))))

20
collects/scheme/help.ss
View File

@ -3,7 +3,7 @@
(require setup/xref
scribble/xref
scribble/manual-struct
net/url
net/uri-codec
net/sendurl
scheme/path
(for-syntax scheme/base))
@ -103,21 +103,9 @@
(define (go-to-tag xref t)
(let-values ([(file anchor) (xref-tag->path+anchor xref t)])
(printf "Sending to web browser...\n file: ~a\n"
file)
(when anchor
(printf " anchor: ~a\n" anchor))
(unless (send-url (url->string
(make-url "file"
#f #f #f #t
(map (lambda (s)
(make-path/param (if (absolute-path? s)
(path->string s)
(path-element->string s))
null))
(explode-path file))
null
anchor)))
(printf "Sending to web browser...\n file: ~a\n" file)
(when anchor (printf " anchor: ~a\n" anchor))
(unless (send-url/file file #:fragment (uri-encode anchor))
(error 'help "browser launch failed"))))
(define generate-search-results #f)