From 980e957407e8e3072e7cf241c5cb55fb7ec175bf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 6 Apr 2014 17:49:22 -0500 Subject: [PATCH] Improve DrRacket .plt installation functionality so that it prints out the file it tried to unpack when it fails --- .../drracket/setup/plt-installer-unit.rkt | 3 +- .../drracket/setup/plt-installer.scrbl | 3 +- pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt | 8 +++- .../racket-doc/scribblings/raco/setup.scrbl | 13 +++++-- .../collects/setup/plt-single-installer.rkt | 38 +++++++++++++------ 5 files changed, 47 insertions(+), 18 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket/setup/plt-installer-unit.rkt b/pkgs/drracket-pkgs/drracket/setup/plt-installer-unit.rkt index b1cf5aeadc..a31eee5f84 100644 --- a/pkgs/drracket-pkgs/drracket/setup/plt-installer-unit.rkt +++ b/pkgs/drracket-pkgs/drracket/setup/plt-installer-unit.rkt @@ -47,5 +47,6 @@ (unless d (printf ">>> Cancelled <<<\n")) (begin-busy-cursor) - d)))) + d)) + #:show-beginning-of-file? #t)) cleanup-thunk))) diff --git a/pkgs/drracket-pkgs/drracket/setup/plt-installer.scrbl b/pkgs/drracket-pkgs/drracket/setup/plt-installer.scrbl index d82e102f2c..75318df937 100644 --- a/pkgs/drracket-pkgs/drracket/setup/plt-installer.scrbl +++ b/pkgs/drracket-pkgs/drracket/setup/plt-installer.scrbl @@ -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.} diff --git a/pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt b/pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt index eb05040508..89fdbc486d 100644 --- a/pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt +++ b/pkgs/gui-pkgs/gui-lib/mrlib/terminal.rkt @@ -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) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl index c2a2268c72..e350c9b5ee 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -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? diff --git a/racket/collects/setup/plt-single-installer.rkt b/racket/collects/setup/plt-single-installer.rkt index d54a744a16..ec2b7d511a 100644 --- a/racket/collects/setup/plt-single-installer.rkt +++ b/racket/collects/setup/plt-single-installer.rkt @@ -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)))))