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

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

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