7d50e61c7f
* Another big chunk of v4-require-isms * Allow `#lang framework/keybinding-lang' for keybinding files * Move hierlist sources into "mrlib/hierlist", leave stub behind svn: r10689
132 lines
6.2 KiB
Scheme
132 lines
6.2 KiB
Scheme
|
|
(module plt-installer-unit mzscheme
|
|
(require mzlib/unit
|
|
mred/mred-sig
|
|
mzlib/class
|
|
mzlib/etc
|
|
"plt-installer-sig.ss"
|
|
(prefix single: "plt-single-installer.ss")
|
|
string-constants)
|
|
|
|
(provide plt-installer@)
|
|
(define-unit plt-installer@
|
|
(import mred^)
|
|
(export setup:plt-installer^)
|
|
|
|
(define on-installer-run
|
|
(make-parameter void))
|
|
|
|
;; with-installer-window : ((union (instanceof dialog%) (instanceof frame%)) -> void) (-> void) -> void
|
|
;; creates a frame and sets up the current error and output ports
|
|
;; before calling `do-install'.
|
|
;; runs the installer in a separate thread and returns immediately,
|
|
;; before the installation is complete. The cleanup thunk is called when installation completes
|
|
(define (with-installer-window do-install cleanup-thunk)
|
|
(let ([orig-eventspace (current-eventspace)]
|
|
[orig-custodian (current-custodian)]
|
|
[inst-eventspace (make-eventspace)])
|
|
(parameterize ([current-eventspace inst-eventspace])
|
|
(letrec ([dlg (make-object (class dialog% ()
|
|
(define/augment can-close? (lambda () (send done is-enabled?)))
|
|
(define/augment on-close (lambda () (done-callback)))
|
|
(super-make-object
|
|
(string-constant plt-installer-progress-window-title)
|
|
#f 600 300 #f #f '(resize-border))))]
|
|
[text (make-object text%)]
|
|
[canvas (make-object editor-canvas% dlg text)]
|
|
[button-panel (instantiate horizontal-panel% ()
|
|
(parent dlg)
|
|
(stretchable-height #f)
|
|
(alignment '(center center)))]
|
|
[kill-button (make-object button%
|
|
(string-constant plt-installer-abort-installation)
|
|
button-panel
|
|
(lambda (b e) (kill)))]
|
|
[done (make-object button% (string-constant close) button-panel (lambda (b e) (done-callback)))]
|
|
[output (make-output-port
|
|
#f
|
|
always-evt
|
|
(lambda (bytes start end flush? enable-break?)
|
|
(parameterize ([current-eventspace inst-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(let ([str (bytes->string/utf-8 (subbytes bytes start end))])
|
|
(send text lock #f)
|
|
(send text insert
|
|
str
|
|
(send text last-position)
|
|
'same
|
|
; Scroll on newlines only:
|
|
(regexp-match #rx"\n" str))
|
|
(send text lock #t)))))
|
|
(- end start))
|
|
void)]
|
|
[kill
|
|
(lambda ()
|
|
(custodian-shutdown-all installer-cust)
|
|
(fprintf output "\n~a\n" (string-constant plt-installer-aborted))
|
|
(send done enable #t))]
|
|
[completed-successfully? #f]
|
|
[done-callback
|
|
(lambda ()
|
|
(send dlg show #f)
|
|
(custodian-shutdown-all installer-cust))]
|
|
[installer-cust (make-custodian)])
|
|
(send done enable #f)
|
|
(send canvas allow-tab-exit #t)
|
|
((current-text-keymap-initializer) (send text get-keymap))
|
|
(send text lock #t)
|
|
|
|
;; still do this even tho we aren't in the eventspace main thread
|
|
(thread (lambda () (send dlg show #t)))
|
|
|
|
(parameterize ([current-custodian installer-cust])
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(queue-callback
|
|
(lambda ()
|
|
|
|
(let ([installer-thread (current-thread)])
|
|
(parameterize ([current-custodian orig-custodian])
|
|
(thread
|
|
(lambda ()
|
|
(thread-wait installer-thread)
|
|
(send kill-button enable #f)
|
|
(unless completed-successfully?
|
|
(parameterize ([current-eventspace orig-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(cleanup-thunk)))))))))
|
|
|
|
(parameterize ([current-output-port output]
|
|
[current-error-port output])
|
|
(do-install dlg))
|
|
(parameterize ([current-eventspace orig-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(set! completed-successfully? #t)
|
|
((on-installer-run))
|
|
(cleanup-thunk))))
|
|
|
|
(send done enable #t)))))))))
|
|
|
|
(define run-single-installer single:run-single-installer)
|
|
|
|
(define run-installer
|
|
(opt-lambda (file [cleanup-thunk void])
|
|
(with-installer-window
|
|
(lambda (frame)
|
|
(run-single-installer
|
|
file
|
|
(lambda ()
|
|
(sleep 0.2) ; kludge to allow f to appear first
|
|
(end-busy-cursor)
|
|
;; do these strings ever appear? (should move to string-constants, if so)
|
|
(let ([d (get-directory
|
|
"Select the destination for unpacking"
|
|
frame)])
|
|
(unless d
|
|
(printf ">>> Cancelled <<<~n"))
|
|
(begin-busy-cursor)
|
|
d))))
|
|
cleanup-thunk)))))
|