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

scribble: encode URLs in 'unreserved mode

Browse Source 
original commit: 130c989888e3ac596fc5c5ac73c3493fd3bb924c
This commit is contained in:
Matthew Flatt 2012-12-17 07:09:27 -07:00
parent 4f1eae99b6
commit 042f013e13
1 changed files with 14 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/scribble/html-render.rkt
View File

@ -15,6 +15,7 @@
setup/main-collects setup/main-collects
setup/dirs setup/dirs
net/url net/url
net/uri-codec
net/base64 net/base64
scheme/serialize scheme/serialize
(prefix-in xml: xml/xml) (prefix-in xml: xml/xml)
@ -64,7 +65,7 @@
(cond [(bytes? file) (cond [(bytes? file)
(make-inline (bytes->string/utf-8 file))] (make-inline (bytes->string/utf-8 file))]
[(url? file) [(url? file)
(make-ref (url->string file))] (make-ref (url->string* file))]
[(not (eq? 'inline path)) [(not (eq? 'inline path))
(make-ref (or path (let-values ([(base name dir?) (make-ref (or path (let-values ([(base name dir?)
(split-path file)]) (split-path file)])
@ -94,6 +95,10 @@
(define current-version (make-parameter (version))) (define current-version (make-parameter (version)))
(define current-part-files (make-parameter #f)) (define current-part-files (make-parameter #f))
(define (url->string* u)
(parameterize ([current-url-encode-mode 'unreserved])
(url->string u)))
;; HTML anchors should be case-insensitively unique. To make them ;; HTML anchors should be case-insensitively unique. To make them
;; distinct, add a "." in front of capital letters. Also clean up ;; distinct, add a "." in front of capital letters. Also clean up
;; characters that give browsers trouble (i.e., the ones that are not ;; characters that give browsers trouble (i.e., the ones that are not
@ -353,7 +358,7 @@
rel)) rel))
=> (lambda (rel) => (lambda (rel)
(cons (cons
(url->string (url->string*
(struct-copy (struct-copy
url url
(combine-url/relative (combine-url/relative
@ -397,7 +402,8 @@
(if (dest-page? dest) "" "#") (if (dest-page? dest) "" "#")
(if (dest-page? dest) (if (dest-page? dest)
"" ""
(anchor-name (dest-anchor dest)))) (uri-unreserved-encode
(anchor-name (dest-anchor dest)))))
"???")) "???"))
(define/public (render-toc-view d ri) (define/public (render-toc-view d ri)
@ -798,7 +804,7 @@
[(equal? x "index.html") (values x "the manual top")] [(equal? x "index.html") (values x "the manual top")]
[(equal? x "../index.html") (values x "the documentation top")] [(equal? x "../index.html") (values x "the documentation top")]
[(string? x) (values x #f)] [(string? x) (values x #f)]
[(path? x) (values (url->string (path->url x)) #f)] [(path? x) (values (url->string* (path->url x)) #f)]
[else (error 'navigation "internal error ~e" x)])) [else (error 'navigation "internal error ~e" x)]))
(define title* (define title*
(if (and tfrom (part? tfrom)) (if (and tfrom (part? tfrom))
@ -818,7 +824,7 @@
(define top-link (define top-link
(titled-url (titled-url
"up" (if (path? up-path) "up" (if (path? up-path)
(url->string (path->url up-path)) (url->string* (path->url up-path))
"../index.html") "../index.html")
`[onclick . ,(format "return GotoPLTRoot(\"~a\");" (version))])) `[onclick . ,(format "return GotoPLTRoot(\"~a\");" (version))]))
(define navleft (define navleft
@ -1070,7 +1076,7 @@
null])))])]) null])))])])
(let ([srcref (let ([p (install-file src)]) (let ([srcref (let ([p (install-file src)])
(if (path? p) (if (path? p)
(url->string (path->url (path->complete-path p))) (url->string* (path->url (path->complete-path p)))
p))]) p))])
`((,(if svg? 'object 'img) `((,(if svg? 'object 'img)
([,(if svg? 'data 'src) ,srcref] ([,(if svg? 'data 'src) ,srcref]
@ -1118,7 +1124,7 @@
(and (relative-path? rel) (and (relative-path? rel)
rel))) rel)))
=> (lambda (rel) => (lambda (rel)
(url->string (url->string*
(struct-copy (struct-copy
url url
(combine-url/relative (combine-url/relative
@ -1135,7 +1141,7 @@
(anchor-name (dest-anchor dest)))])))] (anchor-name (dest-anchor dest)))])))]
[(and ext? external-tag-path) [(and ext? external-tag-path)
;; Redirected to search: ;; Redirected to search:
(url->string (url->string*
(let ([u (string->url external-tag-path)]) (let ([u (string->url external-tag-path)])
(struct-copy (struct-copy
url url