Merge branch 'master' of git.racket-lang.org:plt

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 <get-info-proc>) [no #lang line, so we use the '#lang racket' info proc]
+               ;;                     <get-info-proc>  [the get-info proc for the program in the definitions]
                [info-result (with-handlers ((exn:fail? (λ (x) #f)))
-                              (parameterize ([current-reader-guard
+                              (read-language 
-                                              (let ([old (current-reader-guard)])
+                               port
-                                                (lambda (g)
+                               (lambda () 
-                                                  (if (and (pair? g)
+                                 ;; fall back to whatever #lang racket does if
-                                                           (eq? (car g) 'planet))
+                                 ;; we don't have a #lang line present in the file
-                                                      (error "#lang planet disbled")
+                                 (vector (read-language (open-input-string "#lang racket"))))))])
-                                                      (old g))))])
+          
-                                ;; FIXME: do something so that we don't
+          ; sometimes I get eof here, but I don't know why and can't seem to 
-                                ;; 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 
           ;; 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)
+                           ((if (vector? info-result)
-                           (get-lang-name pos)
+                                (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)
       

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
+                  (read-language defs-port (λ () #f))
-                    (let ([orig-security (current-security-guard)])
+                  #t)])
-                      (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))))])
           (cond
             [read-successfully?
              (let* ([str (send defs-text get-text 0 (file-position defs-port))]

collects/planet/lang/reader.ss

@@ -1,19 +1,30 @@
-(module reader scheme/base
+#lang scheme/base
-  (require syntax/module-reader)
+(require syntax/module-reader
+         "../resolver.ss")
 
-  (provide (rename-out [planet-read read]
+(provide (rename-out [planet-read read]
-                       [planet-read-syntax read-syntax]
+                     [planet-read-syntax read-syntax]
-                       [planet-get-info get-info]))
+                     [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)))

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]

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))

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

collects/scriblib/figure.tex

@@ -9,7 +9,7 @@
 \newlength{\FigOrigskip}
 \FigOrigskip=\parskip
 
-\newenvironment{CenterfigureMulti}{\begin{figure*}\centering}{\end{figure*}}
+\newenvironment{CenterfigureMulti}{\begin{figure*}[htp]\centering}{\end{figure*}}
 \newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}}
-\newenvironment{Centerfigure}{\begin{figure}\centering}{\end{figure}}
+\newenvironment{Centerfigure}{\begin{figure}[htp]\centering}{\end{figure}}
 \newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}}

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
+                        (read-language p (lambda () #f)))]
-                                        (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))))]
             [sync-ports (lambda ()
                           (read-bytes (- (file-position p) init) in))])
         (cond

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)