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

used killing, instead of breaking for aborting executable creation

Browse Source 
svn: r3191
This commit is contained in:
Robby Findler 2006-06-02 20:22:27 +00:00
parent 124761f29a
commit ec046e170e
1 changed files with 62 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/drscheme/private/language.ss
View File

@ -962,45 +962,35 @@
(when (file-exists? distribution-filename) (when (file-exists? distribution-filename)
(delete-file distribution-filename)) (delete-file distribution-filename))
;; Figure out base name, and create working temp directory: ;; Figure out base name, and create working temp directory:
(let ([base-name (let-values ([(base name dir?) (split-path distribution-filename)]) (let* ([base-name (let-values ([(base name dir?) (split-path distribution-filename)])
(path-replace-suffix name #""))] (path-replace-suffix name #""))]
[temp-dir [temp-dir
(make-temporary-file "drscheme-tmp-~a" 'directory)] (make-temporary-file "drscheme-tmp-~a" 'directory)]
[c (make-custodian)]) [c (make-custodian)]
(let ([status-message #f] [dialog (new dialog%
[ready (make-semaphore)])
(with-handlers ([exn? ; Catch breaks!
(λ (x)
(custodian-shutdown-all c)
(delete-directory/files temp-dir)
(message-box
(string-constant drscheme)
(format "~a" (exn-message x)))
(void))])
(let ([orig-thread (current-thread)])
(parameterize ([current-custodian c])
(parameterize ([current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(let* ([dialog (new dialog%
[label (string-constant distribution-progress-window-title)] [label (string-constant distribution-progress-window-title)]
[width 400])] [width 400])]
[label (new message% [status-message
(new message%
[label (string-constant creating-executable-progress-status)] [label (string-constant creating-executable-progress-status)]
[parent dialog] [parent dialog]
[stretchable-width #t])] [stretchable-width #t])]
[pane (new vertical-pane% [pane (new vertical-pane%
[parent dialog])]) [parent dialog])]
[abort-button
(new button% (new button%
[parent pane] [parent pane]
[label (string-constant abort)] [label (string-constant abort)]
[callback (lambda (c b) [callback (lambda (_1 _2)
(break-thread orig-thread))]) (custodian-shutdown-all c))])]
(send dialog center)
(set! status-message label) [exn #f]
(semaphore-post ready)
(send dialog show #t))))))) [worker-thread
(semaphore-wait ready) (parameterize ([current-custodian c])
(thread
(λ ()
(with-handlers ([exn? (λ (e) (set! exn e))])
;; Build the exe: ;; Build the exe:
(make-directory (build-path temp-dir "exe")) (make-directory (build-path temp-dir "exe"))
(let ([exe-name (build-path temp-dir "exe" (default-executable-filename base-name 'stand-alone gui?))]) (let ([exe-name (build-path temp-dir "exe" (default-executable-filename base-name 'stand-alone gui?))])
@ -1009,14 +999,32 @@
(directory-exists? exe-name)) (directory-exists? exe-name))
(let ([dist-dir (build-path temp-dir base-name)]) (let ([dist-dir (build-path temp-dir base-name)])
;; Assemble the bundle directory: ;; Assemble the bundle directory:
(send status-message set-label (string-constant assembling-distribution-files-progress-status)) (queue-callback
(λ ()
(send status-message set-label (string-constant assembling-distribution-files-progress-status))))
(assemble-distribution dist-dir (list exe-name)) (assemble-distribution dist-dir (list exe-name))
;; Pack it: ;; Pack it:
(send status-message set-label (string-constant packing-distribution-progress-status)) (queue-callback
(bundle-directory distribution-filename dist-dir #t))) (λ ()
(send status-message set-label (string-constant packing-distribution-progress-status))))
(bundle-directory distribution-filename dist-dir #t))))))))])
;; create a thread that will trigger hiding the dialog and the return from `show'
;; when things are done (no matter if there was a kill, or just normal terminiation)
(thread
(λ ()
(thread-wait worker-thread)
(queue-callback (λ () (send dialog show #f)))))
(send dialog show #t)
;; Clean up: ;; Clean up:
(custodian-shutdown-all c) (custodian-shutdown-all c)
(delete-directory/files temp-dir)))))) (delete-directory/files temp-dir)
(when exn
(raise exn))))
(define (condense-scheme-code-string s) (define (condense-scheme-code-string s)
(let ([i (open-input-string s)] (let ([i (open-input-string s)]