diff --git a/collects/meta/web/html/resource.rkt b/collects/meta/web/html/resource.rkt index 0047f9ab..774a299c 100644 --- 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]) @@ -194,7 +200,13 @@ (add-renderer path render) (make-keyword-procedure (lambda (kws kvs . args) (keyword-apply referrer kws kvs (url) args)) - (lambda args (apply referrer (url) args))))) + (case-lambda [(x) (if (eq? x get-resource-path) (url) (referrer (url) x))] + [args (apply referrer (url) args)])))) + +;; make it possible to always get the path to a resource +(provide get-resource-path) +(define (get-resource-path resource) + (resource get-resource-path)) ;; a convenient utility to create renderers from some output function (like ;; `output-xml' or `display') and some content diff --git a/collects/meta/web/html/xml.rkt b/collects/meta/web/html/xml.rkt index 09c92e0c..d5e0a03a 100644 --- a/collects/meta/web/html/xml.rkt +++ b/collects/meta/web/html/xml.rkt @@ -37,6 +37,15 @@ "missing attribute value for `~s:'" a)] [else (loop (cddr xs) (cons (cons a (cadr xs)) as))])))) +;; similar, but keeps the attributes as a list, useful to build new functions +;; that accept attributes without knowing about the xml structs. +(provide split-attributes+body) +(define (split-attributes+body xs) + (let loop ([xs xs] [as '()]) + (if (and (pair? xs) (pair? (cdr xs)) (attribute->symbol (car xs))) + (loop (cddr xs) (list* (cadr xs) (car xs) as)) + (values (reverse as) xs)))) + ;; ---------------------------------------------------------------------------- ;; An output that handles xml quoting, customizable diff --git a/collects/scribble/doclang.rkt b/collects/scribble/doclang.rkt index 6e74a799..298659eb 100644 --- a/collects/scribble/doclang.rkt +++ b/collects/scribble/doclang.rkt @@ -1,11 +1,11 @@ -#lang scheme/base +#lang racket/base (require "struct.ss" "decode.ss" - (for-syntax scheme/base + (for-syntax racket/base syntax/kerncase)) -(provide (except-out (all-from-out scheme/base) #%module-begin) +(provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [*module-begin #%module-begin])) ;; Module wrapper ---------------------------------------- diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index da1901ce..ca02c0d9 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -141,7 +141,7 @@ expressions. }===| The command part of an @"@"-form is optional as well. In that case, -the @"@" forms is read as a list, which usually counts as a function +the @"@" form is read as a list, which usually counts as a function application, but it also useful when quoted with the usual Racket @racket[quote]: