source: trunk/source/cocoa-ide/search-files.lisp @ 13116

Last change on this file since 13116 was 13116, checked in by rme, 10 years ago

Patch to #/updateResults: from gfoy. (fixes ticket:615)

File size: 18.5 KB
Line 
1(in-package "GUI")
2
3(defstruct search-result-file 
4  name ;A lisp string that contains the full path of the file
5  nsstr  ;An NSString that is shown in the dialog
6  lines ;A vector of search-result-lines
7  )
8
9(defstruct search-result-line 
10  file ;The search-result-file that contains this search-result-line
11  number ;An integer that is the line-number of the line
12  nsstr ;The NSString used in the dialog
13  )
14
15(defmethod print-object ((srl search-result-line) stream)
16  (print-unreadable-object (srl stream :type t)
17    (format stream "~a ~a ~s" 
18            (search-result-line-file srl)
19            (search-result-line-number srl)
20            (search-result-line-nsstr srl))))
21
22(defconstant $find-combo-box-tag 0)
23(defconstant $folder-combo-box-tag 1)
24(defconstant $file-name-combo-box-tag 2)
25
26(defparameter *search-files-history-limit* 5 "combo box history length")
27
28(defclass search-files-window-controller (ns:ns-window-controller)
29  ((find-combo-box :foreign-type :id :accessor find-combo-box)
30   (folder-combo-box :foreign-type :id :accessor folder-combo-box)
31   (file-name-combo-box :foreign-type :id :accessor file-name-combo-box)
32   (search-button :foreign-type :id :accessor search-button)
33   (browse-button :foreign-type :id :accessor browse-button)
34   (outline-view :foreign-type :id :accessor outline-view)
35   (recursive-checkbox :foreign-type :id :accessor recursive-checkbox)
36   (case-sensitive-checkbox :foreign-type :id :accessor case-sensitive-checkbox)
37   (expand-results-checkbox :foreign-type :id :accessor expand-results-checkbox)
38   (progress-indicator :foreign-type :id :accessor progress-indicator)
39   (status-field :foreign-type :id :accessor status-field)
40   (find-string-value :foreign-type :id :reader find-string-value)
41   (folder-string-value :foreign-type :id :reader folder-string-value)
42   (file-name-string-value :foreign-type :id :reader file-name-string-value)
43   (results :initform (make-array 10 :fill-pointer 0 :adjustable t)
44            :accessor search-results) ;contains a vector of search-result-files
45   (new-results :accessor new-results)
46   (search-dir :initform "" :accessor search-dir) ;the expanded search directory
47   (search-str :initform "" :accessor search-str) ;a lisp string
48   (recursive-p :initform t :reader recursive-p)
49   (case-sensitive-p :initform nil :reader case-sensitive-p)
50   (expand-results-p :initform nil :reader expand-results-p))
51  (:metaclass ns:+ns-object))
52
53(defmacro def-copying-setter (slot-name class-name)
54  (let* ((new (gensym))
55         (obj (gensym)))
56    `(defmethod (setf ,slot-name) (,new (,obj ,class-name))
57       (with-slots (,slot-name) ,obj
58         (unless (eql ,slot-name ,new)
59           (#/release ,slot-name)
60           (setq ,slot-name (#/copy ,new)))))))
61
62(def-copying-setter find-string-value search-files-window-controller)
63(def-copying-setter folder-string-value search-files-window-controller)
64(def-copying-setter file-name-string-value search-files-window-controller)
65
66
67
68;;; Enable and disable the Search button according to the state of the
69;;; search files dialog.
70
71(defun can-search-p (wc)
72  (and (plusp (#/length (find-string-value wc)))
73       (folder-valid-p wc)
74       (plusp (#/length (file-name-string-value wc)))))
75
76(defmethod folder-valid-p ((wc search-files-window-controller))
77  (let* ((fm (#/defaultManager ns:ns-file-manager))
78         (path (folder-string-value wc)))
79    (rlet ((dir-p #>BOOL))
80      (and
81       (#/fileExistsAtPath:isDirectory: fm path dir-p)
82       (plusp (%get-byte dir-p))))))
83
84(objc:defmethod (#/controlTextDidChange: :void) ((wc search-files-window-controller) notification)
85  (let* ((object (#/object notification))
86         (info (#/userInfo notification))
87         (field-editor (#/valueForKey: info #@"NSFieldEditor"))
88         (string-ok (plusp (#/length (find-string-value wc))))
89         (folder-ok (folder-valid-p wc))
90         (file-ok (plusp (#/length (file-name-string-value wc)))))
91    (cond ((eql object (find-combo-box wc))
92           (setf string-ok (plusp (#/length (#/string field-editor)))))
93          ((eql object (folder-combo-box wc))
94           (setf (folder-string-value wc) (#/string field-editor))
95           (setf folder-ok (folder-valid-p wc)))
96          ((eql object (file-name-combo-box wc))
97           (setf file-ok (#/length (#/string field-editor)))))
98    (#/setEnabled: (search-button wc) (and string-ok folder-ok file-ok))))
99
100(objc:defmethod (#/comboBoxSelectionDidChange: :void) ((wc search-files-window-controller) notification)
101  (declare (ignore notification))
102  (#/setEnabled: (search-button wc) (can-search-p wc)))
103
104(objc:defmethod (#/toggleCheckbox: :void) ((wc search-files-window-controller) checkbox)
105  (with-slots (recursive-checkbox case-sensitive-checkbox expand-results-checkbox
106               recursive-p case-sensitive-p expand-results-p) wc
107    (cond ((eql checkbox recursive-checkbox)
108           (setf recursive-p (not recursive-p)))
109          ((eql checkbox case-sensitive-checkbox)
110           (setf case-sensitive-p (not case-sensitive-p)))
111          ((eql checkbox expand-results-checkbox)
112           (setf expand-results-p (not expand-results-p))
113           (if expand-results-p
114             (expand-all-results wc)
115             (collapse-all-results wc))
116           (#/reloadData (outline-view wc)))
117          (t
118           (error "Unknown checkbox ~s" checkbox)))))
119
120;;; For simple strings, it's easier to use the combo box's built-in
121;;; list than it is to mess around with a data source.
122
123(defun update-combo-box (combo-box string)
124  (check-type string ns:ns-string)
125  (unless (#/isEqualToString: string #@"")
126    (#/removeItemWithObjectValue: combo-box string)
127    (#/insertItemWithObjectValue:atIndex: combo-box string 0)
128    (when (> (#/numberOfItems combo-box) *search-files-history-limit*)
129      (#/removeItemAtIndex: combo-box *search-files-history-limit*))))
130
131(objc:defmethod (#/updateFindString: :void) ((wc search-files-window-controller)
132                                             sender)
133  (setf (find-string-value wc) (#/stringValue sender))
134  (update-combo-box sender (find-string-value wc)))
135
136(objc:defmethod (#/updateFolderString: :void) ((wc search-files-window-controller) sender)
137  (setf (folder-string-value wc) (#/stringValue sender))
138  (update-combo-box sender (folder-string-value wc)))
139
140(objc:defmethod (#/updateFileNameString: :void) ((wc search-files-window-controller) sender)
141  (setf (file-name-string-value wc) (#/stringValue sender))
142  (update-combo-box sender (file-name-string-value wc)))
143
144
145
146(objc:defmethod #/init ((self search-files-window-controller))
147  (prog1
148      (#/initWithWindowNibName: self #@"SearchFiles")
149    (#/setShouldCascadeWindows: self nil)))
150
151(defloadvar *search-files-cascade-point* (ns:make-ns-point 0 0))
152
153(objc:defmethod (#/windowDidLoad :void) ((wc search-files-window-controller))
154  ;; Cascade window from the top left point of the topmost search files window.
155  (flet ((good-window-p (w)
156           (and (not (eql w (#/window wc)))
157                (eql (#/class (#/windowController w))
158                     (find-class 'search-files-window-controller)))))
159    (let* ((dialogs (remove-if-not #'good-window-p (gui::windows)))
160           (top-dialog (car dialogs)))
161      (if top-dialog
162        (ns:with-ns-point (zp 0 0)
163          (setq *search-files-cascade-point*
164                (#/cascadeTopLeftFromPoint: top-dialog zp))))))
165  (#/cascadeTopLeftFromPoint: (#/window wc) *search-files-cascade-point*))
166
167(objc:defmethod (#/awakeFromNib :void) ((wc search-files-window-controller))
168  (#/setStringValue: (status-field wc) #@"")
169  (with-slots (outline-view) wc
170    (#/setTarget: outline-view wc)
171    (#/setDoubleAction: outline-view (@selector #/editLine:)))
172  (setf (find-string-value wc) #@"")
173  (with-slots (file-name-combo-box) wc
174    (#/setStringValue: file-name-combo-box #@"*.lisp")
175    (#/updateFileNameString: wc file-name-combo-box))
176  (with-slots (folder-combo-box) wc
177    (let ((dir (ccl::native-translated-namestring (ccl:current-directory))))
178    (#/setStringValue: folder-combo-box
179                       (#/autorelease (%make-nsstring dir)))
180    (#/updateFolderString: wc folder-combo-box))))
181
182(defun ns-string-equal (ns1 ns2)
183  (and (typep ns1 'ns:ns-string)
184       (typep ns2 'ns:ns-string)
185       (#/isEqualToString: ns1 ns2)))
186
187(defmethod get-full-dir-string ((str string))
188  ;make sure it has a trailing slash
189  (let ((ret (ccl::native-untranslated-namestring str)))
190    (unless (eql #\/ (aref str (1- (length str))))
191      (setf ret (concatenate 'string ret "/")))
192    ret))
193
194(defmethod get-full-dir-string ((nsstring ns:ns-string))
195  (get-full-dir-string (lisp-string-from-nsstring nsstring)))
196
197(objc:defmethod (#/doSearch: :void) ((wc search-files-window-controller) sender)
198  (declare (ignore sender))
199  (set-results-string wc #@"Searching...")
200  (setf (find-string-value wc) (#/stringValue (find-combo-box wc))
201        (folder-string-value wc) (#/stringValue (folder-combo-box wc))
202        (file-name-string-value wc) (#/stringValue (file-name-combo-box wc)))
203  (let* ((find-str (lisp-string-from-nsstring (find-string-value wc)))
204         (folder-str (lisp-string-from-nsstring (folder-string-value wc)))
205         (file-str (lisp-string-from-nsstring (file-name-string-value wc)))
206         (grep-args (list "-I" "-s" "-c" "-e" find-str "--include" file-str
207                          (get-full-dir-string folder-str))))
208    (when (recursive-p wc)
209      (push "-r" grep-args))
210    (unless (case-sensitive-p wc)
211      (push "-i" grep-args))
212    (setf (search-dir wc) folder-str
213          (search-str wc) find-str)
214    (#/setEnabled: (search-button wc) nil)
215    (process-run-function "grep" 'run-grep grep-args wc)
216    (#/setTitle: (#/window wc) (#/autorelease
217                                (%make-nsstring (format nil "Search Files: ~a"
218                                                        find-str))))))
219
220(defun auto-expandable-p (results)
221  (let ((n 0))
222    (dotimes (f (length results) t)
223      (dotimes (l (length (search-result-file-lines (aref results f))))
224        (incf n)
225        (when (> n 20)
226          (return-from auto-expandable-p nil))))))
227
228(objc:defmethod (#/updateResults: :void) ((wc search-files-window-controller)
229                                          msg)
230  (let* ((old-results (search-results wc)))
231    (setf (search-results wc) (new-results wc))
232    ;; release NSString instances.  sigh.
233    (dotimes (idx (length old-results))
234      (let* ((file (aref old-results idx))
235             (lines (when file (search-result-file-lines file))))
236        (dotimes (idx (length lines))
237          (let* ((line (aref lines idx))
238                 (string (when line (search-result-line-nsstr line))))
239            (and string (#/release string))))
240        (and (search-result-file-nsstr file)
241             (#/release (search-result-file-nsstr file)))))
242    (set-results-string wc msg)
243;;     (when (or (auto-expandable-p (search-results wc))
244;;              (expand-results-p wc))
245;;       (expand-all-results wc))
246    (#/reloadData (outline-view wc))
247    (#/setEnabled: (search-button wc) t)))
248
249;;; This is run in a secondary thread.
250(defun run-grep (grep-arglist wc)
251  (with-autorelease-pool 
252      (#/performSelectorOnMainThread:withObject:waitUntilDone:
253       (progress-indicator wc) (@selector #/startAnimation:) nil t)
254    (unwind-protect
255         (let* ((grep-output (call-grep grep-arglist)))
256           (multiple-value-bind (results message)
257               (results-and-message grep-output wc)
258             ;; This assumes that only one grep can be running at
259             ;; a time.
260             (setf (new-results wc) results)
261             (#/performSelectorOnMainThread:withObject:waitUntilDone:
262              wc
263              (@selector #/updateResults:)
264              (#/autorelease (%make-nsstring message))
265              t)))
266      (#/performSelectorOnMainThread:withObject:waitUntilDone:
267       (progress-indicator wc) (@selector #/stopAnimation:) nil t))))
268
269(defun results-and-message (grep-output wc)
270  (let* ((results (make-array 10 :fill-pointer 0 :adjustable t))
271         (occurrences 0)
272         (file-count 0)
273         (dir-len (length (search-dir wc))))
274    (map-lines
275     grep-output
276     #'(lambda (start end)
277         (let* ((colon-pos (position #\: grep-output :from-end t :start start
278                                     :end end))
279                (count (and colon-pos
280                            (parse-integer grep-output :start (1+ colon-pos)
281                                           :end end))))
282           (when count
283             (incf file-count)
284             (when (> count 0)
285               (vector-push-extend (make-search-result-file
286                                    :name (subseq grep-output
287                                                  (+ start dir-len)
288                                                  colon-pos)
289                                    :lines (make-array count :initial-element nil))
290                                   results)
291               (incf occurrences count))))))
292    (values results
293            (format nil "Found ~a occurrence~:p in ~a file~:p out of ~a ~
294                         file~:p searched." occurrences (length results)
295                         file-count))))
296                   
297(defmethod expand-all-results ((wc search-files-window-controller))
298  (with-slots (outline-view) wc
299    (#/expandItem:expandChildren: outline-view +null-ptr+ t)
300    (#/reloadData outline-view)))
301
302(defmethod collapse-all-results ((wc search-files-window-controller))
303  (with-slots (outline-view) wc
304    (#/collapseItem:collapseChildren: outline-view +null-ptr+ t)
305    (#/reloadData outline-view)))
306
307(defun set-results-string (wc str)
308  (#/setStringValue: (status-field wc) str))
309           
310(objc:defmethod (#/doBrowse: :void) ((wc search-files-window-controller) sender)
311  (declare (ignore sender))
312  (let ((pathname (cocoa-choose-directory-dialog)))
313    (when pathname
314      (ccl::with-autoreleased-nsstring
315          (dir (native-translated-namestring pathname))
316        (with-slots (folder-combo-box) wc
317          (#/setStringValue: folder-combo-box dir)
318          (#/updateFolderString: wc folder-combo-box))))))
319
320(objc:defmethod (#/editLine: :void) ((wc search-files-window-controller) outline-view)
321  (let* ((item (get-selected-item outline-view))
322         (line-result (and item (nsstring-to-line-result wc item))))
323    (unless line-result
324      (let ((file-result (and item (nsstring-to-file-result wc item))))
325        (when file-result
326          (setf line-result (get-line-result wc file-result 0)))))         
327    (when line-result
328      (cocoa-edit-grep-line (concatenate 'string (search-dir wc) "/" (search-result-line-file line-result))
329                      (1- (search-result-line-number line-result))))))
330
331(defun get-selected-item (outline-view)
332  (let ((index (#/selectedRow outline-view)))
333    (when (> index -1)
334      (#/itemAtRow: outline-view (#/selectedRow outline-view)))))
335
336(defun nsstring-to-file-result (wc nsstring)
337  (find nsstring (search-results wc) :test #'ns-string-equal :key #'search-result-file-nsstr))
338
339(defun nsstring-to-line-result (wc nsstring)
340  (loop for file-result across (search-results wc)
341    do (loop for line-result across (search-result-file-lines file-result)
342         while line-result
343         do (when (ns-string-equal nsstring (search-result-line-nsstr line-result))
344              (return-from nsstring-to-line-result line-result)))))
345
346;;NSOutlineView data source protocol
347;- (id)outlineView:(NSOutlineView *)outlineView child:(NSInteger)index ofItem:(id)item
348(objc:defmethod #/outlineView:child:ofItem: ((wc search-files-window-controller) view (child :<NSI>nteger) item)
349  (declare (ignore view))
350  (with-slots (results) wc
351    (if (eql item +null-ptr+)
352      (let ((result (aref results child)))
353        (or (search-result-file-nsstr result)
354            (setf (search-result-file-nsstr result)
355                  (%make-nsstring (format nil "[~a] ~a" 
356                                          (length (search-result-file-lines result))
357                                          (search-result-file-name result))))))
358      (let* ((file-result (nsstring-to-file-result wc item))
359             (line-result (get-line-result wc file-result child)))
360        (search-result-line-nsstr line-result)))))
361
362(defun get-line-result (wc file-result index)
363  (let ((lines (search-result-file-lines file-result)))
364    (or (aref lines index)
365        (progn
366          (compute-line-results wc file-result)
367          (aref lines index)))))
368
369(defun compute-line-results (wc file-result)
370  (with-slots (search-str search-dir) wc
371    (let* ((grep-output (call-grep (nconc (unless (case-sensitive-p wc) (list "-i"))
372                                          (list "-n" "-e" search-str 
373                                                (concatenate 'string search-dir (search-result-file-name file-result))))))
374           (index -1))
375      (map-lines grep-output
376                 #'(lambda (start end)
377                     (let* ((str (subseq grep-output start end))
378                            (colon-pos (position #\: str))
379                            (num (parse-integer str :end colon-pos)))
380                       (setf (aref (search-result-file-lines file-result) (incf index))
381                             (make-search-result-line :file (search-result-file-name file-result) 
382                                                      :number num 
383                                                      :nsstr (%make-nsstring str)))))))))
384
385;- (BOOL)outlineView:(NSOutlineView *)outlineView isItemExpandable:(id)item
386(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>) ((wc search-files-window-controller) view item)
387  (declare (ignore view))
388  ;;it's expandable if it starts with #\[ (it's a file)
389  (and (typep item 'ns:ns-string)
390       (= (char-code #\[) (#/characterAtIndex: item 0))))
391
392;- (NSInteger)outlineView:(NSOutlineView *)outlineView numberOfChildrenOfItem:(id)item
393(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
394                ((wc search-files-window-controller) view item)
395  (declare (ignore view))
396  (if (eql item +null-ptr+)
397    (length (search-results wc))
398    (let ((file-result (nsstring-to-file-result wc item)))
399      (if file-result
400        (length (search-result-file-lines file-result))
401        0))))
402
403;- (id)outlineView:(NSOutlineView *)outlineView objectValueForTableColumn:(NSTableColumn *)tableColumn byItem:(id)item
404(objc:defmethod #/outlineView:objectValueForTableColumn:byItem: 
405                ((wc search-files-window-controller) outline-view table-column item)
406  (declare (ignore outline-view table-column))
407  (let ((file-result (nsstring-to-file-result wc item)))
408    (if file-result
409      (search-result-file-nsstr file-result)
410      (let ((line-result (nsstring-to-line-result wc item)))
411        (if line-result
412          (search-result-line-nsstr line-result)
413          #@"ERROR")))))
414
415(defun call-grep (args)
416  ;;Calls grep with the strings as arguments, and returns a string containing the output
417  (with-output-to-string (stream)
418    (let* ((proc (run-program "grep" args :input nil :output stream)))
419      (multiple-value-bind (status exit-code) (external-process-status proc)
420        (let ((output (get-output-stream-string stream)))
421          (if (eq :exited status)
422            (return-from call-grep output)
423            (error "~a returned exit status ~s" *grep-program* exit-code)))))))
424
425(defun map-lines (string fn)
426  "For each line in string, fn is called with the start and end of the line"
427  (loop with end = (length string)
428    for start = 0 then (1+ pos)
429    as pos = (or (position #\Newline string :start start :end end) end)
430    when (< start pos) do (funcall fn start pos)
431    while (< pos end)))
432
433
434#|
435(defun top-search ()
436  (#/windowController
437   (first-window-with-controller-type 'search-files-window-controller)))
438|#
439
Note: See TracBrowser for help on using the repository browser.