commit f0af5303b36976d1d8b66b1bff40bdf19dc68f35
parent a2c22fe05b33050ce6dc16f87eb039a2740a22d3
Author: Eli Barzilay <eli@barzilay.org>
Date: Sat, 26 Jun 2010 16:40:12 -0400
Avoid changing the parameter value, so it is possible to extend it.
original commit: 95c49e138eb1a2040e6d5b3bcd059dd093c780bc
Diffstat:
1 file changed, 16 insertions(+), 10 deletions(-)
diff --git a/collects/meta/web/html/resource.rkt b/collects/meta/web/html/resource.rkt
@@ -43,25 +43,31 @@
;; 'abs is used below for roots that should always use absolute links (needed
;; for some skeleton pages that are used in nested subdirectories).
(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
;; 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
;; as-is before the path with a "/" between them).
- (make-parameter #f
- (lambda (x)
- (and (list? x) (pair? x)
- (map (lambda (x)
- (list* (regexp-match* #rx"[^/]+" (car x))
- (regexp-replace #rx"/$" (cadr x) "")
- (cddr x)))
- x)))))
+ (let ([roots (url-roots)])
+ (unless (eq? roots (car cached-roots))
+ (set! cached-roots
+ (cons roots
+ (and (list? roots) (pair? roots)
+ (map (lambda (root)
+ (list* (regexp-match* #rx"[^/]+" (car root))
+ (regexp-replace #rx"/$" (cadr root) "")
+ (cddr root)))
+ roots)))))
+ (cdr cached-roots)))
;; a utility for relative paths, taking the above `default-file' and
;; `url-roots' into consideration.
(define (relativize file tgtdir curdir)
(define file* (if (equal? file default-file) "" file))
- (define roots (url-roots))
+ (define roots (current-url-roots))
(define (find-root path mode)
(ormap (lambda (root+url+flags)
(let loop ([r (car root+url+flags)] [p path])
