MrEd applet

original commit: 4b7041e2ec20cb00fd88304dd260ac503beb98ca
This commit is contained in:
Paul Steckler 2002-07-15 17:00:11 +00:00
parent 6697e45655
commit 6d309cd4be

View File

@ -1,14 +1,14 @@
(module help mzscheme (module help mzscheme
(require (lib "web-server.ss" "web-server") (require (lib "web-server.ss" "web-server")
(lib "util.ss" "web-server") (lib "util.ss" "web-server")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "cmdline.ss") (lib "cmdline.ss")
(lib "configuration.ss" "web-server") (lib "configuration.ss" "web-server")
(lib "configuration-structures.ss" "web-server") (lib "configuration-structures.ss" "web-server")
"private/server.ss" "private/server.ss"
"private/browser.ss") "private/browser.ss")
(require (lib "exit.ss" "help" "servlets" "private"))
(define launch-browser? #t) (define launch-browser? #t)
(define external-connections? #f) (define external-connections? #f)
(define port #f) (define port #f)
@ -33,9 +33,6 @@
(define hd-cookie (start-help-server port external-connections?)) (define hd-cookie (start-help-server port external-connections?))
(define help-desk-port (hd-cookie->port hd-cookie)) (define help-desk-port (hd-cookie->port hd-cookie))
(define exit-sem (make-semaphore 0))
(set-box! exit-box (lambda () (semaphore-post exit-sem)))
; allow server startup time ; allow server startup time
(let loop () (let loop ()
(with-handlers (with-handlers
@ -47,7 +44,42 @@
(close-input-port iport)))) (close-input-port iport))))
(when launch-browser? (when launch-browser?
(help-desk-browser hd-cookie)) (help-desk-browser hd-cookie)
; allow browser startup time
(sleep 2))
(define hd-frame%
(class frame%
(inherit show)
(field
[panel #f])
(super-instantiate ())
(set! panel
(instantiate vertical-panel% ()
(parent this)))
(instantiate button% ()
(label "New browser")
(parent panel)
(min-width 100)
(callback
(lambda (b ev)
(help-desk-browser hd-cookie))))
(instantiate button% ()
(label "Shutdown server")
(parent panel)
(min-width 100)
(callback (lambda (b ev)
(send this show #f))))))
(define frame
(instantiate hd-frame% ()
(label "PLT Help Desk")
(min-width 175)
(stretchable-width #f)
(stretchable-height #f)))
(send frame center)
(send frame show #t))
; wait until shutdown
(semaphore-wait/enable-break exit-sem))