#anchor
- (define (finddoc-page-anchor manual index-key)
- (finddoc-page-help manual index-key #t))
-
- (define ht (make-hash-table))
-
- ;; returns (list docdir index-key filename anchor title)
- ;; or throws an error
- (define (lookup manual index-key label)
- (let* ([key (string->symbol manual)]
- [docdir (find-doc-directory manual)]
- [l (hash-table-get ht key
- (lambda ()
- (let ([f (and docdir (build-path docdir "hdindex"))])
- (if (and f (file-exists? f))
- (let ([l (with-input-from-file f read)])
- (hash-table-put! ht key l)
- l)
- (error 'finddoc "manual index ~s not installed" manual)))))]
- [m (assoc index-key l)])
- (if m
- (cons docdir m)
- (error 'finddoc "index key ~s not found in manual ~s" index-key manual))))
-
- ;; finds the full path of the doc directory, if one exists
- ;; input is just the short name of the directory (as a path)
- (define (find-doc-directory doc)
- (ormap (lambda (d)
- (let ([p (build-path d doc)])
- (and (directory-exists? p)
- p)))
- (get-doc-search-dirs))))
diff --git a/collects/help/private/get-help-url.ss b/collects/help/private/get-help-url.ss
deleted file mode 100644
index 497b8c2c53..0000000000
--- a/collects/help/private/get-help-url.ss
+++ /dev/null
@@ -1,68 +0,0 @@
-(module get-help-url mzscheme
-
- #| Library responsible for turning a path on disk into a URL the help desk can use |#
- (require (lib "file.ss")
- "internal-hp.ss"
- (lib "contract.ss")
- (lib "etc.ss")
- (lib "config.ss" "planet")
- (lib "dirs.ss" "setup"))
-
- ; given a manual path, convert to absolute Web path
- ; manual path is an anchored path to a doc manual, never a servlet
- (define get-help-url
- (opt-lambda (manual-path [anchor #f])
- (let ([segments (explode-path (normalize-path manual-path))])
- (let loop ([candidates manual-path-candidates])
- (cond
- ;; shouldn't happen, unless documentation is outside
- ;; the set of doc dirs:
- [(null? candidates) "/cannot-find-docs.html"]
- [else
- (let ([candidate (car candidates)])
- (cond
- [(subpath/tail (car candidate) segments)
- =>
- (λ (l-o-path)
- ((cadr candidate) l-o-path anchor))]
- [else
- (loop (cdr candidates))]))])))))
-
- (define manual-path-candidates '())
- (define (maybe-add-candidate candidate host)
- (with-handlers ([exn:fail? void])
- (set! manual-path-candidates
- (cons (list (explode-path (normalize-path candidate))
- (λ (segments anchor)
- (format "http://~a:~a/servlets/static.ss/~a~a~a"
- internal-host
- (internal-port)
- host
- (apply string-append (map (λ (x) (format "/~a" (path->string x)))
- segments))
- (if anchor
- (string-append "#" anchor)
- ""))))
- manual-path-candidates))))
-
- ;; Add doc dirs later, so that they take precedence:
- (maybe-add-candidate (PLANET-DIR) planet-host)
- (for-each (λ (dir host) (maybe-add-candidate dir host))
- (append collects-dirs doc-dirs)
- (append collects-hosts doc-hosts))
-
- (define (subpath/tail short long)
- (let loop ([short short]
- [long long])
- (cond
- [(null? short) long]
- [(null? long) #f]
- [(equal? (car short) (car long))
- (loop (cdr short) (cdr long))]
- [else #f])))
-
- (provide/contract (get-help-url
- (opt->
- ((or/c path? path-string?))
- (string?)
- string?))))
diff --git a/collects/help/private/gui.ss b/collects/help/private/gui.ss
deleted file mode 100644
index e7eb4e4c81..0000000000
--- a/collects/help/private/gui.ss
+++ /dev/null
@@ -1,652 +0,0 @@
-#lang scheme/unit
- (require (lib "framework.ss" "framework")
- (lib "mred.ss" "mred")
-
- (lib "class.ss")
- (lib "contract.ss")
- (lib "etc.ss")
- (lib "list.ss")
- (lib "file.ss")
-
- (lib "string-constant.ss" "string-constants")
- (lib "external.ss" "browser")
-
- (lib "browser-sig.ss" "browser")
- (lib "url-sig.ss" "net")
- (lib "url-structs.ss" "net")
- (lib "uri-codec.ss" "net")
- "sig.ss"
- "../bug-report.ss"
- (lib "bday.ss" "framework" "private")
-
- "standard-urls.ss"
- "docpos.ss"
- "manuals.ss"
- "get-help-url.ss"
-
- "internal-hp.ss")
-
- (import browser^ url^)
- (export gui^)
-
- (define help-desk-frame<%>
- (interface (frame:standard-menus<%>)
- order-manuals
- get-language-name
- change-search-to-status
- set-search-status-contents
- change-status-to-search))
-
- (define bug-report/help-desk-mixin
- (mixin (frame:standard-menus<%>) ()
- (define/override (file-menu:create-open-recent?) #f)
- (define/override (help-menu:about-string)
- (string-constant plt:hd:about-help-desk))
- (define/override (help-menu:about-callback i e)
- (message-box (string-constant plt:hd:about-help-desk)
- (format
- (string-constant plt:hd:help-desk-about-string)
- (version:version) 1995 2007)
- this))
- (define/override (help-menu:create-about?) #t)
- (define/override (help-menu:after-about menu)
- (make-object menu-item% (string-constant plt:hd:help-on-help) menu
- (lambda (i e)
- (message-box
- (string-constant plt:hd:help-on-help)
- (string-constant plt:hd:help-on-help-details)
- this)))
- (new menu-item%
- (label (string-constant bug-report-submit-menu-item))
- (parent menu)
- (callback
- (lambda (x y)
- (help-desk:report-bug)))))
- (super-new)))
-
- (define (browser-scroll-frame-mixin %)
- (class %
- (inherit get-hyper-panel)
-
- (define/override (on-subwindow-char w e)
- (or (let ([txt (send (send (get-hyper-panel) get-canvas) get-editor)])
- (and txt
- (let ([km (send txt get-hyper-keymap)])
- (send km handle-key-event txt e))))
- (super on-subwindow-char w e)))
-
- (super-new)))
-
- ;; redirect urls to outside pages to external browsers (depending on the preferences settings)
- ;; also catches links into documentation that isn't installed yet and sends that
- ;; to the missing manuals page.
- (define make-catch-url-frame-mixin
- (let ()
- (define (catch-url-hyper-panel-mixin %)
- (class %
- (define/override (get-canvas%)
- (catch-url-canvas-mixin (super get-canvas%)))
- (super-new)))
-
- (define (catch-url-canvas-mixin %)
- (class %
-
- (define/override (get-editor%) (hd-editor-mixin (super get-editor%)))
-
- (define/override (remap-url url)
- (cond
- [(url? url)
- (cond
-
- ;; .plt files are always internal, no matter where from
- ;; they will be caught elsewhere.
- [(and (url-path url)
- (not (null? (url-path url)))
- (regexp-match #rx".plt$" (path/param-path (car (last-pair (url-path url))))))
- url]
-
- ;; files on download.plt-scheme.org in /doc are considered
- ;; things that we should view in the browser itself.
- [(is-download.plt-scheme.org/doc-url? url)
- url]
-
- ;; one of the "collects" hosts:
- [(and (equal? (internal-port) (url-port url))
- (ormap (lambda (host)
- (equal? host (url-host url)))
- doc-hosts))
- ;; Two things can go wrong with the URL:
- ;; 1. The corresponding doc might not be installed
- ;; 2. There's a relative reference from X to Y, and
- ;; X and Y are installed in different directories,
- ;; so the host is wrong for Y
- ;; Resolve 2, then check 1.
- (let* ([path (url-path url)]
- [manual (and (pair? path)
- (path/param-path (car path)))])
- (if manual
- ;; Find out where this manual is really located:
- (let* ([path (find-doc-directory (string->path manual))]
- [real-url (and path
- (get-help-url path))]
- [url (if real-url
- ;; Use the actual host:
- (make-url (url-scheme url)
- (url-user url)
- (url-host (string->url real-url))
- (url-port url)
- (url-path-absolute? url)
- (url-path url)
- (url-query url)
- (url-fragment url))
- ;; Can't do better than the original URL?
- ;; The manual is not installed.
- url)])
- (if (or (not path)
- (not (has-index-installed? path)))
- ;; Manual not installed...
- (let ([doc-pr (assoc (string->path manual) known-docs)])
- (unless doc-pr
- (error 'remap-url
- "Internal error: manual ~s not found in known-docs"
- manual))
- (string->url
- (make-missing-manual-url manual
- (cdr doc-pr)
- (url->string url))))
- ;; Manual here; use revised URL
- url))
- ;; Not a manual? Shouldn't happen.
- url))]
-
- ;; one of the other internal hosts
- [(and (equal? (internal-port) (url-port url))
- (is-internal-host? (url-host url)))
- url]
-
- ;; send the url off to another browser
- [(and (string? (url-scheme url))
- (not (member (url-scheme url) '("http"))))
- (send-url (url->string url))
- #f]
- [(preferences:get 'drscheme:help-desk:ask-about-external-urls)
- (case (ask-user-about-separate-browser)
- [(separate)
- (send-url (url->string url))
- #f]
- [(internal)
- url]
- [else #f])]
- [(preferences:get 'drscheme:help-desk:separate-browser)
- (send-url (url->string url))
- #f]
- [else url])]
- [else url]))
- (super-new)))
-
- ;; has-index-installed? : path -> boolean
- (define (has-index-installed? path)
- (and (get-index-file path) #t))
-
- (define sk-bitmap #f)
-
- (define hd-editor-mixin
- (mixin (hyper-text<%> editor<%>) ()
- (define/augment (url-allows-evaling? url)
- (and (is-internal-host? (url-host url))
- (equal? (internal-port) (url-port url))))
-
- (define show-sk? #t)
-
- (define/override (on-event evt)
- (cond
- [(and show-sk?
- (sk-bday?)
- (send evt button-down? 'right))
- (let ([admin (get-admin)])
- (let ([menu (new popup-menu%)])
- (new menu-item%
- (parent menu)
- (label (string-constant happy-birthday-shriram))
- (callback (lambda (x y)
- (set! show-sk? #f)
- (let ([wb (box 0)]
- [hb (box 0)]
- [xb (box 0)]
- [yb (box 0)])
- (send admin get-view xb yb wb hb)
- (send admin needs-update (unbox xb) (unbox yb) (unbox wb) (unbox hb))))))
- (send (get-canvas) popup-menu menu
- (+ (send evt get-x) 1)
- (+ (send evt get-y) 1))))]
- [else (super on-event evt)]))
-
-
- (inherit dc-location-to-editor-location get-admin)
- (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
- (super on-paint before? dc left top right bottom dx dy draw-caret)
- (when before?
- (when (and show-sk? (sk-bday?))
- (unless sk-bitmap
- (set! sk-bitmap (make-object bitmap% (build-path (collection-path "icons") "sk.jpg"))))
-
- (let ([admin (get-admin)])
- (when admin
- (let*-values ([(view-w view-h) (get-view-w/h admin)]
- [(view-x view-y)
- (values (- (/ view-w 2) (/ (send sk-bitmap get-width) 2))
- (- view-h (send sk-bitmap get-height)))]
- ;; note: view coordinates are not exactly canvas dc coordinates
- ;; but they are off by a fixed amount (same on all platforms)
- ;; (note: dc-location in this method means canvas dc, which is
- ;; different from the dc coming in here (offscreen bitmaps))
- [(editor-x editor-y) (dc-location-to-editor-location view-x view-y)]
- [(dc-x dc-y) (values (+ editor-x dx)
- (+ editor-y dy))])
- (send dc draw-bitmap sk-bitmap dc-x dc-y)))))))
- (define/private (get-view-w/h admin)
- (let ([wb (box 0)]
- [hb (box 0)])
- (send admin get-view #f #f wb hb)
- (values (unbox wb)
- (unbox hb))))
-
- (inherit get-canvas)
- (define/override (init-browser-status-line top-level-window)
- (send top-level-window change-search-to-status))
- (define/override (update-browser-status-line top-level-window s)
- (send top-level-window set-search-status-contents s))
- (define/override (close-browser-status-line top-level-window)
- (send top-level-window change-status-to-search))
-
- (super-new)))
-
- (lambda (%)
- (class %
- (define/override (get-hyper-panel%)
- (catch-url-hyper-panel-mixin (super get-hyper-panel%)))
- (super-new)))))
-
- (define (is-download.plt-scheme.org/doc-url? url)
- (and (equal? "download.plt-scheme.org" (url-host url))
- (not (null? (url-path url)))
- (equal? (path/param-path (car (url-path url))) "doc")))
-
- ;; ask-user-about-separate-browser : -> (union #f 'separate 'internal)
- (define (ask-user-about-separate-browser)
- (define separate-default? (preferences:get 'drscheme:help-desk:separate-browser))
-
- (let-values ([(result checked?)
- (message+check-box/custom
- (string-constant help-desk)
- (string-constant plt:hd:ask-about-separate-browser)
- (string-constant dont-ask-again-always-current)
- (string-constant plt:hd:homebrew-browser)
- (string-constant plt:hd:separate-browser)
- (string-constant cancel)
- #f ; no parent
- (cons
- (if separate-default?
- 'default=2
- 'default=1)
- '(no-default)))])
- (when checked?
- (preferences:set 'drscheme:help-desk:ask-about-external-urls #f))
- (case result
- [(2)
- (preferences:set 'drscheme:help-desk:separate-browser #t)
- 'separate]
- [(1)
- (preferences:set 'drscheme:help-desk:separate-browser #f)
- 'internal]
- [(#f 3)
- #f]
- [else (error 'ack)])))
-
- (define make-help-desk-framework-mixin
- (mixin (frame:searchable<%> frame:standard-menus<%>) ()
- (define/override (get-text-to-search)
- (send (send (send this get-hyper-panel) get-canvas) get-editor))
-
- (define/override (file-menu:create-new?) #t)
- (define/override (file-menu:new-callback x y) (new-help-desk))
-
- (define/override (file-menu:create-open-recent?) #f)
-
- (define/override (file-menu:create-open?) #f)
- (define/override (file-menu:create-print?) #t)
-
- (define/override (file-menu:print-callback x y)
- (let ([ed (send (send (send this get-hyper-panel) get-canvas) get-editor)])
- (and ed
- (send ed print))))
-
- (define/override (file-menu:between-open-and-revert file-menu)
- (super file-menu:between-open-and-revert file-menu)
- (instantiate menu:can-restore-menu-item% ()
- (parent file-menu)
- (callback (lambda (_1 _2) (open-url-callback)))
- (label (string-constant open-url...)))
- (instantiate menu:can-restore-menu-item% ()
- (parent file-menu)
- (label (string-constant reload))
- (callback (lambda (_1 _2) (send (send this get-hyper-panel) reload)))))
-
- (define/private (open-url-callback)
- (let ([url (get-url-from-user this)])
- (when url
- (let* ([hp (send this get-hyper-panel)]
- [hc (send hp get-canvas)])
- (send hc goto-url url #f)))))
-
- (define/override (on-size w h)
- (preferences:set 'drscheme:help-desk:frame-width w)
- (preferences:set 'drscheme:help-desk:frame-height h)
- (super on-size w h))
-
- (super-new
- (width (preferences:get 'drscheme:help-desk:frame-width))
- (height (preferences:get 'drscheme:help-desk:frame-height)))
-
- (frame:reorder-menus this)))
-
- (define make-search-button-mixin
- (mixin (frame:basic<%> hyper-frame<%>) ()
- (field [search-panel #f])
-
- ;; order-manuals : as in drscheme:language:language<%>
- ;; by default, search in all manuals
- (define/public (order-manuals x) (values x #t))
-
- ;; the name of the language to put in the top of the search results,
- ;; or #f if nothing is to be put there.
- (define/public (get-language-name) #f)
-
- (define/override (make-root-area-container class parent)
- (let* ([search-panel-parent (super make-root-area-container vertical-panel% parent)]
- [main-panel (make-object class search-panel-parent)])
- (set! search-panel (instantiate vertical-panel% ()
- (parent search-panel-parent)
- (stretchable-height #f)))
- main-panel))
-
- ;; these methods have the same name as the methods in the browser.
- ;; they are called during super initialization, so they protect themselves...
- (define/public (change-search-to-status)
- (when search/status-panel
- (send search/status-panel active-child status-panel)))
- (define/public (set-search-status-contents s)
- (when status-message
- (send status-message set-label (trim-string 200 s))))
- (define/private (trim-string n str)
- (cond
- [(<= (string-length str) n) str]
- [else (string-append (substring str 0 98)
- " ... "
- (substring str (- (string-length str)
- 97)
- (string-length str)))]))
-
- (define/public (change-status-to-search)
- (when search/status-panel
- (send search/status-panel active-child field-panel)
- (send search-field focus)))
-
- (field [search/status-panel #f]
- [field-panel #f]
- [search-field #f]
- [status-panel #f]
- [status-message #f]
- [choices-panel #f])
-
- (super-new (label (string-constant help-desk)))
-
- (let ([hp (send this get-hyper-panel)])
- (send hp set-init-page home-page-url)
- (send (send hp get-canvas) allow-tab-exit #t))
-
- (inherit get-menu-bar get-hyper-panel)
- (let ()
- (define search-menu (instantiate menu% ()
- (label (string-constant plt:hd:search))
- (parent (get-menu-bar))))
- (define search-menu-item (instantiate menu:can-restore-menu-item% ()
- (label (string-constant plt:hd:search))
- (parent search-menu)
- (shortcut #\e)
- (callback
- (lambda (x y) (search-callback #f)))))
- (define lucky-menu-item (instantiate menu:can-restore-menu-item% ()
- (label (string-constant plt:hd:feeling-lucky))
- (parent search-menu)
- (shortcut #\u)
- (callback
- (lambda (x y) (search-callback #t)))))
- (define stupid-internal-define-syntax1
- (set! search/status-panel (new panel:single%
- (parent search-panel)
- (stretchable-width #t))))
- (define stupid-internal-define-syntax2
- (set! field-panel (new horizontal-panel% (parent search/status-panel))))
- (define stupid-internal-define-syntax3
- (set! status-panel (new horizontal-panel% (parent search/status-panel))))
- (define stupid-internal-define-syntax4
- (set! status-message (new message%
- (parent status-panel)
- (stretchable-width #t)
- (label ""))))
- (define stupid-internal-define-syntax5
- (set! search-field (instantiate text-field% ()
- (label (string-constant plt:hd:find-docs-for))
- (callback (lambda (x y)
- (let ([on? (not (equal? "" (send search-field get-value)))])
- (send search-button enable on?)
- (send search-menu enable on?))))
- (parent field-panel))))
-
- ;; exposed to derived classes
- (define stupid-internal-define-syntax6
- (set! choices-panel (instantiate horizontal-panel% ()
- (parent search-panel)
- (alignment '(center center)))))
-
- (define search-button (instantiate button% ()
- (label (string-constant plt:hd:search))
- (parent field-panel)
- (callback (lambda (x y) (search-callback #f)))
- (style '(border))))
- (define search-where (instantiate choice% ()
- (label #f)
- (parent choices-panel)
- (selection (preferences:get 'drscheme:help-desk:search-where))
- (choices
- (list
- (string-constant plt:hd:search-for-keyword)
- (string-constant plt:hd:search-for-keyword-or-index)
- (string-constant plt:hd:search-for-keyword-or-index-or-text)))
- (callback
- (lambda (x y)
- (preferences:set 'drscheme:help-desk:search-where
- (send search-where get-selection))))))
- (define search-how (instantiate choice% ()
- (label #f)
- (parent choices-panel)
- (selection (preferences:get 'drscheme:help-desk:search-how))
- (choices
- (list
- (string-constant plt:hd:exact-match)
- (string-constant plt:hd:containing-match)
- (string-constant plt:hd:regexp-match)))
- (callback
- (lambda (x y)
- (preferences:set 'drscheme:help-desk:search-how
- (send search-how get-selection))))))
-
- (define grow-box-spacer (make-object grow-box-spacer-pane% choices-panel))
- (define (search-callback lucky?)
- (let-values ([(manuals doc.txt?) (order-manuals (map path->bytes (map car (find-doc-names))))])
- (let ([url (make-results-url
- (send search-field get-value)
- (case (send search-where get-selection)
- [(0) "keyword"]
- [(1) "keyword-index"]
- [(2) "keyword-index-text"])
- (case (send search-how get-selection)
- [(0) "exact-match"]
- [(1) "containing-match"]
- [(2) "regexp-match"])
- lucky?
- (map bytes->path manuals)
- doc.txt?
- (get-language-name))])
- (send (send (get-hyper-panel) get-canvas) goto-url url #f))))
-
- (send search-button enable #f)
- (send search-menu enable #f)
- (send search-field focus))))
-
- (define help-desk-frame-mixin #f)
- (define addl-mixins (lambda (x) x))
- (define (add-help-desk-mixin m)
- (if help-desk-frame-mixin
- (error 'add-help-desk-mixin "help desk frame has already been created")
- (set! addl-mixins (compose m addl-mixins))))
- (define (make-help-desk-frame-mixin)
- (or help-desk-frame-mixin
- (begin
- (set! help-desk-frame-mixin
- (compose
- addl-mixins
- (lambda (x) (class* x (help-desk-frame<%>) (super-new)))
- make-catch-url-frame-mixin
- bug-report/help-desk-mixin
- make-help-desk-framework-mixin
- browser-scroll-frame-mixin
- frame:searchable-mixin
- frame:standard-menus-mixin
- make-search-button-mixin))
- help-desk-frame-mixin)))
-
- (define new-help-desk
- (opt-lambda ([link home-page-url])
- (let ([f (new ((make-help-desk-frame-mixin) hyper-no-show-frame%))])
- (send f show #t)
- (goto-url link f)
- f)))
-
- (define (goto-hd-location sym)
- (let ([loc (get-hd-location sym)])
- (goto-url loc)))
-
- (define (goto-manual-link manual index-key)
- (goto-url (prefix-with-server (finddoc-page-anchor manual index-key))))
-
- (define (search-for-docs search-string search-type match-type lucky? docs)
- (let ([fr (or (find-help-desk-frame)
- (new-help-desk))])
- (search-for-docs/in-frame fr search-string search-type match-type lucky? docs)))
-
- (define (search-for-docs/in-frame fr search-string search-type match-type lucky? docs)
- (send fr show #t)
- (let-values ([(manuals doc.txt?) (send fr order-manuals (map path->bytes docs))])
- (goto-url (make-results-url search-string
- search-type
- match-type
- lucky?
- (map bytes->path manuals)
- doc.txt?
- (send fr get-language-name))
- fr)))
-
- (define goto-url
- (opt-lambda (link [fr (find-help-desk-frame)])
- (if fr
- (send (send (send fr get-hyper-panel) get-canvas) goto-url link #f)
- (new-help-desk link))))
-
- (define (show-help-desk)
- (let ([fr (find-help-desk-frame)])
- (if fr
- (send fr show #t)
- (new-help-desk))))
-
- (define (find-help-desk-frame)
- (let loop ([frames (send (group:get-the-frame-group) get-frames)])
- (cond
- [(null? frames) #f]
- [else (let ([frame (car frames)])
- (if (is-a? frame help-desk-frame<%>)
- frame
- (loop (cdr frames))))])))
-
- (define (get-url-from-user parent)
- (define d (make-object dialog% (string-constant open-url) parent 500))
- (define t
- (keymap:call/text-keymap-initializer
- (lambda ()
- (make-object text-field% (string-constant url:) d
- (lambda (t e)
- (update-ok))))))
- (define p (make-object horizontal-panel% d))
- (define browse (make-object button% (string-constant browse...) p
- (lambda (b e)
- (let ([f (get-file)])
- (when f
- (send t set-value (encode-file-path-as-url f))
- (update-ok))))))
-
- (define (encode-file-path-as-url f)
- (apply
- string-append
- "file:"
- (map
- (λ (x) (string-append "/" (uri-path-segment-encode (path->string x))))
- (explode-path f))))
-
- (define spacer (make-object vertical-pane% p))
- (define result #f)
- (define (ok-callback b e)
- (let* ([s (send t get-value)]
- [done (lambda ()
- ;; Might be called twice!
- (preferences:set 'drscheme:help-desk:last-url-string s)
- (send d show #f))])
- (with-handlers ([exn:fail?
- (lambda (x)
- (message-box (string-constant bad-url)
- (format (string-constant bad-url:this)
- (exn-message x))
- d))])
- (let* ([removed-spaces (regexp-replace #rx"^[ \t]*" s "")]
- [str (cond
- [(regexp-match #rx":" removed-spaces) removed-spaces]
- [(regexp-match #rx"^[a-zA-Z][a-zA-Z.]*($|/)" removed-spaces)
- (string-append "http://" removed-spaces)]
- [else
- (string-append "file:" removed-spaces)])]
-
- ;; just convert the string to test it out; don't use result...
- [url (string->url str)])
- (set! result str)
- (done)))))
- (define cancel-callback (lambda (b e) (send d show #f)))
- (define-values (ok cancel)
- (gui-utils:ok/cancel-buttons
- p
- ok-callback
- cancel-callback))
- (define (update-ok)
- (send ok enable
- (positive? (send (send t get-editor)
- last-position))))
- (define last-url-string (preferences:get 'drscheme:help-desk:last-url-string))
- (when last-url-string
- (send t set-value last-url-string)
- (let ([text (send t get-editor)])
- (send text set-position 0 (send text last-position))))
- (send p set-alignment 'right 'center)
- (update-ok)
- (send d center)
- (send t focus)
- (send d show #t)
- result)
diff --git a/collects/help/private/installed-components.ss b/collects/help/private/installed-components.ss
deleted file mode 100644
index 37dc4fb194..0000000000
--- a/collects/help/private/installed-components.ss
+++ /dev/null
@@ -1,120 +0,0 @@
-(module installed-components mzscheme
- (require (lib "list.ss")
- (lib "xml.ss" "xml")
- (lib "getinfo.ss" "setup")
- (lib "uri-codec.ss" "net")
- (lib "util.ss" "help" "servlets" "private"))
-
- (provide help-desk:installed-components)
-
- ;; comp = (make-comp string xexpr)
- ;; this represents a collection with a blurb field.
- ;; the name names the collection and the xml is its xexpr blurb
- (define-struct comp (name xml))
-
- ;; help-desk:installed-components url : -> (listof (list string xexpr))
- ;; represents all of the collections with blurb fields
- (define (help-desk:installed-components)
- (let ([comps
- (sort (filter (lambda (x) x)
- (map (lambda (c) (get-blurb c)) (all-collections)))
- comp<=?)])
- (map comp-xml comps)))
-
- ;; all-collections : -> (lisof string)
- ;; returns a list of the collections from the current-library-collections-path parameter
- (define (all-collections)
- (let ([colls (make-hash-table 'equal)])
- (for-each
- (lambda (collection-path-dir)
- (when (directory-exists? collection-path-dir)
- (for-each
- (lambda (collection)
- (when (and (directory-exists? (build-path collection-path-dir collection))
- (not (member (path->bytes collection) '(#"CVS" #".svn"))))
- (hash-table-put! colls collection #t)))
- (directory-list collection-path-dir))))
- (current-library-collection-paths))
- (sort (hash-table-map colls (lambda (x v) x))
- (lambda (x y) (string<=? (path->string x) (path->string y))))))
-
- ;; get-blurb : string url -> xexpr
- ;; builds the xexpr for a collection, based on its name a blurb
- (define (get-blurb collection)
- (let/ec k
- (let ([proc (with-handlers ([(lambda (x) (not (exn:break? x)))
- (lambda (x) #f)])
- (get-info (list collection)))])
- (unless proc
- (k #f))
- (let* ([name (with-handlers ([(lambda (x) #t)
- (lambda (x)
- (k
- (make-comp
- collection
- `(li
- (font ((color "forestgreen")) (b () ,collection))
- (p
- (font
- ((color "red"))
- (i ,(format "error during 'name: ~a"
- (if (exn? x)
- (exn-message x)
- x)))))))))])
- (proc 'name (lambda () (k #f))))]
- [blurb (with-handlers ([(lambda (x) #t)
- (lambda (x)
- (k
- (make-comp
- collection
- `(li
- (font ((color "forestgreen")) (b () ,name))
- (br)
- (font ((color "red"))
- (i
- ,(format "error during 'blurb: ~a"
- (if (exn? x)
- (exn-message x)
- x))))))))])
- (proc 'blurb (lambda () (k #f))))]
- [blurb-ok? (andmap xexpr? blurb)])
- (make-comp
- name
- `(li
- (font ((color "forest green"))
- (b ,name))
- (br)
- ,@(append
- (if blurb-ok?
- blurb
- (list `(font ((color "red"))
- "blurb was not a list of xexprs")))
- (let ([fname (build-path (collection-path collection) "doc.txt")])
- (if (file-exists? fname)
- (list
- " See "
- `(A ((HREF ,(format
- "/servlets/doc-anchor.ss?file=~a&caption=Documentation for the ~a collection&name=~a"
- (uri-encode (path->string fname))
- collection
- collection)))
- "the documentation")
- " for more information.")
- null)))))))))
-
- ;; build-string-from-comp : comp -> string
- ;; constructs a string version of the xexpr from a comp
- (define (build-string-from-comp comp)
- (let ([blurb (comp-xml comp)]
- [p (open-output-string)])
- (write-xml/content
- (xexpr->xml
- blurb)
- p)
- (newline p)
- (newline p)
- (get-output-string p)))
-
- ;; comp<=? : comp comp -> boolean
- ;; compares two comps for sorting
- (define (comp<=? ca cb) (string<=? (comp-name ca) (comp-name cb))))
diff --git a/collects/help/private/internal-hp.ss b/collects/help/private/internal-hp.ss
deleted file mode 100644
index 4ae2ffb15c..0000000000
--- a/collects/help/private/internal-hp.ss
+++ /dev/null
@@ -1,54 +0,0 @@
-(module internal-hp mzscheme
- (require (lib "dirs.ss" "setup")
- (lib "config.ss" "planet")
- "options.ss")
- (provide internal-port
- is-internal-host? internal-host
- collects-hosts collects-dirs
- doc-hosts doc-dirs
- planet-host)
-
- ;; Hostnames defined here should not exist as real machines
-
- ;; The general idea is that there's one "virtual" host for
- ;; every filesystem tree that we need to access.
- ;; (now we use static.ss/host/yadayda instead of the virtual
- ;; host docX.localhost, but we still need to keep track of
- ;; the file system roots)
- ;; The "get-help-url.ss" library provides a function to
- ;; convert a path into a suitable URL (i.e., a URL using
- ;; the right virtual host).
- ;; The "gui.ss" library performs a bit of extra URL
- ;; processing at the last minute, sometimes switching
- ;; a URL for a manual to a different host. (That's needed
- ;; when cross-manual references are implemented as relative
- ;; URLs.)
-
- (define internal-host "localhost")
-
- (define (is-internal-host? str)
- (member str all-internal-hosts))
-
- (define (generate-hosts prefix dirs)
- (let loop ([dirs dirs][n 0])
- (if (null? dirs)
- null
- (cons (format "~a~a" prefix n)
- (loop (cdr dirs) (add1 n))))))
-
- (define planet-host "planet")
-
- (define collects-dirs
- (get-collects-search-dirs))
- (define collects-hosts
- (generate-hosts "collects" collects-dirs))
-
- (define doc-dirs
- (get-doc-search-dirs))
- (define doc-hosts
- (generate-hosts "doc" doc-dirs))
-
- (define all-internal-hosts
- (append (list internal-host planet-host)
- collects-hosts
- doc-hosts)))
diff --git a/collects/help/private/link.ss b/collects/help/private/link.ss
deleted file mode 100644
index c7422410f5..0000000000
--- a/collects/help/private/link.ss
+++ /dev/null
@@ -1,50 +0,0 @@
-(module link mzscheme
- (require (lib "web-server-unit.ss" "web-server")
- (lib "web-server-sig.ss" "web-server")
- (lib "web-config-sig.ss" "web-server")
-
- (lib "unit.ss")
-
- (lib "tcp-sig.ss" "net")
- (lib "url-sig.ss" "net")
- (lib "url-unit.ss" "net")
-
- (lib "browser-sig.ss" "browser")
- (lib "browser-unit.ss" "browser")
-
- (lib "plt-installer-sig.ss" "setup")
- (lib "plt-installer.ss" "setup")
-
- (lib "mred-unit.ss" "mred")
- (lib "mred-sig.ss" "mred")
-
- "tcp-intercept.ss"
- "sig.ss"
-
- "gui.ss"
- "main.ss"
- "config.ss")
-
- (define-unit-from-context inst@ setup:plt-installer^)
- (define-unit-from-context real-tcp@ tcp^)
- (define-unit-binding config@ (make-config) (import) (export web-config^))
-
- (define-compound-unit/infer help-desk@
- (import)
- (export gui^ main^ web-server^)
- (link inst@
- standard-mred@
- (((real-tcp : tcp^)) real-tcp@)
- config@
- (((real-url : url^)) url@ real-tcp)
- (() web-server@ real-tcp)
- (((ic-tcp : tcp^)) tcp-intercept@)
- (((pre-ic-url : url^)) url@ ic-tcp)
- (((ic-url : url^)) url-intercept@ pre-ic-url)
- (() browser@ ic-tcp ic-url)
- (() gui@ ic-url)
- main@))
-
- (define-values/invoke-unit/infer help-desk@)
-
- (provide-signature-elements gui^ main^ web-server^))
diff --git a/collects/help/private/main.ss b/collects/help/private/main.ss
deleted file mode 100644
index 4be43146c2..0000000000
--- a/collects/help/private/main.ss
+++ /dev/null
@@ -1,168 +0,0 @@
-#lang scheme/unit
- (require (lib "framework.ss" "framework")
- (lib "mred.ss" "mred")
- (lib "class.ss")
- (lib "external.ss" "browser")
- (lib "string-constant.ss" "string-constants")
- (lib "xml.ss" "xml")
- (lib "htmltext.ss" "browser")
- (prefix home: "../servlets/home.ss")
- "sig.ss")
-
- (import)
- (export main^)
-
- ;; where should the pref stuff really go?
- (preferences:set-default 'drscheme:help-desk:last-url-string "" string?)
- (preferences:set-default 'drscheme:help-desk:frame-width 350 number?)
- (preferences:set-default 'drscheme:help-desk:frame-height 400 number?)
- (preferences:set-default 'drscheme:help-desk:search-how 1 (lambda (x) (member x '(0 1 2))))
- (preferences:set-default 'drscheme:help-desk:search-where 1 (lambda (x) (member x '(0 1 2))))
-
- (preferences:set-default 'drscheme:help-desk:separate-browser #t boolean?)
- (preferences:set-default 'drscheme:help-desk:ask-about-external-urls #t boolean?)
-
- (preferences:set-default 'drscheme:help-desk:font-size
- (cons #f
- (let* ([txt (make-object text%)]
- [stl (send txt get-style-list)]
- [bcs (send stl basic-style)])
- (send bcs get-size)))
- (λ (x)
- (and (pair? x)
- (boolean? (car x))
- (and (integer? (cdr x))
- (<= 0 (cdr x) 255)))))
-
- ;; create "Html Standard" style to be able to
- ;; adjust its size in the preferences dialog
- (let* ([sl (editor:get-standard-style-list)]
- [html-standard-style-delta (make-object style-delta% 'change-nothing)]
- [html-standard-style
- (send sl find-or-create-style
- (send sl find-named-style "Standard")
- html-standard-style-delta)])
- (send sl new-named-style "Html Standard" html-standard-style))
-
- (preferences:add-callback
- 'drscheme:help-desk:font-size
- (λ (k v) (update-font-size v)))
-
- (define (update-font-size v)
- (let ([style (send (editor:get-standard-style-list) find-named-style "Html Standard")])
- (send style set-delta
- (if (car v)
- (make-object style-delta% 'change-size (cdr v))
- (make-object style-delta% 'change-nothing)))))
- (update-font-size (preferences:get 'drscheme:help-desk:font-size))
-
- (add-to-browser-prefs-panel
- (lambda (panel)
- (let* ([cbp (instantiate group-box-panel% ()
- (parent panel)
- (label (string-constant plt:hd:external-link-in-help))
- (alignment '(left center))
- (stretchable-height #f)
- (style '(deleted)))]
- [cb (instantiate check-box% ()
- (label (string-constant plt:hd:use-homebrew-browser))
- (parent cbp)
- (value (not (preferences:get 'drscheme:help-desk:separate-browser)))
- (callback
- (lambda (cb evt)
- (preferences:set 'drscheme:help-desk:separate-browser
- (not (send cb get-value))))))])
- ;; Put checkbox panel at the top:
- (send panel change-children (lambda (l) (cons cbp l)))
- (preferences:add-callback
- 'drscheme:help-desk:separate-browser
- (lambda (p v) (send cb set-value (not v))))
- (void))))
-
- (define (add-help-desk-font-prefs show-example?)
- (preferences:add-panel
- (list (string-constant font-prefs-panel-title)
- (string-constant help-desk))
- (lambda (panel)
- (let* ([vp (new vertical-panel% (parent panel) (alignment '(left top)))]
- [use-drs (new check-box%
- (label (string-constant use-drscheme-font-size))
- (parent vp)
- (value (not (car (preferences:get 'drscheme:help-desk:font-size))))
- (callback
- (λ (cb y)
- (preferences:set 'drscheme:help-desk:font-size
- (cons (not (send cb get-value))
- (cdr (preferences:get
- 'drscheme:help-desk:font-size)))))))]
- [size (new slider%
- (label (string-constant font-size))
- (min-value 1)
- (max-value 255)
- (parent vp)
- (callback
- (λ (size evt)
- (preferences:set 'drscheme:help-desk:font-size
- (cons
- #t
- (send size get-value)))))
- (init-value
- (cdr (preferences:get 'drscheme:help-desk:font-size))))]
- [hp (new horizontal-panel%
- (alignment '(center center))
- (stretchable-height #f)
- (parent vp))]
- [mk-button
- (λ (label func)
- (new button%
- (parent hp)
- (label label)
- (callback
- (λ (k v)
- (let ([old (preferences:get 'drscheme:help-desk:font-size)])
- (preferences:set 'drscheme:help-desk:font-size
- (cons (car old)
- (func (cdr old)))))))))]
- [sub1-button (mk-button "-1" sub1)]
- [add1-button (mk-button "+1" add1)]
- [enable/disable
- (λ (v)
- (send size enable (car v))
- (send sub1-button enable (car v))
- (send add1-button enable (car v))
- (send size set-value (cdr v)))])
- (preferences:add-callback
- 'drscheme:help-desk:font-size
- (λ (k v)
- (enable/disable v)))
- (enable/disable (preferences:get 'drscheme:help-desk:font-size))
-
- (when show-example?
- (let* ([show-message
- (λ ()
- (message-box
- (string-constant help-desk)
- (string-constant help-desk-this-is-just-example-text)))]
- [mix
- (λ (%)
- (class %
- (inherit set-clickback)
- (define/override (add-link p1 p2 s)
- (set-clickback p1 p2 (lambda (e x y) (show-message))))
- (define/override (add-thunk-callback p1 p2 thunk)
- (set-clickback p1 p2 (lambda (e p1 p2) (show-message))))
- (define/override (add-scheme-callback p1 p2 scheme)
- (set-clickback p1 p2 (lambda (e p1 p2) (show-message))))
- (super-new)))]
- [text (new (mix (html-text-mixin (text:hide-caret/selection-mixin
- text:standard-style-list%))))]
- [msg (new message% (parent vp) (label (string-constant example-text)))]
- [ec (new editor-canvas% (parent vp) (editor text))])
- (let-values ([(in out) (make-pipe)])
- (thread
- (λ ()
- (write-xml/content (xexpr->xml (home:start #f)) out)
- (close-output-port out)))
- (render-html-to-text in text #f #t))))
-
- vp))))
\ No newline at end of file
diff --git a/collects/help/private/manuals.ss b/collects/help/private/manuals.ss
deleted file mode 100644
index f0d08eeca5..0000000000
--- a/collects/help/private/manuals.ss
+++ /dev/null
@@ -1,380 +0,0 @@
-(module manuals mzscheme
- (require (lib "list.ss")
- (lib "date.ss")
- (lib "string-constant.ss" "string-constants")
- (lib "xml.ss" "xml")
- (lib "contract.ss")
- (lib "getinfo.ss" "setup")
- (lib "uri-codec.ss" "net")
- (lib "dirs.ss" "setup")
- (lib "match.ss")
- "finddoc.ss"
- "colldocs.ss"
- "docpos.ss"
- "standard-urls.ss"
- "get-help-url.ss"
- "../servlets/private/util.ss")
-
- ;; type sec = (make-sec name regexp (listof regexp))
- (define-struct sec (name reg seps))
-
- ;; sections : (listof sec)
- ;; determines the section breakdown for the manuals
- ;; elements in the outer list:
- ;; string : name of section
- ;; predicate : determines if a manual is in the section (based on its title)
- ;; breaks -- where to insert newlines
- (define sections
- (list (make-sec "Getting started"
- #rx"(Tour)|(Teach Yourself)"
- '())
- (make-sec "Languages"
- #rx"Language|MrEd"
- '(#rx"Beginning Student" #rx"ProfessorJ Beginner"))
- (make-sec "Tools" #rx"PLT DrScheme|PLT mzc|TeX2page|Web Server|PLoT" '())
- (make-sec "Libraries" #rx"SRFI|MzLib|Framework|PLT Miscellaneous|Teachpack|Swindle" '())
- (make-sec "Writing extensions" #rx"Tools|Inside|Foreign" '())
- (make-sec "Other" #rx"" '())))
-
- ; main-manual-page : string -> xexpr
- ; return link to main manual page of a doc collection, like "mred"
- (define (main-manual-page manual)
- (let* ([entry (assoc (string->path manual) known-docs)]
- [name (or (and entry (cdr entry))
- manual)]
- [doc-dir (find-doc-directory manual)])
- (if doc-dir
- (let ([href (get-help-url doc-dir)])
- `(A ((HREF ,href)) ,name))
- name)))
-
- ; manual-entry: string string string -> xexpr
- ; man is manual name
- ; ndx is index into the manual
- ; txt is the link text
- (define (manual-entry man ndx txt)
- (with-handlers ([exn:fail?
- ;; warning: if the index file isn't present, this page
- (lambda (x)
- `(font ((color "red")) ,txt " [" ,(exn-message x) "]"))])
- `(A ((HREF ,(finddoc-page man ndx))) ,txt)))
-
- (define (basename path)
- (let-values ([(dir name dir?) (split-path path)]) name))
-
- (define (find-doc-names)
- (let* ([dirs (find-doc-directories)]
- [installed (map basename dirs)]
- [uninstalled (filter (lambda (x) (not (member (car x) installed)))
- known-docs)])
- (append (map (lambda (short-name long-name)
- (cons short-name (get-doc-name long-name)))
- installed dirs)
- uninstalled)))
-
- ;; find-doc-directories : -> (listof path)
- ;; constructs a sorted list of directories where documentation may reside.
- (define (find-doc-directories)
- (let ([unsorted (append (find-info.ss-doc-directories)
- (find-doc-directories-in-toplevel-docs))])
- (sort unsorted compare-docs)))
-
- (define (find-info.ss-doc-directories)
- (let ([dirs (find-relevant-directories '(html-docs) 'all-available)])
- (let loop ([dirs dirs])
- (cond
- [(null? dirs) null]
- [else (let* ([dir (car dirs)]
- [info (get-info/full dir)])
- (cond
- [info
- (let ([html-doc-paths (info 'html-docs (lambda () #f))])
- (cond
- [(and (list? html-doc-paths)
- (andmap path-string? html-doc-paths))
- (let ([candidates (map (lambda (x) (build-path dir x)) html-doc-paths)])
- (for-each (λ (c)
- (unless (directory-exists? c)
- (fprintf (current-error-port)
- "found reference to ~a in html-docs for ~a, but it is not a directory\n"
- (path->string c)
- (path->string dir))))
- candidates)
- (append (filter directory-exists? candidates)
- (loop (cdr dirs))))]
- [else
- (loop (cdr dirs))]))]
- [else (loop (cdr dirs))]))]))))
-
- (define (find-doc-directories-in-toplevel-docs)
- (apply append
- (map (lambda (docs-path)
- (filter directory-exists?
- (map (lambda (doc-path)
- (build-path docs-path doc-path))
- (if (directory-exists? docs-path)
- (filter (lambda (x)
- (not (member (path->string x)
- '(".svn" "CVS"))))
- (directory-list docs-path))
- '()))))
- (get-doc-search-dirs))))
-
- (define (find-manuals)
- (let* ([docs (sort (filter get-index-file (find-doc-directories))
- compare-docs)]
- [names (map get-doc-name docs)]
- [names+paths (map cons names docs)])
- (let-values ([(collections-doc-files collection-names) (colldocs)])
- `((H1 "Installed Manuals")
- ,@(if (repos-or-nightly-build?)
- (list
- '(b "Subversion: ")
- `(a ((mzscheme
- ,(to-string/escape-quotes
- `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)))))
- ,(string-constant plt:hd:refresh-all-manuals))
- 'nbsp 'nbsp
- `(a ((href ,flush-manuals-url)) "flush index and keyword cache")
- '(br))
- (list))
- ,@(build-known-manuals names+paths)
- (h3 "Doc.txt")
- (ul ,@(map
- (lambda (collection-doc-file name)
- (let ([path (build-path (car collection-doc-file) (cadr collection-doc-file))])
- `(li ,(cond
- [(file-exists? path)
- `(a ((href ,(format "/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a"
- ;; escape colons and other junk
- (uri-encode (path->string path))
- (uri-encode name)
- (format "Documentation for ~a " name))))
- ,(format "~a " name))]
- [else
- `(font ((color "red"))
- ,(format "~a: specified doc.txt file (~a) not found"
- name path))]))))
- collections-doc-files
- collection-names))
-
- ,@(let ([uninstalled (get-uninstalled docs)])
- (if (null? uninstalled)
- '()
- `((h3 "Uninstalled Manuals")
- (ul ,@(map
- (lambda (doc-pair)
- (let* ([manual (car doc-pair)]
- [name (cdr doc-pair)]
- [manual-path (find-doc-directory manual)])
- `(li "Download and install "
- (a ((mzscheme
- ,(to-string/escape-quotes
- `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
- (list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path)
- ,(path->bytes manual))
- ,name))))))
- ,name)
- ,(if (and manual-path
- (or (file-exists? (build-path manual-path "hdindex"))
- (file-exists? (build-path manual-path "keywords"))))
- " (index installed)"
- ""))))
- uninstalled)))))))))
-
-
- ;; build-known-manuals : (listof (cons string[title] string[path])) -> (listof xexpr)
- (define (build-known-manuals names+paths)
- (let loop ([sections sections]
- [manuals names+paths])
- (cond
- [(null? sections) null]
- [else
- (let* ([section (car sections)]
- [in (filter (lambda (x) (regexp-match (sec-reg section)
- (car x)))
- manuals)]
- [out (filter (lambda (x) (not (regexp-match (sec-reg section)
- (car x))))
- manuals)])
- (append (build-known-section section in)
- (loop (cdr sections) out)))])))
-
- ;; build-known-section : sec (listof (cons string[title] string[path]))) -> (listof xexpr)
- (define (build-known-section sec names+paths)
- (if (null? names+paths)
- '()
- `((h3 ,(sec-name sec))
- (ul ,@(map (match-lambda
- ["" '(p)]
- [(title . path) (mk-link path title)])
- (let loop ([breaks (sec-seps sec)]
- [names+paths names+paths])
- (cond
- [(null? breaks) names+paths]
- [else
- (let ([break (car breaks)])
- (loop (cdr breaks)
- (break-between (car breaks) names+paths)))])))))))
-
- ;; break-between : regexp
- ;; (listof (union string (cons string string)))
- ;; -> (listof (union string (cons string string)))
- ;; adds the para-mark string into the list at the first place
- ;; that the regexp fails to match (not counting other para-marks
- ;; in the list)
- (define (break-between re l)
- (let ([para-mark "
"])
- (let loop ([l l])
- (cond
- [(null? l) null]
- [else
- (let ([fst (car l)])
- (cond
- [(pair? fst)
- (let ([name (car fst)])
- (if (regexp-match re name)
- (cons para-mark l)
- (cons fst (loop (cdr l)))))]
- [else (cons fst (loop (cdr l)))]))]))))
-
-
- ;; mk-link : string string -> xexpr
- (define (mk-link doc-path name)
- (let* ([manual-name (basename doc-path)]
- [index-file (get-index-file doc-path)])
- `(li (a ((href ,(get-help-url (build-path doc-path index-file))))
- ,name)
- ,@(cond
- [(and (repos-or-nightly-build?)
- (file-exists? (build-path doc-path index-file)))
- `((br)
- 'nbsp
- 'nbsp
- (font ((size "-1"))
- ,@(if (is-known-doc? doc-path)
- (list
- "["
- `(a ((mzscheme
- ,(to-string/escape-quotes
- `((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
- (list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path)
- ,(path->bytes manual-name))
- ,name))))))
- ,(string-constant plt:hd:refresh))
- "]" 'nbsp)
- (list))))]
- [else
- (list
- (format (string-constant plt:hd:manual-installed-date)
- (date->string
- (seconds->date
- (file-or-directory-modify-seconds
- (build-path doc-path index-file))))))]))))
-
- (define (to-string/escape-quotes exp)
- (regexp-replace* #rx"\"" (format "~s" exp) "|"))
-
- ;; get-doc-name : path -> string
- (define cached-doc-names (make-hash-table 'equal))
- (define (get-doc-name doc-dir)
- (hash-table-get cached-doc-names doc-dir
- (lambda ()
- (let ([res (compute-doc-name doc-dir)])
- (hash-table-put! cached-doc-names doc-dir res)
- res))))
-
- ;; compute-doc-name : path -> string[title of manual]
- ;; gets the title either from the known docs list, by parsing the
- ;; html, or if both those fail, by using the name of the directory
- ;; Special-cases the help collection. It's not a known doc directory
- ;; per se, so it won't appear in known-docs, but its name is always
- ;; the same.
- (define (compute-doc-name doc-dir)
- (let ([doc-short-dir-name (basename doc-dir)])
- (cond
- [(equal? (string->path "help") doc-short-dir-name) "PLT Help Desk"]
- [(get-known-doc-name doc-dir) => values]
- [else (let* ([main-file (get-index-file doc-dir)]
- [m (and main-file
- (call-with-input-file (build-path doc-dir main-file)
- (lambda (inp) (regexp-match re:title inp))))])
- (if m
- (bytes->string/utf-8 (cadr m))
- (path->string doc-short-dir-name)))])))
- (define re:title
- #rx"<[tT][iI][tT][lL][eE]>[ \t\r\n]*(.*?)[ \t\r\n]*")
-
- ;; is-known-doc? : string[path] -> boolean
- (define (is-known-doc? doc-path)
- (and (assoc (basename doc-path) known-docs) #t))
-
- ;; get-known-doc-name : string[full-path] -> (union string #f)
- (define (get-known-doc-name doc-path)
- (cond [(assoc (basename doc-path) known-docs) => cdr] [else #f]))
-
- ;; get-uninstalled : (listof path) -> (listof (cons path string[docs-name]))
- (define (get-uninstalled docs)
- (let ([ht (make-hash-table 'equal)])
- (for-each (lambda (known-doc)
- (hash-table-put! ht
- (car known-doc)
- (cdr known-doc)))
- known-docs)
- (for-each (lambda (doc) (hash-table-remove! ht (basename doc))) docs)
- (sort (hash-table-map ht cons)
- (λ (a b) (compare-docs (car a) (car b))))))
-
- (define (compare-docs a b)
- (let ([ap (standard-html-doc-position (basename a))]
- [bp (standard-html-doc-position (basename b))])
- (cond [(= ap bp) (stringstring a) (path->string b))]
- [else (< ap bp)])))
-
- ;; get-manual-index : string -> html
- (define (get-manual-index manual-dirname) (get-help-url (build-path (find-doc-dir) manual-dirname)))
-
- ;; get-index-file : path -> (union #f path)
- ;; returns the name of the main file, if one can be found
- (define (get-index-file doc-dir)
- (cond
- [(file-exists? (build-path doc-dir "index.htm"))
- (build-path "index.htm")]
- [(file-exists? (build-path doc-dir "index.html"))
- (build-path "index.html")]
- [(tex2page-detected doc-dir)
- =>
- (lambda (x) x)]
- [else #f]))
-
- ;; tex2page-detected : string -> (union #f string)
- (define (tex2page-detected dir)
- (let loop ([contents (directory-list dir)])
- (cond
- [(null? contents) #f]
- [else (let* ([file (car contents)]
- [m (regexp-match #rx#"(.*)-Z-H-1.html" (path->bytes file))])
- (or (and m
- (file-exists? (build-path dir file))
- (let ([index-file
- (bytes->path
- (bytes-append (cadr m) #".html"))])
- (if (file-exists? (build-path dir index-file))
- index-file
- #f)))
- (loop (cdr contents))))])))
-
-
- (provide find-manuals
- main-manual-page
- finddoc
- finddoc-page-anchor)
-
- (provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
- [finddoc-page (string? string? . -> . string?)]
- [get-doc-name (path? . -> . string?)]
- [find-doc-directories (-> (listof path?))]
- [find-doc-directory (path? . -> . (or/c false/c path?))]
- [find-doc-names (-> (listof (cons/c path? string?)))]
- [get-manual-index (-> string? string?)]
- [get-index-file (path? . -> . (or/c false/c path?))]))
diff --git a/collects/help/private/options.ss b/collects/help/private/options.ss
deleted file mode 100644
index d3e54d264a..0000000000
--- a/collects/help/private/options.ss
+++ /dev/null
@@ -1,22 +0,0 @@
-(module options mzscheme
-
- ;; This module provides configuration options that are shared
- ;; between servlets and the web-server. (Mostly to allow
- ;; configuration as an application or as a standalone server.)
-
- (provide helpdesk-platform internal-port)
-
- ;; internal browser or external browser?
- ;; (used to produce simpler html for the internal browser)
- (define helpdesk-platform
- (make-parameter
- 'internal-browser-simple ; main page only
- ;; 'internal-browser ; menu + main page
- ;; 'external-browser
- ))
-
- ;; Port for the server to listen on
- ;; (relevant only for a standalone server)
- (define internal-port (make-parameter 8012))
-
- )
diff --git a/collects/help/private/path.ss b/collects/help/private/path.ss
deleted file mode 100644
index f842a3ae08..0000000000
--- a/collects/help/private/path.ss
+++ /dev/null
@@ -1,10 +0,0 @@
-(module path mzscheme
- (require (lib "contract.ss"))
- (define (servlet-path? path)
- (if (regexp-match #rx#"^/servlets/"
- (path->bytes path))
- #t
- #f))
- (provide/contract
- [servlet-path? (path? . -> . boolean?)]))
-
diff --git a/collects/help/private/search.ss b/collects/help/private/search.ss
deleted file mode 100644
index 3c20106433..0000000000
--- a/collects/help/private/search.ss
+++ /dev/null
@@ -1,604 +0,0 @@
-(module search mzscheme
- (require (lib "string-constant.ss" "string-constants")
- "colldocs.ss"
- "path.ss"
- "manuals.ss"
- (lib "port.ss")
- (lib "getinfo.ss" "setup")
- (lib "list.ss")
- (lib "plt-match.ss")
- (lib "contract.ss")
- (lib "dirs.ss" "setup"))
-
- (provide doc-collections-changed
- reset-doc-lists
- extract-doc-txt
- load-txt-keywords-into-hash-table)
- (provide/contract
- [do-search
- (string?
- number?
- boolean?
- boolean?
- (listof path?)
- boolean?
- any/c
- (-> any)
- (string? any/c . -> . void?)
- (string? any/c . -> . void?)
- (string? string? string? path? (or/c string? number? false/c) any/c . -> . void?)
- . -> .
- (or/c string? false/c))]
-
- (build-string-finds/finds (string?
- boolean?
- boolean?
- . -> .
- (values (listof string?)
- (listof (or/c regexp? string?)))))
-
- (non-regexp (string? . -> . string?)))
-
- (define doc-dirs (get-doc-search-dirs))
-
- ; These are set by reset-doc-lists:
- ; docs, doc-names and doc-kinds are parallel lists. doc-kinds
- ; distinguishes between the two variants of docs.
- ; docs : (list-of (union string (list path string)))
- (define docs null)
- ; doc-names : (list-of string)
- (define doc-names null)
- ; doc-kinds : (list-of symbol)
- (define doc-kinds null)
- ; doc-collection-date : (union #f number 'none)
- (define doc-collection-dates (map (lambda (x) #f) doc-dirs))
-
- (define (dir-date/none dir)
- (with-handlers ([exn:fail:filesystem? (lambda (x) 'none)])
- (file-or-directory-modify-seconds dir)))
-
- (define (reset-doc-lists)
- ; Locate standard HTML documentation
- (define-values (std-docs std-doc-names)
- (let* ([docs (find-doc-directories)]
- [doc-names (map get-doc-name docs)])
- (values docs doc-names)))
-
- ; Check collections for doc.txt files:
- (define-values (txt-docs txt-doc-names) (colldocs))
-
- (set! docs (append std-docs txt-docs))
-
- (set! doc-names (append
- std-doc-names
- (map (lambda (s) (format "the ~a" s))
- txt-doc-names)))
- (set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))
-
- (set! doc-collection-dates (map dir-date/none doc-dirs)))
-
- (define MAX-HIT-COUNT 300)
-
- (define (clean-html s)
- (regexp-replace*
- "&[^;]*;"
- (regexp-replace*
- "<[^>]*>"
- (regexp-replace*
- "&"
- (regexp-replace*
- ">"
- (regexp-replace*
- "<"
- s
- "<")
- ">")
- "\\&")
- "")
- ""))
-
- (define (with-hash-table ht key compute)
- (hash-table-get
- ht
- key
- (lambda ()
- (let ([v (compute)])
- (hash-table-put! ht key v)
- v))))
-
- (define html-keywords (make-hash-table 'equal))
- (define (load-html-keywords doc)
- (with-hash-table
- html-keywords
- doc
- (lambda ()
- (transform-keywords
- (build-path doc "keywords")))))
-
- (define html-indices (make-hash-table 'equal))
- (define (load-html-index doc)
- (with-hash-table
- html-indices
- doc
- (lambda ()
- (transform-hdindex
- (build-path doc "hdindex")))))
-
- ;; transform-hdindex : any -> (listof (list string path string string)
- ;; makes sure the input from the file is well-formed and changes
- ;; the bytes to paths.
- (define (transform-hdindex filename)
- (verify-file filename
- (λ (l)
- (match l
- [`(,(? string? index)
- ,(? string? file)
- ,(? string? label)
- ,(? string? title))
- #t]
- [else
- #f]))))
-
- ;; transform-keywords : any -> (listof (list string string path string string)
- ;; as with transform-hdindex
- (define (transform-keywords filename)
- (verify-file filename
- (λ (l)
- (match l
- [`(,(? string? keyword)
- ,(? string? result)
- ,(? path-string? file)
- ,(? string? label)
- ,(? string? title))
- #t]
- [else
- #f]))))
-
- (define (verify-file filename ele-ok?)
- (let/ec k
- (let ([fail (lambda (why)
- (fprintf (current-error-port)
- "loading docs from ~a failed: ~a\n"
- (path->string filename)
- why)
- (k '()))])
- (with-handlers ([exn:fail:read? (lambda (x)
- (fail
- (format "read error when opening the file ~a"
- (exn-message x))))]
- [exn:fail:filesystem?
- (lambda (x)
- (fail (format
- "filesystem error when opening the file ~a"
- (exn-message x))))])
- (let ([l (if (file-exists? filename)
- (call-with-input-file filename read)
- '())])
- (unless (list? l) (fail "not a list"))
- (for-each (lambda (l)
- (unless (ele-ok? l)
- (fail (format "line ~s is malformed" l))))
- l)
- l)))))
-
- (define (parse-txt-file doc ht handle-parsing)
- (with-hash-table
- ht
- doc
- (lambda ()
- (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
- (call-with-input-file doc
- handle-parsing)))))
-
- (define re:keyword-line (regexp "\n>"))
- (define text-keywords (make-hash-table 'equal))
-
- (define (load-txt-keywords doc)
- (load-txt-keywords-into-hash-table text-keywords doc))
-
- (define (load-txt-keywords-into-hash-table ht doc)
- (parse-txt-file
- (apply build-path doc)
- ht
- (λ (p)
- (port-count-lines! p)
- (let loop ()
- (let ([m (regexp-match re:keyword-line p)])
- (cond
- [m
- (let/ec k
- (let* ([peek-port (let-values ([(line col pos) (port-next-location p)])
- (let ([pp (peeking-input-port p)])
- (port-count-lines! pp)
- (let ([rp (relocate-input-port pp line col pos)])
- (port-count-lines! rp)
- rp)))]
- [entry (parameterize ([read-accept-bar-quote #f])
- (with-handlers ([exn:fail:read?
- (lambda (x)
- (fprintf (current-error-port)
- "found > on line ~a in ~s that did not parse properly\n first-line: ~a\n exn-msg: ~a\n"
- (let-values ([(line col pos) (port-next-location p)])
- line)
- (path->string (apply build-path doc))
- (read-line (peeking-input-port p))
- (exn-message x))
- (k null))])
- (read peek-port)))]
- [key (let loop ([l-entry entry])
- (cond
- [(symbol? l-entry) l-entry]
- [(keyword? l-entry) l-entry]
- [(pair? l-entry) (if (and (eq? (car l-entry) 'quote)
- (pair? (cdr l-entry)))
- (loop (cadr l-entry))
- (loop (car l-entry)))]
- [else (fprintf (current-error-port) "load-txt-keyword: bad entry in ~s: ~s\n" doc entry)
- #f]))]
- [content (if (symbol? entry)
- (with-handlers ([exn:fail:read? (lambda (x) #f)])
- (let ([s (read peek-port)])
- (if (eq? s '::)
- (format "~s ~s ~s" entry s (read peek-port))
- #f)))
- #f)]
- [txt-to-display
- (let ([p (open-output-string)])
- (if content
- (display content p)
- (if (and (pair? entry)
- (pair? (cdr entry))
- (eq? (car entry) 'quote))
- (fprintf p "'~s" (cadr entry))
- (display entry p)))
- (get-output-string p))]
- [kwd-entry
- (and key
- ; Make the keyword entry:
- (list (format "~s" key) ; the keyword name
- txt-to-display ; the text to display
- (cadr doc) ; file
- (let-values ([(line col pos) (port-next-location p)])
- (- pos 2)) ; label (a position in this case)
- "doc.txt"))])
- (if kwd-entry
- (cons kwd-entry (loop))
- (loop))))] ; title
- [else null]))))))
-
- (define re:index-line (regexp "_([^_]*)_(.*)"))
- (define text-indices (make-hash-table 'equal))
- (define (load-txt-index doc)
- (parse-txt-file
- (apply build-path doc)
- text-indices
- (λ (p)
- (let loop ([start 0])
- (let* ([r (read-line p 'any)]
- [next (if (eof-object? r)
- start
- (+ start (string-length r) 1))])
- (cond
- [(eof-object? r) null]
- [(regexp-match re:index-line r)
- =>
- (lambda (m)
- (append (let loop ([m m])
- (let ([s (cadr m)])
- (cons
- ; Make an index entry:
- (cons s start)
- (let ([m (regexp-match re:index-line (caddr m))])
- (if m
- (loop m)
- null)))))
- (loop next)))]
- [else (loop next)]))))))
-
- (define re:splitter (regexp "^ *([^ ]+)(.*)"))
- (define (split-words s)
- (let ([m (regexp-match re:splitter s)])
- (if m
- (cons (cadr m)
- (split-words (caddr m)))
- null)))
-
- ;; non-regexp : string -> string
- (define (non-regexp s)
- (list->string
- (apply
- append
- (map
- (lambda (c)
- (cond
- [(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
- (list #\\ c)]
- [(char-alphabetic? c)
- (list #\[ (char-upcase c) (char-downcase c) #\])]
- [else (list c)]))
- (string->list s)))))
-
- (define (doc-collections-changed)
- (reset-relevant-directories-state!)
- (reset-doc-lists)
- (set! doc-collection-dates (map (lambda (x) #f) doc-dirs))
- (set! html-keywords (make-hash-table 'equal))
- (set! html-indices (make-hash-table 'equal))
- (set! text-keywords (make-hash-table 'equal))
- (set! text-indices (make-hash-table 'equal)))
-
- (define max-reached #f)
-
- (define (build-string-finds/finds given-find regexp? exact?)
- (cond
- [exact? (values (list given-find)
- (list given-find))]
- [regexp? (values (list given-find)
- (list (regexp given-find)))]
- [else (let ([wl (split-words given-find)])
- (values wl
- (map regexp (map non-regexp wl))))]))
-
- ; do-search : (string ; the search text, unprocessed
- ; num ; 0 = keyword, 1 = keyword+index, 2 = all text
- ; boolean ; #t if string should be used as a regexp
- ; boolean ; #t if the string should match exactly (not just "contains")
- ; (listof path) ; the manuals to search
- ; boolean ; #t if the doc.txt files should be searched
- ; value ; arbitrary key supplied to the "add" functions
- ; (-> A) ; called when more than enough are found; must escape
- ; (string value -> void) ; called to output a document section header (e.g., a manual name)
- ; (symbol value -> void) ; called to output a document-kind section header, 'text or 'html
- ; (string string string path (union string #f) value -> void)
- ; ^ ^ ^ ^ ^- label within page
- ; ^ ^ ^ ^- path to doc page
- ; ^ ^ ^- source doc title
- ; ^ ^- display label
- ; ^- found entry's key
- ; ->
- ; (union string #f))
- (define (do-search given-find search-level regexp? exact? manuals doc-txt?
- ckey maxxed-out
- add-doc-section add-kind-section add-choice)
- ; When new docs are installed, the directory's modification date changes:
- (set! max-reached #f)
-
- (when (ormap (lambda (date new-date)
- (cond
- [(not date) #t]
- [(equal? date new-date) #f]
- [(eq? date 'none) #t]
- [(eq? new-date 'none) #t]
- [else (new-date . > . date)]))
- doc-collection-dates
- (map dir-date/none doc-dirs))
- (reset-doc-lists))
-
- (let ([hit-count 0])
- (let-values ([(string-finds finds) (build-string-finds/finds given-find regexp? exact?)]
- [(filtered-docs filtered-doc-names filtered-doc-kinds)
- (filter-docs manuals doc-txt?)])
- (for-each
- (lambda (doc doc-name doc-kind)
- (define found-one #f)
- (define (found kind)
- (unless found-one
- (add-doc-section doc-name ckey))
- (unless (equal? found-one kind)
- (set! found-one kind)
- (add-kind-section kind ckey))
- (set! hit-count (add1 hit-count))
- (unless (< hit-count MAX-HIT-COUNT)
- (maxxed-out)))
-
- ; Keyword search
- (let ([keys (case doc-kind
- [(html) (load-html-keywords doc)]
- [(text) (load-txt-keywords doc)]
- [else null])]
- [add-key-choice (lambda (v)
- (when (and (pair? v)
- (pair? (cdr v))
- (pair? (cddr v))
- (pair? (cdddr v))
- (pair? (cddddr v)))
- (found "keyword entries")
- (add-choice
- (car v) ; key
- (cadr v) ; display
- (list-ref v 4) ; title
- (if (eq? 'text doc-kind)
- (apply build-path doc)
- (let ([file (bytes->path
- (string->bytes/utf-8
- (list-ref v 2)))])
- (if (servlet-path? file)
- file
- (build-path doc file))))
- (list-ref v 3) ; label
- ckey)))])
-
- (unless regexp?
- (for-each
- (lambda (v)
- (when (string=? given-find (car v))
- (add-key-choice v)))
- keys))
- (unless (or exact? (null? finds))
- (for-each
- (lambda (v)
- (when (andmap (lambda (find) (regexp-match find (car v))) finds)
- (unless (and (not regexp?) (string=? given-find (car v)))
- (add-key-choice v))))
- keys)))
-
- ; Index search
- (unless (< search-level 1)
- (let ([index (case doc-kind
- [(html) (load-html-index doc)]
- [(text) (load-txt-index doc)]
- [else null])]
- [add-index-choice (lambda (name desc)
- (case doc-kind
- [(html)
- (when (and (pair? desc)
- (pair? (cdr desc))
- (pair? (cddr desc)))
- (found "index entries")
- (add-choice
- "" name
- (list-ref desc 2)
- (let ([filename (bytes->path (string->bytes/utf-8 (list-ref desc 0)))])
- (if (servlet-path? filename)
- filename
- (build-path doc filename)))
- (list-ref desc 1)
- ckey))]
- [(text)
- (found "index entries")
- (add-choice
- "" name
- "indexed content"
- (apply build-path doc)
- desc
- ckey)]))])
- (when index
- (unless regexp?
- (for-each
- (lambda (v)
- (when (string=? given-find (car v))
- (add-index-choice (car v) (cdr v))))
- index))
- (unless (or exact? (null? finds))
- (for-each
- (lambda (v)
- (when (andmap (lambda (find) (regexp-match find (car v))) finds)
- (unless (and (not regexp?) (string=? given-find (car v)))
- (add-index-choice (car v) (cdr v)))))
- index)))))
-
- ; Content Search
- (unless (or (< search-level 2) exact? (null? finds))
- (let ([files (case doc-kind
- [(html) (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
- (map (lambda (x) (build-path doc x))
- (filter
- (lambda (x)
- (let ([str (path->string x)])
- (cond
- [(or (regexp-match "--h\\.idx$" str)
- (regexp-match "--h\\.ind$" str)
- (regexp-match "Z-A\\.scm$" str)
- (regexp-match "Z-L\\.scm$" str)
- (regexp-match "gif$" str)
- (regexp-match "png$" str)
- (regexp-match "hdindex$" str)
- (regexp-match "keywords$" str))
- #f]
- [else
- (file-exists? (build-path doc x))])))
- (directory-list doc))))]
- [(text) (list (apply build-path doc))]
- [else null])])
- (for-each
- (lambda (f)
- (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
- (with-input-from-file f
- (lambda ()
- (let loop ()
- (let ([pos (file-position (current-input-port))]
- [r (read-line)])
- (unless (eof-object? r)
- (let ([m (andmap (lambda (find) (regexp-match find r)) finds)])
- (when m
- (found "text")
- (add-choice (car m)
- ; Strip leading space and clean HTML
- (regexp-replace
- "^ [ ]*"
- (if (eq? doc-kind 'html)
- (clean-html r)
- r)
- "")
- "content"
- f
- (if (eq? doc-kind 'text) pos "NO TAG")
- ckey)))
- (loop))))))))
- files))))
- filtered-docs filtered-doc-names filtered-doc-kinds)
-
- (if (= 0 hit-count)
- (format (string-constant plt:hd:nothing-found-for)
- (if (null? string-finds)
- ""
- (apply
- string-append
- (cons (format "\"~a\"" (car string-finds))
- (map (lambda (i) (format " ~a \"~a\"" (string-constant plt:hd:and) i))
- (cdr string-finds))))))
- #f))))
-
- ;; filter-docs : (listof path) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist])
- ;; given the list of manuals specified by `manuals', returns the sublists of the global
- ;; variables docs, doc-names, and doc-kinds that make sense for this search.
- (define (filter-docs manuals doc-txt?)
- (let loop ([manuals manuals])
- (cond
- [(null? manuals) (if doc-txt?
- (extract-doc-txt)
- (values null null null))]
- [else (let ([man (car manuals)])
- (let-values ([(r-doc r-doc-names r-doc-kinds) (loop (cdr manuals))]
- [(t-doc t-doc-names t-doc-kinds) (find-doc man)])
- (if t-doc
- (values (cons t-doc r-doc)
- (cons t-doc-names r-doc-names)
- (cons t-doc-kinds r-doc-kinds))
- (values r-doc
- r-doc-names
- r-doc-kinds))))])))
-
- ;; find-doc :
- ;; path -> (values doc[element of docs] doc-name[element of doc-names] doc-kind[element of doc-kinds])
- (define (find-doc man)
- (let loop ([x-docs docs]
- [x-doc-names doc-names]
- [x-doc-kinds doc-kinds])
- (cond
- [(and (null? x-docs) (null? x-doc-names) (null? x-doc-kinds))
- (values #f #f #f)]
- [(or (null? x-docs) (null? x-doc-names) (null? x-doc-kinds))
- (error 'find-doc "mismatched lists\n")]
- [else
- (let ([doc (car x-docs)])
- (cond
- [(eq? 'html (car x-doc-kinds))
- (let-values ([(base name dir?) (split-path doc)])
- (cond
- [(equal? man name)
- (values doc (car x-doc-names) (car x-doc-kinds))]
- [else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))]
- [else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))])))
-
- ;; extract-doc-txt : (listof string) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist])
- ;; returns the manuals that are not 'html.
- (define (extract-doc-txt)
- (let loop ([x-docs docs]
- [x-doc-names doc-names]
- [x-doc-kinds doc-kinds])
- (cond
- [(null? x-docs) (values null null null)]
- [(or (null? x-doc-names) (null? x-doc-kinds))
- (error 'extract-doc-txt "mismatched lists\n")]
- [else
- (if (eq? (car x-doc-kinds) 'html)
- (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))
- (let-values ([(r-docs r-doc-names r-doc-kinds) (loop (cdr x-docs)
- (cdr x-doc-names)
- (cdr x-doc-kinds))])
- (values (cons (car x-docs) r-docs)
- (cons (car x-doc-names) r-doc-names)
- (cons (car x-doc-kinds) r-doc-kinds))))]))))
-
-
diff --git a/collects/help/private/sig.ss b/collects/help/private/sig.ss
deleted file mode 100644
index 4ab77349d5..0000000000
--- a/collects/help/private/sig.ss
+++ /dev/null
@@ -1,18 +0,0 @@
-(module sig mzscheme
- (require (lib "unit.ss"))
- (provide gui^
- main^)
-
- (define-signature main^
- (add-help-desk-font-prefs))
-
- (define-signature gui^
- (help-desk-frame<%>
- add-help-desk-mixin
- new-help-desk
- find-help-desk-frame
- show-help-desk
- goto-hd-location
- goto-manual-link
- search-for-docs
- search-for-docs/in-frame)))
diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss
deleted file mode 100644
index 33a4654597..0000000000
--- a/collects/help/private/standard-urls.ss
+++ /dev/null
@@ -1,134 +0,0 @@
-(module standard-urls mzscheme
- (require (lib "uri-codec.ss" "net")
- (lib "dirs.ss" "setup")
- (lib "contract.ss")
- (lib "config.ss" "planet")
- (lib "help-desk-urls.ss" "help")
- "../servlets/private/util.ss"
- "internal-hp.ss"
- "get-help-url.ss")
-
- (provide home-page-url host+dirs)
-
- (define (search-type? x)
- (member x '("keyword" "keyword-index" "keyword-index-text")))
-
- (define (search-how? x)
- (member x '("exact-match" "containing-match" "regexp-match")))
-
- (define (base-docs-url)
- (if (repos-or-nightly-build?)
- "http://pre.plt-scheme.org/docs"
- (string-append "http://download.plt-scheme.org/doc/" (version))))
-
- (define (make-docs-plt-url manual-name)
- (format "~a/bundles/~a-doc.plt" (base-docs-url) manual-name))
-
- (define (make-docs-html-url manual-name)
- (format "~a/html/~a/index.htm" (base-docs-url) manual-name))
-
- (define (prefix-with-server suffix)
- (format "http://~a:~a~a" internal-host (internal-port) suffix))
-
- (define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host (internal-port)))
- (define flush-manuals-path "/servlets/results.ss?flush=yes")
- (define flush-manuals-url (format "http://~a:~a~a" internal-host (internal-port) flush-manuals-path))
-
-
- (define relative-results-url-prefix "/servlets/results.ss?")
-
- (define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host (internal-port)))
-
- (define (make-missing-manual-url coll name link)
- (format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a"
- internal-host
- (internal-port)
- coll
- (uri-encode name)
- (uri-encode link)))
-
- (define (make-relative-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
- (string-append
- relative-results-url-prefix
- (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
-
- (define (make-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
- (string-append
- results-url-prefix
- (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
-
- (define (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? language-name)
- (let ([start
- (format
- (string-append "search-string=~a&"
- "search-type=~a&"
- "match-type=~a&"
- "lucky=~a&"
- "manuals=~a&"
- "doctxt=~a")
- (uri-encode search-string)
- search-type
- match-type
- (if lucky? "true" "false")
- (uri-encode (format "~s" (map path->bytes manuals)))
- (if doc.txt? "true" "false"))])
- (if language-name
- (string-append start (format "&langname=~a" (uri-encode language-name)))
- start)))
-
- ; sym, string assoc list
- (define hd-locations
- `((hd-tour ,(format "~a/index.html" (get-help-url (build-path (find-doc-dir) "tour"))))
- (release-notes ,url-helpdesk-release-notes)
- (plt-license ,url-helpdesk-license)
- (front-page ,url-helpdesk-home)))
-
- (define hd-location-syms (map car hd-locations))
-
- (define (get-hd-location sym)
- ; the assq is guarded by the contract
- (cadr (assq sym hd-locations)))
-
- ; host+dirs : (list (cons host-string dir-path))
- ; association between internal (in normal Helpdesk also virtual)
- ; hosts and their corresponding file root.
- (define host+dirs
- (map cons
- (append collects-hosts doc-hosts)
- (append collects-dirs doc-dirs)))
-
- (define (host+file->path host file-path)
- (cond [(assoc host host+dirs)
- => (lambda (internal-host+path)
- (let ([path (cdr internal-host+path)])
- (build-path path file-path)))]
- [(equal? host "planet")
- (build-path (PLANET-DIR) file-path)]
- [else #f]))
-
- (provide host+file->path)
- (provide search-type? search-how?)
- (provide/contract
- (make-relative-results-url (string?
- search-type?
- search-how?
- any/c
- (listof path?)
- any/c
- (or/c false/c string?) . -> . string?))
- (make-results-url (string?
- search-type? search-how? any/c
- (listof path?)
- any/c
- (or/c false/c string?)
- . -> .
- string?))
- (flush-manuals-url string?)
- (flush-manuals-path string?)
- (make-missing-manual-url (string? string? string? . -> . string?))
- (get-hd-location ((lambda (sym) (memq sym hd-location-syms))
- . -> .
- string?))
- [prefix-with-server (string? . -> . string?)]
- [make-docs-plt-url (string? . -> . string?)]
- [make-docs-html-url (string? . -> . string?)]))
diff --git a/collects/help/private/tcp-intercept.ss b/collects/help/private/tcp-intercept.ss
deleted file mode 100644
index 2630ec8e21..0000000000
--- a/collects/help/private/tcp-intercept.ss
+++ /dev/null
@@ -1,117 +0,0 @@
-(module tcp-intercept mzscheme
- (provide tcp-intercept@ url-intercept@)
-
- (require (lib "unit.ss")
- (lib "etc.ss")
- (lib "web-server-sig.ss" "web-server")
- (lib "tcp-sig.ss" "net")
- (lib "url-sig.ss" "net")
- "internal-hp.ss")
-
- (define-syntax (redefine stx)
- (syntax-case stx ()
- [(_ names ...)
- (with-syntax ([(defs ...) (map (lambda (x)
- (with-syntax ([orig-name x]
- [raw-name
- (datum->syntax-object
- x
- (string->symbol
- (string-append
- "raw:"
- (symbol->string (syntax-object->datum x)))))])
- (syntax (define orig-name raw-name))))
- (syntax->list (syntax (names ...))))])
- (syntax (begin defs ...)))]))
-
- (define-unit url-intercept@ (import (prefix raw: url^)) (export url^)
- (init-depend url^)
- (redefine url->string
- get-pure-port
- get-impure-port
- post-pure-port
- post-impure-port
- head-pure-port
- head-impure-port
- put-pure-port
- put-impure-port
- delete-pure-port
- delete-impure-port
- display-pure-port
- purify-port
- netscape/string->url
- string->url
- call/input-url
- combine-url/relative
- url-exception?
- current-proxy-servers))
-
- (define raw:tcp-abandon-port tcp-abandon-port)
- (define raw:tcp-accept tcp-accept)
- (define raw:tcp-accept/enable-break tcp-accept/enable-break)
- (define raw:tcp-accept-ready? tcp-accept-ready?)
- (define raw:tcp-addresses tcp-addresses)
- (define raw:tcp-close tcp-close)
- (define raw:tcp-connect tcp-connect)
- (define raw:tcp-connect/enable-break tcp-connect/enable-break)
- (define raw:tcp-listen tcp-listen)
- (define raw:tcp-listener? tcp-listener?)
-
- ; For tcp-listeners, we use an else branch in the conds since
- ; (instead of a contract) I want the same error message as the raw
- ; primitive for bad inputs.
-
- ; : (listof nat) -> (unit/sig () -> net:tcp^)
- (define-unit tcp-intercept@ (import web-server^) (export tcp^)
-
- ; : port -> void
- (define (tcp-abandon-port tcp-port)
- (cond
- [(tcp-port? tcp-port)
- (raw:tcp-abandon-port tcp-port)]
- [(input-port? tcp-port)
- (close-input-port tcp-port)]
- [(output-port? tcp-port)
- (close-output-port tcp-port)]
- [else (void)]))
-
- ; : listener -> iport oport
- (define tcp-accept raw:tcp-accept)
- ; : listener -> iport oport
- (define tcp-accept/enable-break raw:tcp-accept/enable-break)
-
- ; : tcp-listener -> iport oport
- (define tcp-accept-ready? raw:tcp-accept-ready?)
-
- ; : tcp-port -> str str
- (define (tcp-addresses tcp-port)
- (if (tcp-port? tcp-port)
- (raw:tcp-addresses tcp-port)
- (values "127.0.0.1" internal-host)))
-
- ; : port -> void
- (define tcp-close raw:tcp-close)
-
- ; : (str nat -> iport oport) -> str nat -> iport oport
- (define (gen-tcp-connect raw)
- (lambda (hostname-string port)
- (if (and (is-internal-host? hostname-string)
- (equal? (internal-port) port))
- (let-values ([(req-in req-out) (make-pipe)]
- [(resp-in resp-out) (make-pipe)])
- (parameterize ([current-custodian (make-custodian)])
- (serve-ports req-in resp-out))
- (values resp-in req-out))
- (raw hostname-string port))))
-
- ; : str nat -> iport oport
- (define tcp-connect (gen-tcp-connect raw:tcp-connect))
-
- ; : str nat -> iport oport
- (define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
-
- ; FIX - support the reuse? flag.
- (define tcp-listen raw:tcp-listen)
-
- ; : tst -> bool
- (define tcp-listener? raw:tcp-listener?)))
diff --git a/collects/help/refresh-manuals.ss b/collects/help/refresh-manuals.ss
deleted file mode 100644
index e4c31fb3a6..0000000000
--- a/collects/help/refresh-manuals.ss
+++ /dev/null
@@ -1,232 +0,0 @@
-(module refresh-manuals mzscheme
- (require "private/docpos.ss"
- "private/search.ss"
- "private/manuals.ss"
- "private/standard-urls.ss"
- "private/link.ss"
- (lib "plt-installer.ss" "setup")
- (lib "url.ss" "net")
- (lib "mred.ss" "mred")
- (lib "string-constant.ss" "string-constants")
- (lib "contract.ss")
- (lib "port.ss")
- (lib "thread.ss"))
-
- (provide refresh-manuals
- bytes-to-path)
-
-
- (define sc-refreshing-manuals (string-constant plt:hd:refreshing-manuals))
- (define sc-refresh-downloading... (string-constant plt:hd:refresh-downloading...))
- (define sc-refresh-deleting... (string-constant plt:hd:refresh-deleting...))
- (define sc-refresh-installing... (string-constant plt:hd:refresh-installing...))
- (define sc-finished-installation (string-constant plt:hd:refreshing-manuals-finished))
- (define sc-clearing-cached-indicies (string-constant plt:hd:refresh-clearing-indicies))
-
- (define refresh-manuals
- (case-lambda
- [() (refresh-manuals known-docs)]
- [(docs-to-install)
- (unless (and (list? docs-to-install)
- (andmap (lambda (x) (and (pair? x)
- (path? (car x))
- (string? (cdr x))))
- docs-to-install))
- (error 'refresh-manuals "expected (listof (cons path string)) as argument, got ~e" docs-to-install))
- (let ([tmp-directory (find/create-temporary-docs-dir)]
- [success? #f]
- [thd #f])
- (with-installer-window
- (lambda (parent)
- (set! thd (current-thread))
- (unless tmp-directory
- (error 'plt-installer "please clean out ~a" (find-system-path 'temp-dir)))
- (let ([docs-error (download-docs docs-to-install tmp-directory)])
- (cond
- [docs-error
- (printf "~a\n" docs-error)]
- [else
- (delete-docs docs-to-install)
- (install-docs docs-to-install tmp-directory parent)
- (delete-local-plt-files tmp-directory)
- (display sc-clearing-cached-indicies)
- (newline)
-
- ;; tell the web-server to visit the url for flushing the cache
- ;; this is necc. because the server creates a new namespace for
- ;; each servlet, so we have to get the webserver to visit the servlet
- ;; in order to flush the cache. We don't, however, want to actually
- ;; visit the page, so we just do this for its effect.
- (let-values ([(in1 out1) (make-pipe)]
- [(in2 out2) (make-pipe)])
- (thread (lambda ()
- (fprintf out1 "GET ~a HTTP/1.0\r\n" flush-manuals-path)
- (close-output-port out1)))
- (serve-ports in1 out2) ;; spawns its own thread
- (let loop ()
- (let ([b (with-handlers ([exn? (lambda (x) eof)])
- (read-byte in2))])
- (unless (eof-object? b)
- (loop))))
- (close-input-port in2))])
-
- (display sc-finished-installation)
- (newline)
- (set! success? #t)))
- (lambda ()
- (unless success?
- (delete-local-plt-files tmp-directory))
- (kill-thread thd))))]))
-
- ; needed in "../private/manuals.ss" due to links with > getting mangled
- (define bytes-to-path bytes->path)
-
- (define (make-local-doc-filename tmp-dir stub)
- (build-path tmp-dir (format "~a-doc.plt" stub)))
-
- ;; if cannot find a suitable directory, #f is returned
- ;; if okay, returns the path to the directory.
- (define find/create-temporary-docs-dir
- ;(-> (union string? false?))
- (lambda ()
- (let ([temp-dir (find-system-path 'temp-dir)])
- (let loop ([n 0])
- (if (= n 30)
- #f
- (let ([candidate (build-path temp-dir (format "help-refresh-docs~a" n))])
- (if (directory-exists? candidate)
- (loop (+ n 1))
- (begin
- (make-directory candidate)
- candidate))))))))
-
-
-
-
-
-
- ;; ;;; ;;
- ; ; ;
- ; ; ;
- ;;;; ;;; ;;; ;;;; ;;; ; ;;; ;;;; ;;;;
- ; ; ; ; ; ; ;; ; ; ; ; ; ; ;
- ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ;
- ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
- ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
- ;;; ; ;;; ; ; ;;; ;; ;;;;;; ;;; ;;; ; ;;; ;
-
-
-
-
- ;; download-docs : ... -> (union #f string)
- ;; downloads the docs to the tmp-dir
- (define download-docs
- (lambda (docs-to-install tmp-dir)
- (let loop ([known-docs docs-to-install])
- (cond
- [(null? known-docs) #f]
- [else (let* ([known-doc (car known-docs)]
- [resp (download-doc tmp-dir (car known-doc) (cdr known-doc))])
- (if (string? resp)
- resp
- (loop (cdr known-docs))))]))))
-
- ;; download-doc : ... -> (union #f string)
- ;; stub is the `drscheme' portion of `drscheme-doc.plt'.
- (define download-doc
- (lambda (tmp-dir stub full-name)
- (let ([url (make-docs-plt-url (path->string stub))]
- [doc-name (make-local-doc-filename tmp-dir stub)])
- (display (format sc-refresh-downloading... full-name))
- (newline)
- (call-with-output-file doc-name
- (lambda (out-port)
- (call/input-url (string->url url)
- get-impure-port
- (lambda (in-port)
- (let/ec k
- (let* ([resp (purify-port in-port)]
- [m (regexp-match #rx"HTTP/[^ ]* ([0-9]+)([^\r\n]*)" resp)])
- (unless m
- (k "malformed response from server ~s" resp))
- (let ([code (string->number (cadr m))])
- (unless (equal? code 200)
- (k (format "error response from server \"~a~a\"" code (caddr m)))))
- (copy-port in-port out-port)
- #f)))))))))
-
-
-
- ;; ;;;
- ; ; ;
- ; ; ;
- ;;;; ;;; ; ;;; ;;;;; ;;;
- ; ; ; ; ; ; ; ; ; ;
- ; ; ;;;;; ; ;;;;; ; ;;;;;
- ; ; ; ; ; ; ;
- ; ; ; ; ; ; ; ; ; ; ;
- ;;; ; ;;; ;;;;;; ;;; ;;; ;;;
-
-
-
- (define delete-docs
- (lambda (docs)
- (for-each (lambda (known-doc) (delete-known-doc (car known-doc) (cdr known-doc)))
- docs)))
-
- (define delete-known-doc
- (lambda (doc full-name)
- (let ([doc-dir (find-doc-directory doc)])
- (when doc-dir
- (display (format sc-refresh-deleting... full-name))
- (newline)
- (with-handlers ([exn:fail:filesystem?
- (lambda (exn)
- (fprintf (current-error-port)
- "Warning: delete failed: ~a\n"
- (exn-message exn)))])
- (delete-directory/r doc-dir))))))
-
- (define delete-local-plt-files
- (lambda (tmp-dir)
- (delete-directory/r tmp-dir)))
-
- ;; deletes the entire subtree underneath this directory
- ;; (including the dir itself)
- (define delete-directory/r
- (lambda (dir)
- (when (directory-exists? dir)
- (let loop ([dir dir])
- (let ([children (directory-list dir)])
- (for-each (lambda (f) (when (file-exists? (build-path dir f))
- (delete-file (build-path dir f))))
- children)
- (for-each (lambda (d) (when (directory-exists? (build-path dir d))
- (loop (build-path dir d))))
- children)
- (delete-directory dir))))))
-
-
-
- ; ;;; ;;;
- ; ; ;
- ; ; ;
- ;;; ; ;;; ;;; ;;;;; ;;;; ; ;
- ; ;; ; ; ; ; ; ; ;
- ; ; ; ;;; ; ;;;; ; ;
- ; ; ; ; ; ; ; ; ;
- ; ; ; ; ; ; ; ; ; ; ;
- ;;;;; ;;; ;; ;;; ;;; ;;; ; ;;;;;; ;;;;;;
-
-
-
- (define install-docs
- (lambda (docs-to-install tmp-dir parent)
- (for-each (lambda (pr)
- (display (format sc-refresh-installing... (cdr pr)))
- (newline)
- (run-single-installer (make-local-doc-filename tmp-dir (car pr))
- (lambda ()
- (error 'install-docs
- "expected PLT-relative archive"))))
- docs-to-install))))