source: trunk/source/cocoa-ide/search-files-pre-lion.lisp @ 16126

Last change on this file since 16126 was 16126, checked in by svspire, 6 years ago

Make search-files work again in 10.6.
In addition, there's a new variable *use-pre-lion-search-files* which,
if true, will revert to the old (and IMHO more capable) search-files
behavior even in post-10.6 systems. This must be set prior to
building the IDE. In other words:
(setf ccl::*use-pre-lion-search-files* t)
(require :cocoa-application)
Fixes ticket:1188.

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