709 lines
34 KiB
Scheme
709 lines
34 KiB
Scheme
|
|
(module multi-file-search mzscheme
|
|
(require (lib "framework.ss" "framework")
|
|
(lib "class.ss")
|
|
(lib "unitsig.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "file.ss")
|
|
(lib "thread.ss")
|
|
(lib "async-channel.ss")
|
|
(lib "string-constant.ss" "string-constants")
|
|
"drsig.ss")
|
|
|
|
(provide multi-file-search@)
|
|
|
|
(define multi-file-search@
|
|
(unit/sig drscheme:multi-file-search^
|
|
(import [drscheme:frame : drscheme:frame^]
|
|
[drscheme:unit : drscheme:unit^])
|
|
|
|
;; multi-file-search : -> void
|
|
;; opens a dialog to configure the search and initiates the search
|
|
(define (multi-file-search)
|
|
(let ([search-info (configure-search)])
|
|
(when search-info
|
|
(open-search-window search-info))))
|
|
|
|
;; searcher = (string (string int int int -> void) -> void)
|
|
;; this performs a single search.
|
|
;; the first argument is the filename to be searched
|
|
;; the second argument is called for each match.
|
|
;; the arguments are: line-string line-number col-number match-length
|
|
|
|
|
|
;; search-type = (make-search-type string make-searcher (listof (cons string boolean)))
|
|
;; the param strings are the labels for checkboxes
|
|
;; the param booleans are the default values for the checkboxes
|
|
;; these are the available searches
|
|
(define-struct search-type (label make-searcher params))
|
|
|
|
;; search-info = (make-search-info string boolean (union #f regexp) search-type)
|
|
(define-struct search-info (dir recur? filter searcher))
|
|
|
|
;; search-types : (listof search-type)
|
|
(define search-types
|
|
(list (make-search-type
|
|
(string-constant mfs-string-match/graphics)
|
|
(λ (info search-string) (exact-match-searcher info search-string))
|
|
(list (cons (string-constant mfs-case-sensitive-label) #f)))
|
|
(make-search-type
|
|
(string-constant mfs-regexp-match/no-graphics)
|
|
(λ (info search-string) (regexp-match-searcher info search-string))
|
|
(list))))
|
|
|
|
;; search-entry = (make-search-entry string number number number)
|
|
(define-struct search-entry (filename line-string line-number col-number match-length))
|
|
|
|
;; preferences initialization
|
|
(preferences:set-default 'drscheme:multi-file-search:recur? #t boolean?)
|
|
(preferences:set-default 'drscheme:multi-file-search:filter? #t boolean?)
|
|
(preferences:set-default 'drscheme:multi-file-search:filter-string "\\.(ss|scm)$" string?)
|
|
(preferences:set-default 'drscheme:multi-file-search:search-string "" string?)
|
|
(preferences:set-default 'drscheme:multi-file-search:search-type
|
|
1
|
|
(λ (x)
|
|
(and (number? x)
|
|
(exact? x)
|
|
(integer? x)
|
|
(<= 0 x)
|
|
(< x (length search-types)))))
|
|
|
|
;; drscheme:mult-file-search:search-check-boxes : (listof (listof boolean))
|
|
(preferences:set-default 'drscheme:multi-file-search:search-check-boxes
|
|
(map (λ (x) (map cdr (search-type-params x)))
|
|
search-types)
|
|
(λ (x)
|
|
(and (list? x)
|
|
(andmap (λ (x)
|
|
(and (list? x)
|
|
(andmap boolean? x)))
|
|
x))))
|
|
|
|
(preferences:set-default 'drscheme:multi-file-search:percentages
|
|
'(1/3 2/3)
|
|
(λ (x) (and (list? x)
|
|
(= 2 (length x))
|
|
(= 1 (apply + x)))))
|
|
|
|
(preferences:set-default 'drscheme:multi-file-search:frame-size '(300 . 400)
|
|
(λ (x) (and (pair? x)
|
|
(number? (car x))
|
|
(number? (cdr x)))))
|
|
(preferences:set-default 'drscheme:multi-file-search:directory (car (filesystem-root-list)) path?)
|
|
(preferences:set-un/marshall
|
|
'drscheme:multi-file-search:directory
|
|
(λ (v) (path->string v))
|
|
(λ (p) (if (path-string? p)
|
|
(string->path p)
|
|
(car (filesystem-root-list)))))
|
|
|
|
|
|
;; open-search-window : search-info -> void
|
|
;; thread: eventspace main thread
|
|
;; opens a window and creates the thread that does the search
|
|
(define (open-search-window search-info)
|
|
(define frame (make-object search-size-frame% (string-constant mfs-drscheme-multi-file-search)))
|
|
(define panel (make-object saved-vertical-resizable% (send frame get-area-container)))
|
|
(define button-panel (make-object horizontal-panel% (send frame get-area-container)))
|
|
(define open-button (make-object button% (string-constant mfs-open-file) button-panel
|
|
(λ (x y) (open-file-callback))))
|
|
(define stop-button (make-object button% (string-constant mfs-stop-search) button-panel
|
|
(λ (x y) (stop-callback))))
|
|
(define grow-box-pane (make-object grow-box-spacer-pane% button-panel))
|
|
|
|
(define zoom-text (make-object scheme:text%))
|
|
(define results-text (make-object results-text% zoom-text))
|
|
(define results-ec (instantiate searching-canvas% ()
|
|
(parent panel)
|
|
(editor results-text)
|
|
(frame frame)))
|
|
(define zoom-ec (instantiate searching-canvas% ()
|
|
(parent panel)
|
|
(editor zoom-text)
|
|
(frame frame)))
|
|
|
|
(define (open-file-callback)
|
|
(send results-text open-file))
|
|
|
|
;; sometimes, breaking the other thread puts
|
|
;; the break message in the channel behind
|
|
;; many many requests. Rather than show those,
|
|
;; we use the `broken?' flag as a shortcut.
|
|
(define broken? #f)
|
|
(define (stop-callback)
|
|
(break-thread search-thd)
|
|
(set! broken? #t)
|
|
(send stop-button enable #f))
|
|
|
|
;; channel : async-channel[(union 'done search-entry)]
|
|
(define channel (make-async-channel 100))
|
|
(define search-thd (thread (λ () (do-search search-info channel))))
|
|
|
|
(send frame set-text-to-search results-text) ;; just to initialize it to something.
|
|
(send results-text lock #t)
|
|
(send frame reflow-container)
|
|
(send panel set-percentages (preferences:get 'drscheme:multi-file-search:percentages))
|
|
(send button-panel set-alignment 'right 'center)
|
|
(send button-panel stretchable-height #f)
|
|
(send frame show #t)
|
|
|
|
(let loop ()
|
|
(let ([match (yield channel)])
|
|
(yield)
|
|
(cond
|
|
[(eq? match 'done)
|
|
(send results-text search-complete)
|
|
(send stop-button enable #f)]
|
|
[(or broken? (eq? match 'break))
|
|
(send results-text search-interrupted)]
|
|
[else
|
|
(send results-text add-match
|
|
(search-info-dir search-info)
|
|
(search-entry-filename match)
|
|
(search-entry-line-string match)
|
|
(search-entry-line-number match)
|
|
(search-entry-col-number match)
|
|
(search-entry-match-length match))
|
|
(loop)]))))
|
|
|
|
(define results-super-text%
|
|
(text:hide-caret/selection-mixin
|
|
(text:basic-mixin
|
|
(editor:standard-style-list-mixin
|
|
(editor:basic-mixin
|
|
text%)))))
|
|
|
|
;; results-text% : derived from text%
|
|
;; init args: zoom-text
|
|
;; zoom-text : (instance-of text%)
|
|
;; public-methods:
|
|
;; add-match : string string int int int int -> void
|
|
;; adds a match to the text
|
|
;; search-interrupted : -> void
|
|
;; inserts a message saying "search interrupted".
|
|
;; search-complete is not expected to be called if this method is called.
|
|
;; search-complete : -> void
|
|
;; inserts a message saying "no matches found" if none were reported
|
|
(define results-text%
|
|
(class results-super-text%
|
|
(init-field zoom-text)
|
|
(inherit insert last-paragraph erase
|
|
paragraph-start-position paragraph-end-position
|
|
last-position change-style
|
|
set-clickback set-position
|
|
end-edit-sequence begin-edit-sequence
|
|
lock)
|
|
|
|
[define filename-delta (make-object style-delta% 'change-bold)]
|
|
[define match-delta (let ([d (make-object style-delta%)])
|
|
(send d set-delta-foreground
|
|
(make-object color%
|
|
0
|
|
160
|
|
0))
|
|
d)]
|
|
[define hilite-line-delta (make-object style-delta% 'change-style 'italic)]
|
|
[define unhilite-line-delta (make-object style-delta% 'change-style 'normal)]
|
|
[define widest-filename #f]
|
|
[define/private indent-all-lines
|
|
;; indent-all-lines : number -> void
|
|
;; inserts `offset' spaces to the beginning of each line,
|
|
;; except the last one. Must be at least one such line in the text.
|
|
(λ (offset)
|
|
(let ([spaces (make-string offset #\space)])
|
|
(let loop ([para (- (last-paragraph) 1)])
|
|
(let ([para-start (paragraph-start-position para)])
|
|
(insert spaces para-start para-start)
|
|
(change-style filename-delta para-start (+ para-start offset)))
|
|
(unless (zero? para)
|
|
(loop (- para 1))))))]
|
|
|
|
;; match-shown? : boolean
|
|
;; indicates if a match has ever been shown.
|
|
;; if not, need to clean out the "searching" message
|
|
;; and show a match. Done in `add-match'
|
|
[define match-shown? #f]
|
|
|
|
;; current-file : (union #f string)
|
|
;; the name of the currently viewed file, if one if viewed.
|
|
;; line-in-current-file and col-in-current-file are linked
|
|
[define current-file #f]
|
|
[define line-in-current-file #f]
|
|
[define col-in-current-file #f]
|
|
|
|
[define old-line #f]
|
|
[define/private hilite-line
|
|
(λ (line)
|
|
(begin-edit-sequence)
|
|
(lock #f)
|
|
(when old-line
|
|
(change-style unhilite-line-delta
|
|
(paragraph-start-position old-line)
|
|
(paragraph-end-position old-line)))
|
|
(when line
|
|
(change-style hilite-line-delta
|
|
(paragraph-start-position line)
|
|
(paragraph-end-position line)))
|
|
(set! old-line line)
|
|
(lock #t)
|
|
(end-edit-sequence))]
|
|
|
|
[define/public (open-file)
|
|
(when current-file
|
|
(let ([f (handler:edit-file current-file)])
|
|
(when (and f
|
|
(is-a? f drscheme:unit:frame<%>))
|
|
(let* ([t (send f get-definitions-text)]
|
|
[pos (+ (send t paragraph-start-position line-in-current-file)
|
|
col-in-current-file)])
|
|
(send t set-position pos)))))]
|
|
|
|
[define/public add-match
|
|
(λ (base-filename full-filename line-string line-number col-number match-length)
|
|
(lock #f)
|
|
(let* ([new-line-position (last-position)]
|
|
[short-filename
|
|
(path->string
|
|
(find-relative-path
|
|
(normalize-path base-filename)
|
|
(normalize-path full-filename)))]
|
|
[this-match-number (last-paragraph)]
|
|
[len (string-length short-filename)]
|
|
[insertion-start #f]
|
|
[show-this-match
|
|
(λ ()
|
|
(set! match-shown? #t)
|
|
(set! current-file full-filename)
|
|
(set! line-in-current-file line-number)
|
|
(set! col-in-current-file col-number)
|
|
(set-position new-line-position new-line-position)
|
|
(send zoom-text begin-edit-sequence)
|
|
(send zoom-text lock #f)
|
|
(send zoom-text load-file/gui-error full-filename)
|
|
(send zoom-text set-position (send zoom-text paragraph-start-position line-number))
|
|
(let ([start (+ (send zoom-text paragraph-start-position line-number)
|
|
col-number)])
|
|
(send zoom-text change-style match-delta start (+ start match-length)))
|
|
(send zoom-text lock #t)
|
|
(send zoom-text set-caret-owner #f 'global)
|
|
(hilite-line this-match-number)
|
|
(send zoom-text end-edit-sequence))])
|
|
(unless match-shown?
|
|
(erase))
|
|
(unless widest-filename
|
|
(set! widest-filename len))
|
|
(if (<= len widest-filename)
|
|
(begin
|
|
(set! insertion-start (last-position))
|
|
(insert (make-string (- widest-filename len) #\space)
|
|
(last-position) (last-position)))
|
|
(begin
|
|
(indent-all-lines (- len widest-filename))
|
|
(set! insertion-start (last-position))
|
|
(set! widest-filename len)))
|
|
(let ([filename-start (last-position)])
|
|
(insert short-filename (last-position) (last-position))
|
|
(insert ": " (last-position) (last-position))
|
|
(change-style filename-delta insertion-start (last-position))
|
|
(let ([line-start (last-position)])
|
|
(insert line-string (last-position) (last-position))
|
|
(change-style match-delta
|
|
(+ line-start col-number)
|
|
(+ line-start col-number match-length)))
|
|
(set-clickback filename-start (last-position)
|
|
(λ (_1 _2 _3)
|
|
(show-this-match)))
|
|
(insert #\newline (last-position) (last-position))
|
|
|
|
(unless match-shown?
|
|
(show-this-match))))
|
|
(lock #t))]
|
|
|
|
(define/public (search-interrupted)
|
|
(lock #f)
|
|
(insert #\newline (last-position) (last-position))
|
|
(insert (string-constant mfs-search-interrupted) (last-position) (last-position))
|
|
(lock #t))
|
|
|
|
(define/public (search-complete)
|
|
(unless match-shown?
|
|
(lock #f)
|
|
(insert #\newline (last-position) (last-position))
|
|
(insert (string-constant mfs-no-matches-found) (last-position) (last-position))
|
|
(lock #t)))
|
|
|
|
(inherit get-style-list set-style-list set-styles-sticky)
|
|
(super-instantiate ())
|
|
(send zoom-text lock #t)
|
|
(set-styles-sticky #f)
|
|
(insert (string-constant mfs-searching...))))
|
|
|
|
;; collaborates with search-size-frame%
|
|
(define searching-canvas%
|
|
(class canvas:basic%
|
|
(init-field frame)
|
|
(inherit get-editor)
|
|
(define/override (on-focus on?)
|
|
(when on?
|
|
(send frame set-text-to-search (get-editor)))
|
|
(super on-focus on?))
|
|
(super-instantiate ())))
|
|
|
|
;; thread: eventspace main thread
|
|
(define search-size-frame%
|
|
(class (drscheme:frame:basics-mixin
|
|
(frame:searchable-mixin
|
|
frame:standard-menus%))
|
|
(init-field name)
|
|
|
|
(field [text-to-search #f])
|
|
(define/public (set-text-to-search text) (set! text-to-search text))
|
|
(define/override (get-text-to-search) text-to-search)
|
|
|
|
(define/override (on-size w h)
|
|
(preferences:set 'drscheme:multi-file-search:frame-size (cons w h))
|
|
(super on-size w h))
|
|
(let ([size (preferences:get 'drscheme:multi-file-search:frame-size)])
|
|
(super-instantiate ()
|
|
(label name)
|
|
(width (car size))
|
|
(height (cdr size))))))
|
|
|
|
|
|
;; this vertical-resizable class just remembers the percentage between the
|
|
;; two panels
|
|
;; thread: eventspace main thread
|
|
(define saved-vertical-resizable%
|
|
(class panel:vertical-dragable%
|
|
(inherit get-percentages)
|
|
(define/augment (after-percentage-change)
|
|
(let ([ps (get-percentages)])
|
|
(when (= (length ps) 2)
|
|
(preferences:set 'drscheme:multi-file-search:percentages ps)))
|
|
(inner (void) after-percentage-change))
|
|
(super-instantiate ())))
|
|
|
|
;; configure-search : -> (union #f search-info)
|
|
;; thread: eventspace main thread
|
|
;; configures the search
|
|
(define (configure-search)
|
|
(define dialog (make-object dialog% (string-constant mfs-configure-search)
|
|
#f 500 #f #f #f '(resize-border)))
|
|
(define outer-files-panel (make-object vertical-panel% dialog '(border)))
|
|
(define outer-method-panel (make-object vertical-panel% dialog '(border)))
|
|
(define button-panel (make-object horizontal-panel% dialog))
|
|
(define files-label (make-object message% (string-constant mfs-files-section) outer-files-panel))
|
|
(define files-inset-outer-panel (make-object horizontal-panel% outer-files-panel))
|
|
(define files-inset-panel (make-object horizontal-panel% files-inset-outer-panel))
|
|
(define files-panel (make-object vertical-panel% files-inset-outer-panel))
|
|
(define method-label (make-object message% (string-constant mfs-search-section) outer-method-panel))
|
|
(define method-inset-outer-panel (make-object horizontal-panel% outer-method-panel))
|
|
(define method-inset-panel (make-object horizontal-panel% method-inset-outer-panel))
|
|
(define method-panel (make-object vertical-panel% method-inset-outer-panel))
|
|
|
|
(define dir-panel (make-object horizontal-panel% files-panel))
|
|
(define dir-field (make-object text-field% (string-constant mfs-dir) dir-panel
|
|
(λ (x y) (dir-field-callback))))
|
|
(define dir-button (make-object button% (string-constant browse...) dir-panel
|
|
(λ (x y) (dir-button-callback))))
|
|
|
|
(define recur-check-box (make-object check-box% (string-constant mfs-recur-over-subdirectories) files-panel
|
|
(λ (x y) (recur-check-box-callback))))
|
|
|
|
(define filter-panel (make-object horizontal-panel% files-panel))
|
|
(define filter-check-box (make-object check-box% (string-constant mfs-regexp-filename-filter) filter-panel
|
|
(λ (x y) (filter-check-box-callback))))
|
|
(define filter-text-field (make-object text-field% #f filter-panel
|
|
(λ (x y) (filter-text-field-callback))))
|
|
|
|
(define methods-choice (make-object choice% #f (map search-type-label search-types) method-panel
|
|
(λ (x y) (methods-choice-callback))))
|
|
(define search-text-field (make-object text-field% (string-constant mfs-search-string) method-panel
|
|
(λ (x y) (search-text-field-callback))))
|
|
(define active-method-panel (make-object panel:single% method-panel))
|
|
(define methods-check-boxess
|
|
(let ([pref (preferences:get 'drscheme:multi-file-search:search-check-boxes)])
|
|
(map
|
|
(λ (search-type prefs-settings)
|
|
(let ([p (make-object vertical-panel% active-method-panel)]
|
|
[params (search-type-params search-type)])
|
|
(send p set-alignment 'left 'center)
|
|
(map (λ (flag-pair prefs-setting)
|
|
(let ([cb (make-object check-box%
|
|
(car flag-pair)
|
|
p
|
|
(λ (evt chk) (method-callback chk)))])
|
|
(send cb set-value prefs-setting)
|
|
cb))
|
|
params
|
|
(if (= (length params) (length prefs-settings))
|
|
prefs-settings
|
|
(map (λ (x) #f) params)))))
|
|
search-types
|
|
(if (= (length search-types) (length pref))
|
|
pref
|
|
(map (λ (x) '()) search-types)))))
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons
|
|
button-panel
|
|
(λ (x y) (ok-button-callback))
|
|
(λ (x y) (cancel-button-callback))))
|
|
(define spacer (make-object grow-box-spacer-pane% button-panel))
|
|
|
|
;; initialized to a searcher during the ok button callback
|
|
;; so the user can be informed of an error before the dialog
|
|
;; closes.
|
|
(define searcher #f)
|
|
|
|
;; initialized to a regexp if the user wants to filter filenames,
|
|
;; during the ok-button-callback, so errors can be signalled.
|
|
(define filter #f)
|
|
|
|
;; title for message box that signals error messages
|
|
(define message-box-title (string-constant mfs-drscheme-multi-file-search))
|
|
|
|
(define (ok-button-callback)
|
|
(cond
|
|
[(with-handlers ([exn:fail:filesystem?
|
|
(λ (x) #f)])
|
|
(directory-exists? (send dir-field get-value)))
|
|
(let ([_searcher
|
|
((search-type-make-searcher (list-ref search-types (send methods-choice get-selection)))
|
|
(map (λ (cb) (send cb get-value))
|
|
(send (send active-method-panel active-child) get-children))
|
|
(send search-text-field get-value))])
|
|
(if (string? _searcher)
|
|
(message-box message-box-title _searcher dialog)
|
|
(let ([regexp (with-handlers ([(λ (x) #t)
|
|
(λ (exn)
|
|
(format "~a" (exn-message exn)))])
|
|
(and (send filter-check-box get-value)
|
|
(regexp (send filter-text-field get-value))))])
|
|
(if (string? regexp)
|
|
(message-box message-box-title regexp dialog)
|
|
(begin (set! searcher _searcher)
|
|
(set! filter regexp)
|
|
(set! ok? #t)
|
|
(send dialog show #f))))))]
|
|
[else
|
|
(message-box message-box-title
|
|
(format (string-constant mfs-not-a-dir) (send dir-field get-value))
|
|
dialog)]))
|
|
(define (cancel-button-callback)
|
|
(send dialog show #f))
|
|
|
|
(define (method-callback chk)
|
|
(preferences:set
|
|
'drscheme:multi-file-search:search-check-boxes
|
|
(let loop ([methods-check-boxess methods-check-boxess])
|
|
(cond
|
|
[(null? methods-check-boxess) null]
|
|
[else
|
|
(let loop ([methods-check-boxes (car methods-check-boxess)])
|
|
(cond
|
|
[(null? methods-check-boxes) null]
|
|
[else (cons (send (car methods-check-boxes) get-value)
|
|
(loop (cdr methods-check-boxes)))]))]))))
|
|
|
|
(define (dir-field-callback)
|
|
(let ([df (send dir-field get-value)])
|
|
(when (path-string? df)
|
|
(preferences:set 'drscheme:multi-file-search:directory (string->path df)))))
|
|
|
|
(define (filter-check-box-callback)
|
|
(preferences:set 'drscheme:multi-file-search:filter? (send filter-check-box get-value))
|
|
(send filter-text-field enable (send filter-check-box get-value)))
|
|
(define (filter-text-field-callback)
|
|
(preferences:set 'drscheme:multi-file-search:filter-string (send filter-text-field get-value)))
|
|
|
|
(define (recur-check-box-callback)
|
|
(preferences:set 'drscheme:multi-file-search:recur? (send recur-check-box get-value)))
|
|
(define (methods-choice-callback)
|
|
(preferences:set 'drscheme:multi-file-search:search-type (send methods-choice get-selection))
|
|
(send active-method-panel active-child
|
|
(list-ref (send active-method-panel get-children)
|
|
(send methods-choice get-selection))))
|
|
(define (search-text-field-callback)
|
|
(preferences:set 'drscheme:multi-file-search:search-string (send search-text-field get-value)))
|
|
(define (dir-button-callback)
|
|
(let ([d (get-directory)])
|
|
(when (and d
|
|
(directory-exists? d))
|
|
(preferences:set 'drscheme:multi-file-search:directory d)
|
|
(send dir-field set-value (path->string d)))))
|
|
|
|
(define (get-files)
|
|
(let ([dir (string->path (send dir-field get-value))])
|
|
(and (directory-exists? dir)
|
|
(if (send recur-check-box get-value)
|
|
(build-recursive-file-list dir filter)
|
|
(build-flat-file-list dir filter)))))
|
|
|
|
(define ok? #f)
|
|
|
|
(send button-panel set-alignment 'right 'center)
|
|
(send dir-panel stretchable-height #f)
|
|
(send outer-files-panel stretchable-height #f)
|
|
(send outer-files-panel set-alignment 'left 'center)
|
|
(send files-inset-panel min-width 20)
|
|
(send files-inset-panel stretchable-width #f)
|
|
(send files-panel set-alignment 'left 'center)
|
|
|
|
(send recur-check-box set-value (preferences:get 'drscheme:multi-file-search:recur?))
|
|
(send filter-check-box set-value (preferences:get 'drscheme:multi-file-search:filter?))
|
|
(send search-text-field set-value (preferences:get 'drscheme:multi-file-search:search-string))
|
|
(send filter-text-field set-value (preferences:get 'drscheme:multi-file-search:filter-string))
|
|
(send dir-field set-value (path->string (preferences:get 'drscheme:multi-file-search:directory)))
|
|
|
|
(send outer-method-panel stretchable-height #f)
|
|
(send outer-method-panel set-alignment 'left 'center)
|
|
(send method-inset-panel min-width 20)
|
|
(send method-inset-panel stretchable-width #f)
|
|
(send method-panel set-alignment 'left 'center)
|
|
(send filter-panel stretchable-height #f)
|
|
|
|
(send search-text-field focus)
|
|
(send dialog show #t)
|
|
|
|
(and
|
|
ok?
|
|
(make-search-info
|
|
(send dir-field get-value)
|
|
(send recur-check-box get-value)
|
|
(and (send filter-check-box get-value)
|
|
(regexp (send filter-text-field get-value)))
|
|
searcher)))
|
|
|
|
|
|
;; do-search : search-info text -> void
|
|
;; thread: searching thread
|
|
;; called in a new thread that may be broken (to indicate a stop)
|
|
(define (do-search search-info channel)
|
|
(let* ([dir (search-info-dir search-info)]
|
|
[filter (search-info-filter search-info)]
|
|
[searcher (search-info-searcher search-info)]
|
|
[get-filenames (if (search-info-recur? search-info)
|
|
(build-recursive-file-list dir filter)
|
|
(build-flat-file-list dir filter))])
|
|
(with-handlers ([exn:break? (λ (x) (async-channel-put channel 'break))])
|
|
(let loop ()
|
|
(let ([filename (get-filenames)])
|
|
(when filename
|
|
(searcher filename
|
|
(λ (line-string line-number col-number match-length)
|
|
(async-channel-put
|
|
channel
|
|
(make-search-entry
|
|
filename
|
|
line-string
|
|
line-number
|
|
col-number
|
|
match-length))))
|
|
(loop))))
|
|
(async-channel-put channel 'done))))
|
|
|
|
;; build-recursive-file-list : string (union regexp #f) -> (-> (union string #f))
|
|
;; thread: search thread
|
|
(define (build-recursive-file-list dir filter)
|
|
(letrec ([touched (make-hash-table 'equal)]
|
|
[next-thunk (λ () (process-dir dir (λ () #f)))]
|
|
[process-dir
|
|
; string[dirname] (listof string[filename]) -> (listof string[filename])
|
|
(λ (dir k)
|
|
(let* ([key (normalize-path dir)]
|
|
[traversed? (hash-table-get touched key (λ () #f))])
|
|
(if traversed?
|
|
(k)
|
|
(begin
|
|
(hash-table-put! touched key #t)
|
|
(process-dir-contents
|
|
(map (λ (x) (build-path dir x))
|
|
(directory-list dir))
|
|
k)))))]
|
|
[process-dir-contents
|
|
; string[dirname] (listof string[filename]) -> (listof string[filename])
|
|
(λ (contents k)
|
|
(cond
|
|
[(null? contents)
|
|
(k)]
|
|
[else
|
|
(let ([file/dir (car contents)])
|
|
(cond
|
|
[(and (file-exists? file/dir)
|
|
(or (not filter)
|
|
(regexp-match filter (path->string file/dir))))
|
|
(set! next-thunk
|
|
(λ ()
|
|
(process-dir-contents (cdr contents) k)))
|
|
file/dir]
|
|
[(directory-exists? file/dir)
|
|
(process-dir-contents
|
|
(cdr contents)
|
|
(λ ()
|
|
(process-dir file/dir k)))]
|
|
[else
|
|
(process-dir-contents (cdr contents) k)]))]))])
|
|
(λ () (next-thunk))))
|
|
|
|
;; build-flat-file-list : (union #f regexp) string -> (-> (union string #f))
|
|
;; thread: searching thread
|
|
(define (build-flat-file-list dir filter)
|
|
(let ([contents (map (λ (x) (build-path dir x)) (directory-list dir))])
|
|
(λ ()
|
|
(let loop ()
|
|
(cond
|
|
[(null? contents)
|
|
#f]
|
|
[(and filter (regexp-match filter (car contents)))
|
|
(begin0
|
|
(car contents)
|
|
(set! contents (cdr contents)))]
|
|
[else
|
|
(set! contents (cdr contents))
|
|
(loop)])))))
|
|
|
|
;; exact-match-searcher : make-searcher
|
|
(define (exact-match-searcher params key) ;; thread: main eventspace thread
|
|
(let ([case-sensitive? (car params)])
|
|
(λ (filename add-entry) ;; thread: searching thread
|
|
(let ([text (make-object text:basic%)])
|
|
(send text load-file filename)
|
|
(let loop ([pos 0])
|
|
(let ([found (send text find-string key 'forward pos 'eof #t case-sensitive?)])
|
|
(when found
|
|
(let* ([para (send text position-paragraph found)]
|
|
[para-start (send text paragraph-start-position para)]
|
|
[line-string (send text get-text para-start
|
|
(send text paragraph-end-position para))]
|
|
[line-number para]
|
|
[col-number (- found para-start)]
|
|
[match-length (string-length key)])
|
|
(add-entry line-string line-number col-number match-length)
|
|
(loop (+ found 1))))))))))
|
|
|
|
;; regexp-match-searcher : make-searcher
|
|
;; thread: searching thread
|
|
(define (regexp-match-searcher parmas key) ;; thread: main eventspace thread
|
|
(let ([re:key (with-handlers ([(λ (x) #t)
|
|
(λ (exn)
|
|
(format "~a" (exn-message exn)))])
|
|
(regexp key))])
|
|
(if (string? re:key)
|
|
re:key
|
|
(λ (filename add-entry) ;; thread: searching thread
|
|
(call-with-input-file filename
|
|
(λ (port)
|
|
(let loop ([line-number 0])
|
|
(let ([line (read-line port)])
|
|
(cond
|
|
[(eof-object? line) (void)]
|
|
[else
|
|
(let ([match (regexp-match-positions re:key line)])
|
|
(when match
|
|
(let ([pos (car match)])
|
|
(add-entry line line-number
|
|
(car pos)
|
|
(- (cdr pos) (car pos))))))
|
|
(loop (+ line-number 1))]))))
|
|
'text))))))))
|