Avoid changing the parameter value, so it is possible to extend it.
This commit is contained in:
parent
fdb8751de3
commit
95c49e138e
|
@ -43,25 +43,31 @@
|
||||||
;; 'abs is used below for roots that should always use absolute links (needed
|
;; 'abs is used below for roots that should always use absolute links (needed
|
||||||
;; for some skeleton pages that are used in nested subdirectories).
|
;; for some skeleton pages that are used in nested subdirectories).
|
||||||
(provide url-roots)
|
(provide url-roots)
|
||||||
(define url-roots
|
(define url-roots (make-parameter #f))
|
||||||
|
|
||||||
|
(define cached-roots '(#f . #f))
|
||||||
|
(define (current-url-roots)
|
||||||
;; takes in a (listof (list prefix-string url-string . flags)), and produces
|
;; takes in a (listof (list prefix-string url-string . flags)), and produces
|
||||||
;; an alist with lists of strings for the keys; the prefix-strings are split
|
;; an alist with lists of strings for the keys; the prefix-strings are split
|
||||||
;; on "/"s, and the url-strings can be anything at all actually (they are put
|
;; on "/"s, and the url-strings can be anything at all actually (they are put
|
||||||
;; as-is before the path with a "/" between them).
|
;; as-is before the path with a "/" between them).
|
||||||
(make-parameter #f
|
(let ([roots (url-roots)])
|
||||||
(lambda (x)
|
(unless (eq? roots (car cached-roots))
|
||||||
(and (list? x) (pair? x)
|
(set! cached-roots
|
||||||
(map (lambda (x)
|
(cons roots
|
||||||
(list* (regexp-match* #rx"[^/]+" (car x))
|
(and (list? roots) (pair? roots)
|
||||||
(regexp-replace #rx"/$" (cadr x) "")
|
(map (lambda (root)
|
||||||
(cddr x)))
|
(list* (regexp-match* #rx"[^/]+" (car root))
|
||||||
x)))))
|
(regexp-replace #rx"/$" (cadr root) "")
|
||||||
|
(cddr root)))
|
||||||
|
roots)))))
|
||||||
|
(cdr cached-roots)))
|
||||||
|
|
||||||
;; a utility for relative paths, taking the above `default-file' and
|
;; a utility for relative paths, taking the above `default-file' and
|
||||||
;; `url-roots' into consideration.
|
;; `url-roots' into consideration.
|
||||||
(define (relativize file tgtdir curdir)
|
(define (relativize file tgtdir curdir)
|
||||||
(define file* (if (equal? file default-file) "" file))
|
(define file* (if (equal? file default-file) "" file))
|
||||||
(define roots (url-roots))
|
(define roots (current-url-roots))
|
||||||
(define (find-root path mode)
|
(define (find-root path mode)
|
||||||
(ormap (lambda (root+url+flags)
|
(ormap (lambda (root+url+flags)
|
||||||
(let loop ([r (car root+url+flags)] [p path])
|
(let loop ([r (car root+url+flags)] [p path])
|
||||||
|
|
Loading…
Reference in New Issue
Block a user