commit d54711c88bfedaa9740dadf3b1c3db958473d0de
parent eced37475628c314ce62671c59452ccd31ba2e02
Author: Paul Steckler <steck@stecksoft.com>
Date: Tue, 25 Jun 2002 20:32:52 +0000
v201 changes
original commit: 4928ab22adbeffbca64d394176af6da4e3002212
Diffstat:
1 file changed, 281 insertions(+), 270 deletions(-)
diff --git 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^)
-
- (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 : ??
- (define doc-collection-date #f)
-
- (define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
-
- ; 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 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 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)))))
+ ; 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-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 re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
- (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)])))))))))
+ ; 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: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 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 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 (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:splitter (regexp "^ *([^ ]+)(.*)"))
- (define (split-words s)
- (let ([m (regexp-match re:splitter s)])
- (if m
- (cons (cadr m)
- (split-words (caddr m)))
- null)))
+ (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 (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 (doc-collections-changed)
+ (set! doc-collection-date #f)
+ (reset-doc-positions!))
- (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)])))
+ (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))))
+
