From 6e18cdd287eb2c2c0d9a6c91805806db987f8962 Mon Sep 17 00:00:00 2001 From: Paul Steckler Date: Tue, 16 Jul 2002 16:58:34 +0000 Subject: [PATCH] Factored out MrEd deps original commit: ce0919821999ded657ad5338db774b52ea328119 --- collects/help/help.ss | 140 +++++++++++++++----------------- collects/help/private/search.ss | 30 +------ 2 files changed, 67 insertions(+), 103 deletions(-) diff --git a/collects/help/help.ss b/collects/help/help.ss index fc441e84..eeb3df67 100644 --- a/collects/help/help.ss +++ b/collects/help/help.ss @@ -1,11 +1,7 @@ (module help mzscheme - (require (lib "web-server.ss" "web-server") - (lib "util.ss" "web-server") - (lib "class.ss") + (require (lib "class.ss") (lib "mred.ss" "mred") (lib "cmdline.ss") - (lib "configuration.ss" "web-server") - (lib "configuration-structures.ss" "web-server") "private/server.ss" "private/browser.ss") @@ -40,91 +36,87 @@ (define help-desk-port (hd-cookie->port hd-cookie)) ; allow server startup time - (let loop () - (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)))) + (wait-for-connection help-desk-port) (when launch-browser? (help-desk-browser hd-cookie) - ; allow browser startup time + ; allow browser startup time (sleep 2)) (if quiet? (semaphore-wait (make-semaphore 0)) (let* ([hd-frame% (class frame% - (inherit show) - (field - [panel #f] - [main-sd-button #f] - [shutdown-dialog - (lambda () - (let* ([cb-frame (instantiate frame% () - (label "Confirm"))] - [vpanel (instantiate vertical-panel% () - (parent cb-frame))] - [msg (instantiate message% () - (label "Really shutdown Help Desk server?") - (parent vpanel))] - [hpanel (instantiate horizontal-panel% () - (parent vpanel) - (alignment '(center center)))] - [sd-button (instantiate button% () - (label "Shutdown") - (parent hpanel) - (callback (lambda (b ev) - (send cb-frame show #f) - (send this show #f))))] - [no-sd-button (instantiate button% () - (label "Cancel") - (parent hpanel) - (callback (lambda (b ev) - (send main-sd-button - enable #t) - (send cb-frame show #f))))]) - (send main-sd-button enable #f) - (send cb-frame center) - (send cb-frame show #t)))]) - (define/override can-close? - (lambda () (shutdown-dialog) #f)) - (super-instantiate ()) - (set! panel - (instantiate vertical-panel% () - (parent this))) - (instantiate message% () - (label (format "Help Desk server running on port ~a" - (hd-cookie->port hd-cookie))) - (parent panel)) - (instantiate button% () - (label "Help Desk Home") - (parent panel) - (min-width 100) - (callback - (lambda (b ev) - (help-desk-browser hd-cookie)))) - (set! main-sd-button - (instantiate button% () - (label "Shutdown Server") - (parent panel) - (min-width 100) - (callback (lambda (b ev) - (shutdown-dialog))))))] + (inherit show) + (field + [panel #f] + [main-sd-button #f] + [shutdown-dialog + (lambda () + (let* ([cb-frame (instantiate frame% () + (label "Confirm"))] + [vpanel (instantiate vertical-panel% () + (parent cb-frame))] + [msg (instantiate message% () + (label "Really shutdown Help Desk server?") + (parent vpanel))] + [hpanel (instantiate horizontal-panel% () + (parent vpanel) + (alignment '(center center)))] + [sd-button (instantiate button% () + (label "Shutdown") + (parent hpanel) + (callback + (lambda (b ev) + (send cb-frame show #f) + (send this show #f))))] + [no-sd-button (instantiate button% () + (label "Cancel") + (parent hpanel) + (callback + (lambda (b ev) + (send main-sd-button + enable #t) + (send cb-frame show #f))))]) + (send main-sd-button enable #f) + (send cb-frame center) + (send cb-frame show #t)))]) + (define/override can-close? + (lambda () (shutdown-dialog) #f)) + (super-instantiate ()) + (set! panel + (instantiate vertical-panel% () + (parent this))) + (instantiate message% () + (label (format "Help Desk server running on port ~a" + (hd-cookie->port hd-cookie))) + (parent panel)) + (instantiate button% () + (label "Help Desk Home") + (parent panel) + (min-width 100) + (callback + (lambda (b ev) + (help-desk-browser hd-cookie)))) + (set! main-sd-button + (instantiate button% () + (label "Shutdown Server") + (parent panel) + (min-width 100) + (callback (lambda (b ev) + (shutdown-dialog))))))] [frame (instantiate hd-frame% () - (label "PLT Help Desk") - (min-width 175) - (stretchable-width #f) - (stretchable-height #f))]) + (label "PLT Help Desk") + (min-width 175) + (stretchable-width #f) + (stretchable-height #f))]) (send frame center) (send frame show #t) (when iconize? (send frame iconize #t))))) + diff --git a/collects/help/private/search.ss b/collects/help/private/search.ss index 569ec96c..66c3690a 100644 --- a/collects/help/private/search.ss +++ b/collects/help/private/search.ss @@ -3,40 +3,12 @@ "docpos.ss" "colldocs.ss" "server.ss" - "browser.ss" (lib "list.ss") - (lib "util.ss" "help" "servlets" "private") - (lib "specs.ss" "framework")) + (lib "util.ss" "help" "servlets" "private")) (provide do-search 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) (or (user-defined-doc-position x) (standard-html-doc-position x)))