From 6f17b84706e3cbb67c527c220cd40c0ca01a2446 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 30 Jan 2010 16:51:24 +0000 Subject: [PATCH] improved the module langauge's name printing svn: r17895 --- collects/drscheme/private/module-language.ss | 28 +++++++++++++------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index be1b0ab6da..60383f5b64 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -62,15 +62,25 @@ (inherit get-language-name) (define/public (get-users-language-name defs-text) - (let* ([i (open-input-text-editor defs-text)] - [l (with-handlers ((exn:fail? (λ (x) '?))) - (read-language i (lambda () '?)))]) - (if (eq? '? l) - (get-language-name) - (regexp-replace #rx".*#(?:!|lang ) *" - (send defs-text get-text 0 (file-position i)) - "")))) - + (let ([defs-port (open-input-text-editor defs-text)]) + (with-handlers ((exn:fail? (λ (x) (void)))) + (let/ec k + (let ([orig-security (current-security-guard)]) + (parameterize ([current-security-guard + (make-security-guard + orig-security + (lambda (what path modes) #t) + (lambda (what host port mode) (k (void))))]) + (read-language defs-port (λ () (void))) + (void))))) + (let* ([str (send defs-text get-text 0 (file-position defs-port))] + [pos (regexp-match-positions #rx"#(?:!|lang )" str)]) + (cond + [(not pos) + (get-language-name)] + [else + (substring str (cdr (car pos)) (string-length str))])))) + (define/override (use-namespace-require/copy?) #f) (define/augment (capability-value key)