suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve DrRacket .plt installation functionality so that it prints

Browse Source 
out the file it tried to unpack when it fails
This commit is contained in:
Robby Findler 2014-04-06 17:49:22 -05:00
parent e08ffde1b5
commit 980e957407
5 changed files with 47 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/drracket-pkgs/drracket/setup/plt-installer-unit.rkt
View File

@ -47,5 +47,6 @@
(unless d
(printf ">>> Cancelled <<<\n"))
(begin-busy-cursor)
d))))
d))
#:show-beginning-of-file? #t))
cleanup-thunk)))

3
pkgs/drracket-pkgs/drracket/setup/plt-installer.scrbl
View File

@ -41,7 +41,8 @@
}
@defproc[(run-single-installer (file path-string?)
(get-dir-proc (-> (or/c path-string? #f))))
(get-dir-proc (-> (or/c path-string? #f)))
[#:show-beginning-of-file? show-beginning-of-file? any/c #f])
void?]{
The same as the export from @racketmodname[setup/plt-single-installer],
but with a GUI.}

8
pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt
View File

@ -230,7 +230,13 @@
(let/ec k
(parameterize ([current-output-port output-port]
[current-error-port error-port]
[error-escape-handler (λ () (k (void)))]
[error-escape-handler
(let ([oh (error-escape-handler)]
[ct (current-thread)])
(λ ()
(if (equal? (current-thread) ct)
(k (void))
(oh))))]
[exit-handler
(λ (x)
(unless (equal? x 0)

13
pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl
View File

@ -940,7 +940,9 @@ function for installing a single @filepath{.plt} file.
@defproc[(run-single-installer
(file path-string?)
(get-dir-proc (-> (or/c path-string? #f)))) void?]{
(get-dir-proc (-> (or/c path-string? #f)))
[#:show-beginning-of-file? show-beginning-of-file? any/c #f])
void?]{
Creates a separate thread and namespace, runs the installer in that
thread with the new namespace, and returns when the thread
completes or dies. It also creates a custodian
@ -952,8 +954,13 @@ function for installing a single @filepath{.plt} file.
The @racket[get-dir-proc] procedure is called if the installer needs a
target directory for installation, and a @racket[#f] result means that
the user canceled the installation. Typically, @racket[get-dir-proc] is
@racket[current-directory].}
v
@racket[current-directory].
If @racket[show-beginning-of-file?] is a true value and the installation
fails, then @racket[run-single-installer] prints the first 1,000 characters
of the file (in an attempt to help debug the cause of failures).
}
@defproc[(install-planet-package [file path-string?]
[directory path-string?]
[spec (list/c string? string?

38
racket/collects/setup/plt-single-installer.rkt
View File

@ -5,40 +5,44 @@
;; run-single-installer : string (-> string) -> void
;; runs the installer on the given package
(define (run-single-installer file get-target-dir)
(run-single-installer/internal file get-target-dir #f #f #f))
(define (run-single-installer file get-target-dir
#:show-beginning-of-file? [show-beginning-of-file? #f])
(run-single-installer/internal file get-target-dir #f #f #f show-beginning-of-file?))
;; install-planet-package : path path (list string string (listof string) nat nat) -> void
;; unpacks and installs the given planet package into the given path
(define (install-planet-package file directory spec)
(run-single-installer/internal file (lambda () directory) (cons directory spec) #f #f))
(run-single-installer/internal file (lambda () directory) (cons directory spec) #f #f #f))
;; clean-planet-package : path (list string string (listof string) nat nat) -> void
;; cleans the given planet package
(define (clean-planet-package directory spec)
(run-single-installer/internal #f (lambda () directory) (cons directory spec) #f #t))
(run-single-installer/internal #f (lambda () directory) (cons directory spec) #f #t #f))
;; reindex-user-documentation
;; call after installing or uninstalling a set of Planet packages
(define (reindex-user-documentation)
(run-single-installer/internal #f current-directory #f '(("scribblings/main/user")) #f))
(run-single-installer/internal #f current-directory #f '(("scribblings/main/user")) #f #f))
;; run-single-installer : string (-> string) (list path string string nat nat) -> void
;; creates a separate thread, runs the installer in that thread,
;; returns when the thread completes
(define (run-single-installer/internal file get-target-dir planet-spec collections clean?)
(define (run-single-installer/internal file get-target-dir planet-spec collections clean?
show-beginning-of-file?)
(define cust (make-custodian))
(parameterize ([current-custodian cust]
[current-namespace (make-base-namespace)]
[exit-handler (lambda (v) (custodian-shutdown-all cust))])
(define succeeded? #f)
(define thd
(thread
(lambda ()
(setup #:jobs 1
#:file file
#:get-target-dir get-target-dir
#:planet-specs (and planet-spec (list planet-spec))
#:collections collections))))
(set! succeeded?
(setup #:jobs 1
#:file file
#:get-target-dir get-target-dir
#:planet-specs (and planet-spec (list planet-spec))
#:collections collections)))))
(dynamic-wind
void
(lambda ()
@ -46,5 +50,15 @@
(break-thread thd)
(sleep 0.1)
(raise exn))])
(thread-wait thd)))
(thread-wait thd)
(when show-beginning-of-file?
(unless succeeded?
(define (sep) (display "----------------------------------------\n"))
(printf "The first 100 characters of the file:\n")
(sep)
(call-with-input-file file
(λ (port)
(display (read-string 100 port))))
(newline)
(sep)))))
(lambda () (custodian-shutdown-all cust)))))