From d54711c88bfedaa9740dadf3b1c3db958473d0de Mon Sep 17 00:00:00 2001 From: Paul Steckler Date: Tue, 25 Jun 2002 20:32:52 +0000 Subject: [PATCH] v201 changes original commit: 4928ab22adbeffbca64d394176af6da4e3002212 --- collects/help/private/search.ss | 551 ++++++++++++++++---------------- 1 file changed, 281 insertions(+), 270 deletions(-) diff --git a/collects/help/private/search.ss b/collects/help/private/search.ss index 8b448f17..8ff488ac 100644 --- a/collects/help/private/search.ss +++ b/collects/help/private/search.ss @@ -1,282 +1,294 @@ - (module search mzscheme (require (lib "string-constant.ss" "string-constants") - (lib "unitsig.ss") - "sig.ss" - "../help-sig.ss" "docpos.ss" "colldocs.ss" - (lib "list.ss")) + (lib "list.ss") + (lib "util.ss" "doc" "help" "servlets" "private") + "../server.ss" + "../browser.ss") - (provide search@) + (provide do-search + doc-collections-changed + search-for-docs) - (define search@ - (unit/sig search^ - (import help:doc-position^) + ; hd-cookie string sym sym 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))) + + ; 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 string 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-date #f) - (define (html-doc-position x) - (or (user-defined-doc-position x) - (standard-html-doc-position x))) + (define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)")) - ; 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 string 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 : ?? - (define doc-collection-date #f) + ; get-std-doc-title : string -> string + ; gets the standard title of the documentation, from the + ; known docs list. + (define (get-std-doc-title path doc) + (let ([a (assoc doc known-docs)]) + (if a + (cdr a) + (let ([index-file (build-path path doc "index.htm")]) + (if (file-exists? index-file) + (call-with-input-file index-file + (lambda (port) + (let loop () + (let ([l (read-line port)]) + (cond + [(eof-object? l) + doc] + [(regexp-match re:title l) + => + (lambda (m) + (apply + string + (map (lambda (x) (if (char-whitespace? x) #\space x)) + (string->list (cadr m)))))] + [else (loop)]))))) + doc))))) + + (define (reset-doc-lists) + ; Locate standard HTML documentation + (define-values (std-docs std-doc-names) + (let* ([path (with-handlers ([not-break-exn? (lambda (x) #f)]) + (collection-path "doc"))]) + (if path + (let* ([doc-collections (directory-list path)] + [docs (map (lambda (x) (build-path path x)) doc-collections)] + [doc-names (map (lambda (x) (get-std-doc-title path x)) doc-collections)]) + ; Order the standard docs: + (let ([ordered (quicksort + (map list docs doc-collections doc-names) + (lambda (a b) ; html-doc-position expects collection name + (< (html-doc-position (cadr a)) + (html-doc-position (cadr b)))))]) + (values (map car ordered) (map caddr ordered)))) ; here we want the std title + (values null null)))) + + ; 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 collection" s)) + txt-doc-names))) + (set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs))) + + (with-handlers ([not-break-exn? + (lambda (x) (set! doc-collection-date 'none))]) + (set! doc-collection-date + (file-or-directory-modify-seconds + (collection-path "doc"))))) + + (define MAX-HIT-COUNT 300) + + (define (clean-html s) + (regexp-replace* + "&[^;]*;" + (regexp-replace* + "<[^>]*>" + (regexp-replace* + "&" + (regexp-replace* + ">" + (regexp-replace* + "<" + s + "<") + ">") + "\\&") + "") + "")) + + ; One lock for all hash table operations is good enough + (define ht-lock (make-semaphore 1)) + + (define (with-hash-table ht key compute) + (dynamic-wind + (lambda () (semaphore-wait ht-lock)) + (lambda () + (let ([sym (string->symbol key)]) + (hash-table-get + ht + sym + (lambda () + (let ([v (compute)]) + (hash-table-put! ht sym v) + v))))) + (lambda () (semaphore-post ht-lock)))) + + (define html-keywords (make-hash-table)) + (define (load-html-keywords doc) + (with-hash-table + html-keywords + doc + (lambda () + (with-handlers ([not-break-exn? (lambda (x) null)]) + (with-input-from-file (build-path doc "keywords") + read))))) - (define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)")) + (define html-indices (make-hash-table)) + (define (load-html-index doc) + (with-hash-table + html-indices + doc + (lambda () + (with-handlers ([not-break-exn? (lambda (x) null)]) + (with-input-from-file (build-path doc "hdindex") + read))))) - ; get-std-doc-title : string -> string - ; gets the standard title of the documentation, from the - ; known docs list. - (define (get-std-doc-title path doc) - (let ([a (assoc doc known-docs)]) - (if a - (cdr a) - (let ([index-file (build-path path doc "index.htm")]) - (if (file-exists? index-file) - (call-with-input-file index-file - (lambda (port) - (let loop () - (let ([l (read-line port)]) - (cond - [(eof-object? l) - doc] - [(regexp-match re:title l) - => - (lambda (m) - (apply - string - (map (lambda (x) (if (char-whitespace? x) #\space x)) - (string->list (cadr m)))))] - [else (loop)]))))) - doc))))) + (define (parse-txt-file doc ht handle-one) + (with-hash-table + ht + doc + (lambda () + (with-handlers + ([not-break-exn? (lambda (x) null)]) + (with-input-from-file doc + (lambda () + (let loop ([start 0]) + (let* ([r (read-line (current-input-port) 'any)] + [next (if (eof-object? r) + start + (+ start (string-length r) 1))]) + (cond + [(eof-object? r) null] + [(handle-one r start) => (lambda (vs) (append vs (loop next)))] + [else (loop next)]))))))))) + + (define re:keyword-line (regexp "^>")) + (define text-keywords (make-hash-table)) + (define (load-txt-keywords doc) + (parse-txt-file + (apply build-path doc) + text-keywords + (lambda (r start) + (cond + [(regexp-match re:keyword-line r) + (let* ([p (open-input-string (substring r 1 (string-length r)))] + [entry (parameterize ([read-accept-bar-quote #f]) + (read p))] + [key (let loop ([entry entry]) + (cond + [(symbol? entry) entry] + [(pair? entry) (if (eq? (car entry) 'quote) + (loop (cadr entry)) + (loop (car entry)))] + [else (error "bad entry")]))] + [content (if (symbol? entry) + (with-handlers ([not-break-exn? (lambda (x) #f)]) + (let ([s (read p)]) + (if (eq? s '::) + (read p) + #f))) + #f)]) + (list + ; Make the keyword entry: + (list (symbol->string key) ; the keyword name + (let ([p (open-output-string)]) + (if content + (display content p) + (if (and (pair? entry) + (eq? (car entry) 'quote)) + (fprintf p "'~s" (cadr entry)) + (display entry p))) + (get-output-string p)) ; the text to display + (cadr doc) ; file + start ; label (a position in this case) + "doc.txt")))] ; title + [else #f])))) + (define re:index-line (regexp "_([^_]*)_(.*)")) + (define text-indices (make-hash-table)) + (define (load-txt-index doc) + (parse-txt-file + (apply build-path doc) + text-indices + (lambda (r start) + (cond + [(regexp-match re:index-line r) + => (lambda (m) + (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))))))] + [else #f])))) + + (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))) - (define (reset-doc-lists) - ; Locate standard HTML documentation - (define-values (std-docs std-doc-names) - (let* ([path (with-handlers ([not-break-exn? (lambda (x) #f)]) - (collection-path "doc"))]) - (if path - (let* ([doc-collections (directory-list path)] - [docs (map (lambda (x) (build-path path x)) doc-collections)] - [doc-names (map (lambda (x) (get-std-doc-title path x)) doc-collections)]) - ; Order the standard docs: - (let ([ordered (quicksort - (map cons docs doc-names) - (lambda (a b) - (< (html-doc-position (cdr a)) - (html-doc-position (cdr b)))))]) - (values (map car ordered) (map cdr ordered)))) - (values null null)))) - - ; 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 collection" s)) - txt-doc-names))) - (set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs))) - - (with-handlers ([not-break-exn? - (lambda (x) (set! doc-collection-date 'none))]) - (set! doc-collection-date - (file-or-directory-modify-seconds - (collection-path "doc"))))) + (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 MAX-HIT-COUNT 300) + (define (doc-collections-changed) + (set! doc-collection-date #f) + (reset-doc-positions!)) - (define (clean-html s) - (regexp-replace* - "&[^;]*;" - (regexp-replace* - "<[^>]*>" - (regexp-replace* - "&" - (regexp-replace* - ">" - (regexp-replace* - "<" - s - "<") - ">") - "\\&") - "") - "")) + (define re:url-dir (regexp "^([^/]*)/(.*)$")) + (define (combine-path/url-path path url-path) + (let loop ([path path] + [url-path url-path]) + (cond + [(regexp-match re:url-dir url-path) + => + (lambda (m) + (let* ([url-dir (cadr m)] + [rest (caddr m)] + [dir + (cond + [(string=? ".." url-dir) 'up] + [(string=? "." url-dir) 'same] + [(string=? "" url-dir) 'same] + [else url-dir])]) + (loop (build-path path dir) + rest)))] + [else (build-path path url-path)]))) - ; One lock for all hash table operations is good enough - (define ht-lock (make-semaphore 1)) - - (define (with-hash-table ht key compute) - (dynamic-wind - (lambda () (semaphore-wait ht-lock)) - (lambda () - (let ([sym (string->symbol key)]) - (hash-table-get - ht - sym - (lambda () - (let ([v (compute)]) - (hash-table-put! ht sym v) - v))))) - (lambda () (semaphore-post ht-lock)))) - - (define html-keywords (make-hash-table)) - (define (load-html-keywords doc) - (with-hash-table - html-keywords - doc - (lambda () - (with-handlers ([not-break-exn? (lambda (x) null)]) - (with-input-from-file (build-path doc "keywords") - read))))) - - (define html-indices (make-hash-table)) - (define (load-html-index doc) - (with-hash-table - html-indices - doc - (lambda () - (with-handlers ([not-break-exn? (lambda (x) null)]) - (with-input-from-file (build-path doc "hdindex") - read))))) - - (define (parse-txt-file doc ht handle-one) - (with-hash-table - ht - doc - (lambda () - (with-handlers ([not-break-exn? (lambda (x) null)]) - (with-input-from-file doc - (lambda () - (let loop ([start 0]) - (let* ([r (read-line (current-input-port) 'any)] - [next (if (eof-object? r) - start - (+ start (string-length r) 1))]) - (cond - [(eof-object? r) null] - [(handle-one r start) => (lambda (vs) (append vs (loop next)))] - [else (loop next)]))))))))) - - (define re:keyword-line (regexp "^>")) - (define text-keywords (make-hash-table)) - (define (load-txt-keywords doc) - (parse-txt-file - (apply build-path doc) - text-keywords - (lambda (r start) - (cond - [(regexp-match re:keyword-line r) - (let* ([p (open-input-string (substring r 1 (string-length r)))] - [entry (parameterize ([read-accept-bar-quote #f]) - (read p))] - [key (let loop ([entry entry]) - (cond - [(symbol? entry) entry] - [(pair? entry) (if (eq? (car entry) 'quote) - (loop (cadr entry)) - (loop (car entry)))] - [else (error "bad entry")]))] - [content (if (symbol? entry) - (with-handlers ([not-break-exn? (lambda (x) #f)]) - (let ([s (read p)]) - (if (eq? s '::) - (read p) - #f))) - #f)]) - (list - ; Make the keyword entry: - (list (symbol->string key) ; the keyword name - (let ([p (open-output-string)]) - (if content - (display content p) - (if (and (pair? entry) - (eq? (car entry) 'quote)) - (fprintf p "'~s" (cadr entry)) - (display entry p))) - (get-output-string p)) ; the text to display - (cadr doc) ; file - start ; label (a position in this case) - "doc.txt")))] ; title - [else #f])))) - - (define re:index-line (regexp "_([^_]*)_(.*)")) - (define text-indices (make-hash-table)) - (define (load-txt-index doc) - (parse-txt-file - (apply build-path doc) - text-indices - (lambda (r start) - (cond - [(regexp-match re:index-line r) - => (lambda (m) - (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))))))] - [else #f])))) - - (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))) - - (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) - (set! doc-collection-date #f)) - - (define re:url-dir (regexp "^([^/]*)/(.*)$")) - (define (combine-path/url-path path url-path) - (let loop ([path path] - [url-path url-path]) - (cond - [(regexp-match re:url-dir url-path) - => - (lambda (m) - (let* ([url-dir (cadr m)] - [rest (caddr m)] - [dir - (cond - [(string=? ".." url-dir) 'up] - [(string=? "." url-dir) 'same] - [(string=? "" url-dir) 'same] - [else url-dir])]) - (loop (build-path path dir) - rest)))] - [else (build-path path url-path)]))) - - ; do-search : (string ; the search text, unprocessed + ; 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") @@ -431,9 +443,8 @@ (format (string-constant nothing-found-for) (apply string-append - (append - (cons (format "\"~a\"" (car string-finds)) - (map (lambda (i) (format " ~a \"~a\"" (string-constant and) i)) - (cdr string-finds))) - (list "."))))]) - #f)))))) + (cons (format "\"~a\"" (car string-finds)) + (map (lambda (i) (format " ~a \"~a\"" (string-constant and) i)) + (cdr string-finds)))))]) + #f)))) +