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

Factored out MrEd deps

Browse Source 
original commit: ce0919821999ded657ad5338db774b52ea328119
This commit is contained in:
Paul Steckler 2002-07-16 16:58:34 +00:00
parent 6086973b8b
commit 6e18cdd287
2 changed files with 67 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
collects/help/help.ss
View File

@ -1,11 +1,7 @@
(module help mzscheme (module help mzscheme
(require (lib "web-server.ss" "web-server") (require (lib "class.ss")
(lib "util.ss" "web-server")
(lib "class.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "cmdline.ss") (lib "cmdline.ss")
(lib "configuration.ss" "web-server")
(lib "configuration-structures.ss" "web-server")
"private/server.ss" "private/server.ss"
"private/browser.ss") "private/browser.ss")
@ -40,91 +36,87 @@
(define help-desk-port (hd-cookie->port hd-cookie)) (define help-desk-port (hd-cookie->port hd-cookie))
; allow server startup time ; allow server startup time
(let loop () (wait-for-connection help-desk-port)
(with-handlers
([void (lambda _ (sleep 1) (loop))])
(let-values
([(iport oport) (tcp-connect "127.0.0.1" help-desk-port)])
(sleep 1)
(close-output-port oport)
(close-input-port iport))))
(when launch-browser? (when launch-browser?
(help-desk-browser hd-cookie) (help-desk-browser hd-cookie)
; allow browser startup time ; allow browser startup time
(sleep 2)) (sleep 2))
(if quiet? (if quiet?
(semaphore-wait (make-semaphore 0)) (semaphore-wait (make-semaphore 0))
(let* ([hd-frame% (let* ([hd-frame%
(class frame% (class frame%
(inherit show) (inherit show)
(field (field
[panel #f] [panel #f]
[main-sd-button #f] [main-sd-button #f]
[shutdown-dialog [shutdown-dialog
(lambda () (lambda ()
(let* ([cb-frame (instantiate frame% () (let* ([cb-frame (instantiate frame% ()
(label "Confirm"))] (label "Confirm"))]
[vpanel (instantiate vertical-panel% () [vpanel (instantiate vertical-panel% ()
(parent cb-frame))] (parent cb-frame))]
[msg (instantiate message% () [msg (instantiate message% ()
(label "Really shutdown Help Desk server?") (label "Really shutdown Help Desk server?")
(parent vpanel))] (parent vpanel))]
[hpanel (instantiate horizontal-panel% () [hpanel (instantiate horizontal-panel% ()
(parent vpanel) (parent vpanel)
(alignment '(center center)))] (alignment '(center center)))]
[sd-button (instantiate button% () [sd-button (instantiate button% ()
(label "Shutdown") (label "Shutdown")
(parent hpanel) (parent hpanel)
(callback (lambda (b ev) (callback
(send cb-frame show #f) (lambda (b ev)
(send this show #f))))] (send cb-frame show #f)
[no-sd-button (instantiate button% () (send this show #f))))]
(label "Cancel") [no-sd-button (instantiate button% ()
(parent hpanel) (label "Cancel")
(callback (lambda (b ev) (parent hpanel)
(send main-sd-button (callback
enable #t) (lambda (b ev)
(send cb-frame show #f))))]) (send main-sd-button
(send main-sd-button enable #f) enable #t)
(send cb-frame center) (send cb-frame show #f))))])
(send cb-frame show #t)))]) (send main-sd-button enable #f)
(define/override can-close? (send cb-frame center)
(lambda () (shutdown-dialog) #f)) (send cb-frame show #t)))])
(super-instantiate ()) (define/override can-close?
(set! panel (lambda () (shutdown-dialog) #f))
(instantiate vertical-panel% () (super-instantiate ())
(parent this))) (set! panel
(instantiate message% () (instantiate vertical-panel% ()
(label (format "Help Desk server running on port ~a" (parent this)))
(hd-cookie->port hd-cookie))) (instantiate message% ()
(parent panel)) (label (format "Help Desk server running on port ~a"
(instantiate button% () (hd-cookie->port hd-cookie)))
(label "Help Desk Home") (parent panel))
(parent panel) (instantiate button% ()
(min-width 100) (label "Help Desk Home")
(callback (parent panel)
(lambda (b ev) (min-width 100)
(help-desk-browser hd-cookie)))) (callback
(set! main-sd-button (lambda (b ev)
(instantiate button% () (help-desk-browser hd-cookie))))
(label "Shutdown Server") (set! main-sd-button
(parent panel) (instantiate button% ()
(min-width 100) (label "Shutdown Server")
(callback (lambda (b ev) (parent panel)
(shutdown-dialog))))))] (min-width 100)
(callback (lambda (b ev)
(shutdown-dialog))))))]
[frame [frame
(instantiate hd-frame% () (instantiate hd-frame% ()
(label "PLT Help Desk") (label "PLT Help Desk")
(min-width 175) (min-width 175)
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f))]) (stretchable-height #f))])
(send frame center) (send frame center)
(send frame show #t) (send frame show #t)
(when iconize? (when iconize?
(send frame iconize #t))))) (send frame iconize #t)))))

30
collects/help/private/search.ss
View File

@ -3,40 +3,12 @@
"docpos.ss" "docpos.ss"
"colldocs.ss" "colldocs.ss"
"server.ss" "server.ss"
"browser.ss"
(lib "list.ss") (lib "list.ss")
(lib "util.ss" "help" "servlets" "private") (lib "util.ss" "help" "servlets" "private"))
(lib "specs.ss" "framework"))
(provide do-search (provide do-search
doc-collections-changed) doc-collections-changed)
(provide/contract
(search-for-docs
(hd-cookie? string?
(lambda (s)
(member s
'("keyword" "keyword-index" "keyword-index-text")))
(lambda (s)
(member s
'("exact-match" "containing-match" "regexp-match")))
any?
. -> . any?)))
; hd-cookie string string string any -> void
; shows search result in default browser
(define (search-for-docs cookie search-string search-type match-type lucky?)
(let* ([port (hd-cookie->port cookie)]
[url (format
(string-append "http://127.0.0.1:~a/servlets/index.ss?"
"search-string=~a&"
"search-type=~a&"
"match-type=~a&"
"lucky=~a")
port (hexify-string search-string) search-type match-type
(if lucky? "true" "false"))])
(help-desk-navigate url)))
(define (html-doc-position x) (define (html-doc-position x)
(or (user-defined-doc-position x) (or (user-defined-doc-position x)
(standard-html-doc-position x))) (standard-html-doc-position x)))