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

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

Ensure search files dialog is key when it is first selected (ticket:491).
Save window position of initial search files dialog. Cascade additional
search files dialogs from the topmost one.

File size: 18.3 KB
RevLine 
[9247]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
[11960]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
[9247]28(defclass search-files-window-controller (ns:ns-window-controller)
[11960]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)
[9247]46   (search-dir :initform "" :accessor search-dir) ;the expanded search directory
[11960]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))
[9247]51  (:metaclass ns:+ns-object))
52
[11960]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)))))))
[9247]61
[11960]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)
[9247]65
[11960]66
[9247]67
[11960]68;;; Enable and disable the Search button according to the state of the
69;;; search files dialog.
[9247]70
[11960]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)))))
[9247]75
[11960]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))))))
[9247]83
[11960]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))))
[9247]99
[11960]100(objc:defmethod (#/comboBoxSelectionDidChange: :void) ((wc search-files-window-controller) notification)
101  (declare (ignore notification))
102  (#/setEnabled: (search-button wc) (can-search-p wc)))
[9247]103
[11960]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)))))
[9247]119
[11960]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.
[9247]122
[11960]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*))))
[9247]130
[11960]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)))
[9247]135
[11960]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)))
[9247]139
[11960]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))
[12133]147  (prog1
148      (#/initWithWindowNibName: self #@"SearchFiles")
149    (#/setShouldCascadeWindows: self nil)))
[11960]150
[12133]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
[11960]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
[9247]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
[11960]197(objc:defmethod (#/doSearch: :void) ((wc search-files-window-controller) sender)
[9247]198  (declare (ignore sender))
[11973]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)))
[11960]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)))
[11973]206         (grep-args (list "-I" "-s" "-c" "-e" find-str "--include" file-str
[11960]207                          (get-full-dir-string folder-str))))
[11973]208    (when (recursive-p wc)
209      (push "-r" grep-args))
210    (unless (case-sensitive-p wc)
211      (push "-i" grep-args))
[11960]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 (f (length old-results))
234      (dotimes (l (length (search-result-file-lines f)))
235        (and (search-result-line-nsstr l)
236             (#/release (search-result-line-nsstr l))))
237      (and (search-result-file-nsstr f)
238           (#/release (search-result-file-nsstr f))))
239    (set-results-string wc msg)
240    (when (or (auto-expandable-p (search-results wc))
241              (expand-results-p wc))
242      (expand-all-results wc))
243    (#/reloadData (outline-view wc))
244    (#/setEnabled: (search-button wc) t)))
245   
246;;; This is run in a secondary thread.
247(defun run-grep (grep-arglist wc)
248  (with-autorelease-pool 
249      (#/performSelectorOnMainThread:withObject:waitUntilDone:
[11973]250       (progress-indicator wc) (@selector #/startAnimation:) nil t)
[11960]251    (unwind-protect
252         (let* ((grep-output (call-grep grep-arglist)))
253           (multiple-value-bind (results message)
254               (results-and-message grep-output wc)
255             ;; This assumes that only one grep can be running at
256             ;; a time.
257             (setf (new-results wc) results)
258             (#/performSelectorOnMainThread:withObject:waitUntilDone:
259              wc
260              (@selector #/updateResults:)
261              (#/autorelease (%make-nsstring message))
[11973]262              t)))
[11960]263      (#/performSelectorOnMainThread:withObject:waitUntilDone:
[11973]264       (progress-indicator wc) (@selector #/stopAnimation:) nil t))))
[11960]265
266(defun results-and-message (grep-output wc)
267  (let* ((results (make-array 10 :fill-pointer 0 :adjustable t))
268         (occurrences 0)
269         (file-count 0)
270         (dir-len (length (search-dir wc))))
271    (map-lines
272     grep-output
273     #'(lambda (start end)
274         (let* ((colon-pos (position #\: grep-output :from-end t :start start
275                                     :end end))
[11973]276                (count (and colon-pos
277                            (parse-integer grep-output :start (1+ colon-pos)
278                                           :end end))))
279           (when count
280             (incf file-count)
281             (when (> count 0)
282               (vector-push-extend (make-search-result-file
283                                    :name (subseq grep-output
284                                                  (+ start dir-len)
285                                                  colon-pos)
286                                    :lines (make-array count :initial-element nil))
287                                   results)
288               (incf occurrences count))))))
[11960]289    (values results
290            (format nil "Found ~a occurrence~:p in ~a file~:p out of ~a ~
291                         file~:p searched." occurrences (length results)
292                         file-count))))
293                   
[9247]294(defmethod expand-all-results ((wc search-files-window-controller))
295  (with-slots (outline-view) wc
296    (#/expandItem:expandChildren: outline-view +null-ptr+ t)
297    (#/reloadData outline-view)))
298
299(defmethod collapse-all-results ((wc search-files-window-controller))
300  (with-slots (outline-view) wc
301    (#/collapseItem:collapseChildren: outline-view +null-ptr+ t)
302    (#/reloadData outline-view)))
303
304(defun set-results-string (wc str)
[11960]305  (#/setStringValue: (status-field wc) str))
[9247]306           
[11960]307(objc:defmethod (#/doBrowse: :void) ((wc search-files-window-controller) sender)
[9247]308  (declare (ignore sender))
[11973]309  (let ((pathname (cocoa-choose-directory-dialog)))
310    (when pathname
311      (ccl::with-autoreleased-nsstring
312          (dir (native-translated-namestring pathname))
313        (with-slots (folder-combo-box) wc
314          (#/setStringValue: folder-combo-box dir)
315          (#/updateFolderString: wc folder-combo-box))))))
[9247]316
[11960]317(objc:defmethod (#/editLine: :void) ((wc search-files-window-controller) outline-view)
[9247]318  (let* ((item (get-selected-item outline-view))
319         (line-result (and item (nsstring-to-line-result wc item))))
320    (unless line-result
321      (let ((file-result (and item (nsstring-to-file-result wc item))))
322        (when file-result
323          (setf line-result (get-line-result wc file-result 0)))))         
324    (when line-result
325      (cocoa-edit-grep-line (concatenate 'string (search-dir wc) "/" (search-result-line-file line-result))
326                      (1- (search-result-line-number line-result))))))
327
328(defun get-selected-item (outline-view)
329  (let ((index (#/selectedRow outline-view)))
330    (when (> index -1)
331      (#/itemAtRow: outline-view (#/selectedRow outline-view)))))
332
333(defun nsstring-to-file-result (wc nsstring)
334  (find nsstring (search-results wc) :test #'ns-string-equal :key #'search-result-file-nsstr))
335
336(defun nsstring-to-line-result (wc nsstring)
337  (loop for file-result across (search-results wc)
338    do (loop for line-result across (search-result-file-lines file-result)
339         while line-result
340         do (when (ns-string-equal nsstring (search-result-line-nsstr line-result))
341              (return-from nsstring-to-line-result line-result)))))
342
343;;NSOutlineView data source protocol
344;- (id)outlineView:(NSOutlineView *)outlineView child:(NSInteger)index ofItem:(id)item
345(objc:defmethod #/outlineView:child:ofItem: ((wc search-files-window-controller) view (child :<NSI>nteger) item)
346  (declare (ignore view))
347  (with-slots (results) wc
348    (if (eql item +null-ptr+)
349      (let ((result (aref results child)))
350        (or (search-result-file-nsstr result)
351            (setf (search-result-file-nsstr result)
352                  (%make-nsstring (format nil "[~a] ~a" 
353                                          (length (search-result-file-lines result))
354                                          (search-result-file-name result))))))
355      (let* ((file-result (nsstring-to-file-result wc item))
356             (line-result (get-line-result wc file-result child)))
357        (search-result-line-nsstr line-result)))))
358
359(defun get-line-result (wc file-result index)
360  (let ((lines (search-result-file-lines file-result)))
361    (or (aref lines index)
362        (progn
363          (compute-line-results wc file-result)
364          (aref lines index)))))
365
366(defun compute-line-results (wc file-result)
367  (with-slots (search-str search-dir) wc
368    (let* ((grep-output (call-grep (nconc (unless (case-sensitive-p wc) (list "-i"))
369                                          (list "-n" "-e" search-str 
370                                                (concatenate 'string search-dir (search-result-file-name file-result))))))
371           (index -1))
372      (map-lines grep-output
373                 #'(lambda (start end)
374                     (let* ((str (subseq grep-output start end))
375                            (colon-pos (position #\: str))
376                            (num (parse-integer str :end colon-pos)))
377                       (setf (aref (search-result-file-lines file-result) (incf index))
378                             (make-search-result-line :file (search-result-file-name file-result) 
379                                                      :number num 
380                                                      :nsstr (%make-nsstring str)))))))))
381
382;- (BOOL)outlineView:(NSOutlineView *)outlineView isItemExpandable:(id)item
383(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>) ((wc search-files-window-controller) view item)
384  (declare (ignore view))
385  ;;it's expandable if it starts with #\[ (it's a file)
386  (and (typep item 'ns:ns-string)
387       (= (char-code #\[) (#/characterAtIndex: item 0))))
388
389;- (NSInteger)outlineView:(NSOutlineView *)outlineView numberOfChildrenOfItem:(id)item
390(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
391                ((wc search-files-window-controller) view item)
392  (declare (ignore view))
393  (if (eql item +null-ptr+)
394    (length (search-results wc))
395    (let ((file-result (nsstring-to-file-result wc item)))
396      (if file-result
397        (length (search-result-file-lines file-result))
398        0))))
399
400;- (id)outlineView:(NSOutlineView *)outlineView objectValueForTableColumn:(NSTableColumn *)tableColumn byItem:(id)item
401(objc:defmethod #/outlineView:objectValueForTableColumn:byItem: 
402                ((wc search-files-window-controller) outline-view table-column item)
403  (declare (ignore outline-view table-column))
404  (let ((file-result (nsstring-to-file-result wc item)))
405    (if file-result
406      (search-result-file-nsstr file-result)
407      (let ((line-result (nsstring-to-line-result wc item)))
408        (if line-result
409          (search-result-line-nsstr line-result)
410          #@"ERROR")))))
411
412(defun call-grep (args)
413  ;;Calls grep with the strings as arguments, and returns a string containing the output
414  (with-output-to-string (stream)
415    (let* ((proc (run-program "grep" args :input nil :output stream)))
416      (multiple-value-bind (status exit-code) (external-process-status proc)
417        (let ((output (get-output-stream-string stream)))
[11960]418          (if (eq :exited status)
419            (return-from call-grep output)
420            (error "~a returned exit status ~s" *grep-program* exit-code)))))))
[9247]421
422(defun map-lines (string fn)
423  "For each line in string, fn is called with the start and end of the line"
424  (loop with end = (length string)
425    for start = 0 then (1+ pos)
426    as pos = (or (position #\Newline string :start start :end end) end)
427    when (< start pos) do (funcall fn start pos)
428    while (< pos end)))
429
430
431#|
432(defun top-search ()
433  (#/windowController
434   (first-window-with-controller-type 'search-files-window-controller)))
[11960]435|#
436
Note: See TracBrowser for help on using the repository browser.