diff --git a/collects/drscheme/private/module-language-tools.ss b/collects/drscheme/private/module-language-tools.ss index 8baaff58b2..73bc52053d 100644 --- a/collects/drscheme/private/module-language-tools.ss +++ b/collects/drscheme/private/module-language-tools.ss @@ -9,6 +9,9 @@ scheme/gui/base "drsig.ss") +(define op (current-output-port)) +(define (oprintf . args) (apply fprintf op args)) + (define-unit module-language-tools@ (import [prefix drscheme:unit: drscheme:unit^] [prefix drscheme:module-language: drscheme:module-language^] @@ -18,7 +21,7 @@ (define-local-member-name initialized? move-to-new-language) - (define-struct opt-out-toolbar-button (make-button id)) + (define-struct opt-out-toolbar-button (make-button id) #:transparent) (define opt-out-toolbar-buttons '()) (define (add-opt-out-toolbar-button make-button id) @@ -98,18 +101,18 @@ (define/public (move-to-new-language) (let* ([port (open-input-text-editor this)] + ;; info-result : (or/c #f [#lang without a known language] + ;; (vector ) [no #lang line, so we use the '#lang racket' info proc] + ;; [the get-info proc for the program in the definitions] [info-result (with-handlers ((exn:fail? (λ (x) #f))) - (parameterize ([current-reader-guard - (let ([old (current-reader-guard)]) - (lambda (g) - (if (and (pair? g) - (eq? (car g) 'planet)) - (error "#lang planet disbled") - (old g))))]) - ;; FIXME: do something so that we don't - ;; have to disable all planet packages. - (read-language port (lambda () #f))))]) - ;; sometimes I get eof here, but I don't know why and can't seem to + (read-language + port + (lambda () + ;; fall back to whatever #lang racket does if + ;; we don't have a #lang line present in the file + (vector (read-language (open-input-string "#lang racket"))))))]) + + ; sometimes I get eof here, but I don't know why and can't seem to ;; make it happen outside of DrScheme (when (eof-object? info-result) (fprintf (current-error-port) "file ~s produces eof from read-language\n" @@ -128,10 +131,18 @@ (contract (or/c #f (listof (list/c string? (is-a?/c bitmap%) (-> (is-a?/c drscheme:unit:frame<%>) any)))) - (info-result 'drscheme:toolbar-buttons #f) - (get-lang-name pos) + ((if (vector? info-result) + (vector-ref info-result 0) + info-result) + 'drscheme:toolbar-buttons #f) + (if (vector? info-result) + 'hash-lang-racket + (get-lang-name pos)) 'drscheme/private/module-language-tools) - (info-result 'drscheme:opt-out-toolbar-buttons '()))))))) + ((if (vector? info-result) + (vector-ref info-result 0) + info-result) + 'drscheme:opt-out-toolbar-buttons '()))))))) (inherit get-tab) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 98ab117a4d..7c09d02989 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -63,15 +63,8 @@ (let* ([defs-port (open-input-text-editor defs-text)] [read-successfully? (with-handlers ((exn:fail? (λ (x) #f))) - (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 #f)))]) - (read-language defs-port (λ () (void))) - #t))))]) + (read-language defs-port (λ () #f)) + #t)]) (cond [read-successfully? (let* ([str (send defs-text get-text 0 (file-position defs-port))] diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss index 09a8aaf71c..2b5e5ea212 100644 --- a/collects/planet/lang/reader.ss +++ b/collects/planet/lang/reader.ss @@ -1,19 +1,30 @@ -(module reader scheme/base - (require syntax/module-reader) +#lang scheme/base +(require syntax/module-reader + "../resolver.ss") - (provide (rename-out [planet-read read] - [planet-read-syntax read-syntax] - [planet-get-info get-info])) +(provide (rename-out [planet-read read] + [planet-read-syntax read-syntax] + [planet-get-info get-info])) + +(define (str->spec str) + (let ([str (bytes->string/latin-1 str)]) + (if (module-path? `(planet ,(string->symbol str))) + `(planet ,(string->symbol (string-append str "/lang/reader"))) + #f))) + +(define-values (planet-read planet-read-syntax real-planet-get-info) + (make-meta-reader + 'planet + "planet path" + str->spec + values + values + values)) + +(define op (current-output-port)) + +(define (planet-get-info inport module-path line col pos) + (parameterize ([install? #f] + [download? #f]) + (real-planet-get-info inport module-path line col pos))) - (define-values (planet-read planet-read-syntax planet-get-info) - (make-meta-reader - 'planet - "planet path" - (lambda (str) - (let ([str (bytes->string/latin-1 str)]) - (if (module-path? `(planet ,(string->symbol str))) - `(planet ,(string->symbol (string-append str "/lang/reader"))) - #f))) - values - values - values))) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index b134c2c96f..511b4f1b05 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -463,6 +463,30 @@ The @schememodname[planet] module (as opposed to the reader used with The planet collection provides configuration and utilities for using PLaneT. +@subsection{Resolver} + +@defmodule[planet/resolver] + +The primary purpose of this library to for @scheme[require] to find +@PLaneT packages. It also, however, provides some utilities for manipulating +the resolvers behavior. + +@defproc[(resolve-planet-path [planet-path any/c]) path?]{ + Returns the path where the file named by the require spec @scheme[planet-path] is located in the current installation. +} + +@defparam[download? dl? boolean?]{ + A parameter that controls if @PLaneT attempts to download a planet package that isn't already present. + If the package isn't present, the resolver will raise the @scheme[exn:fail:planet?] exception + instead of downloading it. +} + +@defparam[install? inst? boolean?]{ + A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed. + If the package isn't installed, the resolver will raise the @scheme[exn:fail:planet?] exception + instead of installing it. +} + @subsection{Client Configuration} @defmodule[planet/config] @@ -659,6 +683,10 @@ context of a package. The others are convenience macros that select out the relevant field, or return @scheme[#f] if the expression appears outside the context of a PLaneT package.} +@defproc[(exn:fail:planet? [val any/c]) boolean?]{ + Returns @scheme[#t] if @scheme[val] is +} + @subsection{Terse Status Updates} @defmodule[planet/terse-info] diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index ddedc5be34..e7bc4fa9c4 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -212,10 +212,16 @@ subdirectory. pkg-promise->pkg install-pkg get-planet-module-path/pkg - install?) + download? + install? + exn:fail:planet? + make-exn:fail:planet) -;; if #f, will not install packages and instead give an error +;; if #f, will not install packages and instead raise a exn:fail:install? error (define install? (make-parameter #t)) +;; if #f, will not download packages and instead raise a exn:fail:install? error +(define download? (make-parameter #t)) +(define-struct (exn:fail:planet exn:fail) ()) ;; update doc index only once for a set of installs: (define planet-nested-install (make-parameter #f)) @@ -511,6 +517,12 @@ subdirectory. (string-append "PLaneT could not download the requested package: " s)])) (define (download-package pkg) + (unless (download?) + (raise (make-exn:fail:planet + (format + "PLaneT error: cannot download package ~s since the download? parameter is set to #f" + (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg))) + (current-continuation-marks)))) ((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet) pkg)) @@ -539,7 +551,7 @@ subdirectory. ;; installed file (define (install-pkg pkg path maj min) (unless (install?) - (raise (make-exn:fail + (raise (make-exn:fail:planet (format "PLaneT error: cannot install package ~s since the install? parameter is set to #f" (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min)) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 275afacb56..f4cf303d95 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -41,12 +41,13 @@ unlink-all lookup-package-by-keys resolve-planet-path - (struct-out exn:fail:planet) display-plt-file-structure display-plt-archived-file get-package-from-cache install-pkg - pkg->download-url) + pkg->download-url + exn:fail:planet? + make-exn:fail:planet) (provide/contract [get-package-spec @@ -103,8 +104,6 @@ ;; -- remove any existing linkage for package ;; returns void if the removal worked; raises an exception if no package existed. -(define-struct (exn:fail:planet exn:fail) ()) - (define (remove-pkg owner name maj min) (let ((p (get-installed-package owner name maj min))) (unless p diff --git a/collects/syntax-color/module-lexer.ss b/collects/syntax-color/module-lexer.ss index 9d476f48d5..4c4d015e37 100644 --- a/collects/syntax-color/module-lexer.ss +++ b/collects/syntax-color/module-lexer.ss @@ -12,16 +12,7 @@ [(init) (file-position p)] [(start-line start-col start-pos) (port-next-location p)]) (let ([get-info (with-handlers ([exn:fail? (lambda (exn) 'fail)]) - (parameterize ([current-reader-guard - (let ([old (current-reader-guard)]) - (lambda (g) - (if (and (pair? g) - (eq? (car g) 'planet)) - (error "#lang planet disbled") - (old g))))]) - ;; FIXME: do something so that we don't - ;; have to disable all planet packages. - (read-language p (lambda () #f))))] + (read-language p (lambda () #f)))] [sync-ports (lambda () (read-bytes (- (file-position p) init) in))]) (cond diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index 063d9fd239..4105778ce7 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -216,7 +216,7 @@ #:read-spec [read-spec (lambda (in) - (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) + (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) ;; if this changes, the regexp in planet's lang/reader.ss must also change (and spec (let ([s (cadr spec)]) (if (equal? s "") #f s)))))]) (define (get in export-sym src line col pos spec-as-stx? mk-fail-thunk)