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

Last change on this file was 16686, checked in by rme, 4 years ago

Update copyright/license headers in cocoa-ide directory.

File size: 29.6 KB
Line 
1;;;
2;;; Copyright 2016 Clozure Associates
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;;     http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16(in-package "GUI")
17
18(defparameter *search-files-history-limit* 5 "combo box history length")
19
20;;;
21;;; Creating the outline view from grep
22;;;
23
24;;; Views for the outline view
25
26(defun %image-and-text-table-cell-view ()
27  (cg:with-rects ((image-frame 0 0 16 16)
28                  (text-field-frame 0 0 100 16))
29    (let* ((view (#/initWithFrame: (#/alloc ns:ns-table-cell-view)
30                                   #&NSZeroRect))
31           (image-view (#/initWithFrame: (#/alloc ns:ns-image-view)
32                                         image-frame))
33           (text-field (#/initWithFrame: (#/alloc ns:ns-text-field)
34                                         text-field-frame))
35           (views-dict (#/dictionaryWithObjectsAndKeys: ns:ns-dictionary
36                                                        image-view #@"imageView"
37                                                        text-field #@"textField"
38                                                        +null-ptr+)))
39      (#/setNextKeyView: view text-field)
40      (#/setImageView: view image-view)
41      (#/setTextField: view text-field)
42      (#/setDrawsBackground: text-field nil)
43      (#/setFont: text-field (#/systemFontOfSize:
44                              ns:ns-font
45                              (#/smallSystemFontSize ns:ns-font)))
46      (#/setBordered: text-field nil)
47      (#/setEditable: text-field nil)
48      (#/setLineBreakMode: (#/cell text-field)
49                           #$NSLineBreakByTruncatingTail)
50      (#/setTranslatesAutoresizingMaskIntoConstraints: image-view nil)
51      (#/setTranslatesAutoresizingMaskIntoConstraints: text-field nil)
52      (#/addSubview: view image-view)
53      (#/release image-view)
54      (#/addSubview: view text-field)
55      (#/release text-field)
56      (#/addConstraints: view
57                         (#/constraintsWithVisualFormat:options:metrics:views:
58                          ns:ns-layout-constraint
59                          #@"|-5-[imageView(==16)]-[textField(>=100)]|"
60                          0 +null-ptr+ views-dict))
61      (#/addConstraint: view
62                        (#/constraintWithItem:attribute:relatedBy:toItem:attribute:multiplier:constant:
63                         ns:ns-layout-constraint image-view #$NSLayoutAttributeCenterY
64                         #$NSLayoutRelationEqual view #$NSLayoutAttributeCenterY 1d0 0d0))
65      (#/addConstraint: view
66                        (#/constraintWithItem:attribute:relatedBy:toItem:attribute:multiplier:constant:
67                         ns:ns-layout-constraint text-field #$NSLayoutAttributeCenterY
68                         #$NSLayoutRelationEqual view #$NSLayoutAttributeCenterY 1d0 0d0))
69      view)))
70
71(defun %navigator-search-table-cell-view ()
72  (%image-and-text-table-cell-view))
73
74(defun %navigator-match-table-cell-view ()
75  (cg:with-rects ((text-field-frame 0 0 100 16))
76    (let* ((view (#/initWithFrame: (#/alloc ns:ns-table-cell-view)
77                                   #&NSZeroRect))
78           (text-field (#/initWithFrame: (#/alloc ns:ns-text-field)
79                                         text-field-frame))
80           (views-dict (#/dictionaryWithObjectsAndKeys: ns:ns-dictionary
81                                                        text-field
82                                                        #@"textField"
83                                                        +null-ptr+)))
84      (#/setNextKeyView: view text-field)
85      (#/setTextField: view text-field)
86      (#/setDrawsBackground: text-field nil)
87      (#/setFont: text-field (#/systemFontOfSize:
88                              ns:ns-font
89                              (#/smallSystemFontSize ns:ns-font)))
90      (#/setBordered: text-field nil)
91      (#/setEditable: text-field t)
92      (#/setLineBreakMode: (#/cell text-field)
93                           #$NSLineBreakByTruncatingTail)
94      (#/setTranslatesAutoresizingMaskIntoConstraints: text-field nil)
95      (#/addSubview: view text-field)
96      (#/release text-field)
97      (#/addConstraints: view (#/constraintsWithVisualFormat:options:metrics:views:
98                               ns:ns-layout-constraint
99                               #@"|-5-[textField(>=100)]|"
100                               0 +null-ptr+ views-dict))
101      (#/addConstraint: view
102                        (#/constraintWithItem:attribute:relatedBy:toItem:attribute:multiplier:constant:
103                         ns:ns-layout-constraint text-field #$NSLayoutAttributeCenterY
104                         #$NSLayoutRelationEqual view #$NSLayoutAttributeCenterY 1d0 0d0))
105      view)))
106
107
108
109(defun string-to-lines (string)
110  (with-input-from-string (s string)
111    (loop for line = (read-line s nil nil) while line collect line)))
112
113(defun run-grep (pathnames pattern)
114  ;; Don't try to grep files that don't exist.  Even if we use
115  ;; grep's -s flag, the exit code will still indicate an error.
116  (setq pathnames (remove-if-not #'probe-file pathnames))
117  (let* ((s (make-string-output-stream))
118         (args (append (list "-nHI" "--null" "--directories=skip" "-F" pattern) pathnames))
119         (proc (run-program "/usr/bin/grep" args :input nil :output s)))
120    (multiple-value-bind (status exit-code)
121                         (external-process-status proc)
122      (if (eq status :exited)
123        (cond ((= exit-code 0)
124               ;; matched one or more lines
125               (values (string-to-lines (get-output-stream-string s)) t))
126              ((= exit-code 1)
127               ;; no matches
128               (values nil t))
129              ((>= exit-code 2)
130               ;; some error occurred
131               (values nil nil)))
132        (values (ccl::describe-external-process-failure proc "running grep") nil)))))
133
134(defun run-search-files-grep (folder file-pattern pattern
135                              &key recursive case-sensitive regex)
136  (when (probe-file folder)
137    (let* ((s (make-string-output-stream))
138           (args (append (list "-snHI" "--null" "--include" file-pattern
139                               "--directories=skip")
140                         (when recursive
141                           (list "-R"))
142                         (unless case-sensitive
143                           (list "-i"))
144                         (unless regex
145                           (list "-F"))
146                         (list pattern
147                               (string-right-trim "/" folder))))
148           (proc (run-program "/usr/bin/grep" args :input nil :output s)))
149      (multiple-value-bind (status exit-code)
150          (external-process-status proc)
151        (if (eq status :exited)
152            (cond ((= exit-code 0)
153                   ;; matched one or more lines
154                   (values (string-to-lines (get-output-stream-string s)) t))
155                  ((= exit-code 1)
156                   ;; no matches
157                   (values nil t))
158                  ((>= exit-code 2)
159                   ;; Return *some* data, even if the exit code
160                   ;; indicates an error. This is mainly because grep
161                   ;; will still return useful results even if some
162                   ;; files were unreadable (e.g. dangling symlinks).
163                   (values (string-to-lines (get-output-stream-string s))
164                           nil)))
165            (values (ccl::describe-external-process-failure proc "running grep") nil))))))
166
167(defclass grep-result ()
168  ((file :accessor grep-result-file :initarg :file)
169   (matches :accessor grep-result-matches :initarg :matches)))
170
171(defun grep-result-match-count (grep-result)
172  (length (grep-result-matches grep-result)))
173
174(defmethod print-object ((g grep-result) stream)
175  (print-unreadable-object (g stream :type t)
176    (format stream "~s, ~d matched line~:p" (grep-result-file g)
177            (length (grep-result-matches g)))))
178
179(defun make-grep-result (filename matches)
180  (make-instance 'grep-result :file filename :matches matches))
181
182;; This assumes that grep was called with --null, which prints a null
183;; after the filname.  If it printed the usual #\: then we would choke
184;; on file names that contain colons.
185(defun grep-output-line-values (line)
186  (let* ((nul (position #\nul line))
187         (colon (position #\: line :start (1+ nul))))
188    (values (subseq line 0 nul)
189            (parse-integer line :start (1+ nul) :end colon)
190            (subseq line (1+ colon)))))
191
192(defun generate-grep-results (lines)
193  (let ((current-filename nil)
194        (current-matches nil)
195        (results nil))
196    (dolist (line lines)
197      (multiple-value-bind (filename line-number text)
198                           (grep-output-line-values line)
199        (cond ((null current-filename)
200               (setq current-filename filename)
201               (push (list line-number text) current-matches))
202              ((string= filename current-filename)
203               (push (list line-number text) current-matches))
204              (t
205               (push (make-grep-result current-filename
206                                       (nreverse current-matches)) results)
207               (setq current-filename filename)
208               (setq current-matches nil)
209               (push (list line-number text) current-matches)))))
210    (when current-matches
211      (push (make-grep-result current-filename
212                              (nreverse current-matches)) results))
213    (nreverse results)))
214
215(defclass navigator-search-node-data (ns:ns-object)
216  ((display-string :foreign-type :id)
217   (url :foreign-type :id)
218   (line-number :foreign-type #>NSInteger)
219   (text :foreign-type :id))
220  (:metaclass ns:+ns-object))
221
222(objc:defmethod (#/setDisplayString: :void) ((self navigator-search-node-data) string)
223  (with-slots (display-string) self
224    (unless (eql string display-string)
225      (#/release display-string)
226      (setq display-string (#/retain string)))))
227
228(objc:defmethod #/URL ((self navigator-search-node-data))
229  (slot-value self 'url))
230
231(objc:defmethod (#/setURL: :void) ((self navigator-search-node-data) new-url)
232  (with-slots (url) self
233    (unless (eql url new-url)
234      (#/release url)
235      (setq url (#/retain new-url)))))
236
237(objc:defmethod (#/lineNumber #>NSInteger) ((self navigator-search-node-data))
238  (slot-value self 'line-number))
239
240(objc:defmethod (#/setLineNumber: :void) ((self navigator-search-node-data)
241                                          (number #>NSInteger))
242  (setf (slot-value self 'line-number) number))
243
244(objc:defmethod (#/setText: :void) ((self navigator-search-node-data) string)
245  (with-slots (text) self
246    (unless (eql string text)
247      (#/release text)
248      (setq text (#/retain string)))))
249
250(objc:defmethod (#/dealloc :void) ((self navigator-search-node-data))
251  (#/release (slot-value self 'display-string))
252  (#/release (slot-value self 'url))
253  (#/release (slot-value self 'text))
254  (call-next-method))
255
256(objc:defmethod (#/isContainer #>BOOL) ((self navigator-search-node-data))
257  (%null-ptr-p (slot-value self 'text)))
258
259(defun %tree-node-for-grep-result (grep-result)
260  (let* ((node-data (#/new navigator-search-node-data))
261         (node (#/initWithRepresentedObject: (#/alloc ns:ns-tree-node) node-data))
262         (file (grep-result-file grep-result)))
263    (#/release node-data)
264    (with-cfstring (s file)
265      (#/setDisplayString: node-data s))
266    (with-cfurl (u file)
267      (#/setURL: node-data u))
268    (let ((matches (grep-result-matches grep-result)))
269      (dolist (match matches)
270        (let* ((child-node-data (#/new navigator-search-node-data))
271               (child-node (#/initWithRepresentedObject: (#/alloc ns:ns-tree-node)
272                                                         child-node-data))
273               (line-number (first match))
274               (text (second match)))
275          (#/release child-node-data)
276          (with-cfurl (u file)
277            (#/setURL: child-node-data u))
278          (#/setLineNumber: child-node-data line-number)
279          (with-cfstring (s text)
280            (#/setText: child-node-data s))
281          (#/addObject: (#/childNodes node) child-node))))
282    node))
283
284(defun %tree-node-for-grep-results (grep-results)
285  (let* ((root-node (#/initWithRepresentedObject: (#/alloc ns:ns-tree-node)
286                                                  +null-ptr+))
287         (children (#/mutableChildNodes root-node)))
288    (dolist (r grep-results)
289      (let ((node (%tree-node-for-grep-result r)))
290        (#/addObject: children node)
291        (#/release node)))
292    root-node))
293
294(defclass grep-results-data-source (ns:ns-object)
295  ((root-node :foreign-type :id))
296  (:metaclass ns:+ns-object))
297
298(objc:defmethod #/init ((self grep-results-data-source))
299  (let ((new (call-next-method)))
300    (unless (%null-ptr-p new)
301      (setf (slot-value self 'root-node)
302            (#/initWithRepresentedObject: (#/alloc ns:ns-tree-node)
303                                          +null-ptr+)))
304    new))
305
306(objc:defmethod (#/dealloc :void) ((self grep-results-data-source))
307  (#/release (slot-value self 'root-node))
308  (call-next-method))
309
310(objc:defmethod (#/setRootNode: :void) ((self grep-results-data-source) tree-node)
311  (with-slots (root-node) self
312    (unless (eql root-node tree-node)
313      (#/release root-node)
314      (setq root-node (#/retain tree-node)))))
315
316(objc:defmethod #/childrenForItem: ((self grep-results-data-source) item)
317  (if (%null-ptr-p item)
318    (#/childNodes (slot-value self 'root-node))
319    (#/childNodes item)))
320
321(objc:defmethod (#/outlineView:numberOfChildrenOfItem: #>NSInteger)
322                ((self grep-results-data-source) outline-view item)
323  (declare (ignore outline-view))
324  (#/count (#/childrenForItem: self item)))
325
326(objc:defmethod (#/outlineView:isItemExpandable: #>BOOL)
327                ((self grep-results-data-source) outline-view item)
328  (declare (ignore outline-view))
329  (let* ((node (if (%null-ptr-p item)
330                 (slot-value self 'root-node)
331                 item))
332         (node-data (#/representedObject node)))
333    (#/isContainer node-data)))
334
335(objc:defmethod #/outlineView:child:ofItem: ((self grep-results-data-source)
336                                             outline-view (index #>NSInteger)
337                                             item)
338  (declare (ignore outline-view))
339  (let ((children (#/childrenForItem: self item)))
340    (#/objectAtIndex: children index)))
341
342(objc:defmethod #/outlineView:viewForTableColumn:item: ((self grep-results-data-source)
343                                                       outline-view table-column item)
344  (declare (ignore table-column))
345  (cond ((zerop (#/count (#/childNodes item)))
346         (let ((view (%navigator-match-table-cell-view))
347               (node-data (#/representedObject item)))
348           (#/setStringValue: (#/textField view) (slot-value node-data 'text))
349           (#/setEditable: (#/textField view) nil)
350           (#/autorelease view)))
351        (t
352         (let ((view (#/makeViewWithIdentifier:owner: outline-view
353                                                      #@"search-files-cell" self)))
354           (when (%null-ptr-p view)
355             (setq view (%navigator-search-table-cell-view))
356             (#/setIdentifier: view #@"search-files-cell")
357             (#/autorelease view))
358           (let* ((node-data (#/representedObject item))
359                  (url (slot-value node-data 'url))
360                  (extension (#/pathExtension url))
361                  (name +null-ptr+))
362             (unless (%null-ptr-p url)
363               (setq name (#/path url)))
364             (if (%null-ptr-p name)
365               (setq name #@"no url?"))
366             (#/setEditable: (#/textField view) nil)
367             (#/setTranslatesAutoresizingMaskIntoConstraints: (#/imageView view) nil)
368             (#/setTranslatesAutoresizingMaskIntoConstraints: (#/textField view) nil)
369             (#/setImage: (#/imageView view)
370                          (#/iconForFileType: (#/sharedWorkspace ns:ns-workspace) extension))
371             (#/setStringValue: (#/textField view) name))
372           view))))
373
374(objc:defmethod (#/outlineView:shouldSelectItem: #>BOOL) ((self grep-results-data-source) ov
375                                                         item)
376  (declare (ignore ov))
377  (let ((node-data (#/representedObject item)))
378    (not (#/isContainer node-data))))
379
380;;;
381;;; Displaying and updating the interface
382;;;
383
384
385(defclass search-files-window-controller (ns:ns-window-controller)
386  ((find-combo-box :foreign-type :id :accessor find-combo-box)
387   (folder-combo-box :foreign-type :id :accessor folder-combo-box)
388   (file-name-combo-box :foreign-type :id :accessor file-name-combo-box)
389   (search-button :foreign-type :id :accessor search-button)
390   (browse-button :foreign-type :id :accessor browse-button)
391   (outline-view :foreign-type :id :accessor outline-view)
392   (recursive-checkbox :foreign-type :id :accessor recursive-checkbox)
393   (regex-checkbox :foreign-type :id :accessor regex-checkbox)
394   (case-sensitive-checkbox :foreign-type :id :accessor case-sensitive-checkbox)
395   (expand-results-checkbox :foreign-type :id :accessor expand-results-checkbox)
396   (progress-indicator :foreign-type :id :accessor progress-indicator)
397   (status-field :foreign-type :id :accessor status-field)
398   (find-string-value :foreign-type :id :reader find-string-value)
399   (folder-string-value :foreign-type :id :reader folder-string-value)
400   (file-name-string-value :foreign-type :id :reader file-name-string-value)
401   (results :initform (make-array 10 :fill-pointer 0 :adjustable t)
402            :accessor search-results) ;contains a vector of search-result-files
403   (new-results :accessor new-results)
404   (search-dir :initform "" :accessor search-dir) ;the expanded search directory
405   (search-str :initform "" :accessor search-str) ;a lisp string
406   (recursive-p :initform t :reader recursive-p)
407   (regex-p :initform t :reader regex-p)
408   (case-sensitive-p :initform nil :reader case-sensitive-p)
409   (expand-results-p :initform nil :reader expand-results-p)
410   (grep-process :initform nil :accessor grep-process)
411   (search-data-source :foreign-type :id :accessor search-data-source))
412  (:metaclass ns:+ns-object))
413
414(defmacro def-copying-setter (slot-name class-name)
415  (let* ((new (gensym))
416         (obj (gensym)))
417    `(defmethod (setf ,slot-name) (,new (,obj ,class-name))
418       (with-slots (,slot-name) ,obj
419         (unless (eql ,slot-name ,new)
420           (#/release ,slot-name)
421           (setq ,slot-name (#/copy ,new)))))))
422
423(def-copying-setter find-string-value search-files-window-controller)
424(def-copying-setter folder-string-value search-files-window-controller)
425(def-copying-setter file-name-string-value search-files-window-controller)
426
427;;; Enable and disable the Search button according to the state of the
428;;; search files dialog.
429
430(defun can-search-p (wc)
431  (and (plusp (#/length (find-string-value wc)))
432       (folder-valid-p wc)
433       (plusp (#/length (file-name-string-value wc)))))
434
435(defmethod folder-valid-p ((wc search-files-window-controller))
436  (let* ((nsstr (folder-string-value wc)))
437    (when (and (typep nsstr ns:ns-string) (plusp (#/length nsstr)))
438      (let ((lstr (lisp-string-from-nsstring nsstr)))
439        (when (valid-host-p lstr)
440          (ignore-errors (probe-file (get-full-dir-string lstr))))))))
441
442(objc:defmethod (#/controlTextDidChange: :void) ((wc search-files-window-controller) notification)
443  (let* ((object (#/object notification))
444         (info (#/userInfo notification))
445         (field-editor (#/valueForKey: info #@"NSFieldEditor"))
446         (string-ok (plusp (#/length (find-string-value wc))))
447         (folder-ok (folder-valid-p wc))
448         (file-ok (plusp (#/length (file-name-string-value wc)))))
449    (cond ((eql object (find-combo-box wc))
450           (setf string-ok (plusp (#/length (#/string field-editor)))))
451          ((eql object (folder-combo-box wc))
452           (setf (folder-string-value wc) (#/string field-editor))
453           (setf folder-ok (folder-valid-p wc)))
454          ((eql object (file-name-combo-box wc))
455           (setf file-ok (#/length (#/string field-editor)))))
456    (#/setEnabled: (search-button wc) (and string-ok folder-ok file-ok))))
457
458(objc:defmethod (#/comboBoxSelectionDidChange: :void) ((wc search-files-window-controller) notification)
459  (declare (ignore notification))
460  (#/setEnabled: (search-button wc) (can-search-p wc)))
461
462(objc:defmethod (#/toggleCheckbox: :void) ((wc search-files-window-controller) checkbox)
463  (with-slots (recursive-checkbox regex-checkbox case-sensitive-checkbox expand-results-checkbox
464               recursive-p regex-p case-sensitive-p expand-results-p) wc
465    (cond ((eql checkbox recursive-checkbox)
466           (setf recursive-p (not recursive-p)))
467          ((eql checkbox regex-checkbox)
468           (setf regex-p (not regex-p)))
469          ((eql checkbox case-sensitive-checkbox)
470           (setf case-sensitive-p (not case-sensitive-p)))
471          ((eql checkbox expand-results-checkbox)
472           (setf expand-results-p (not expand-results-p))
473           (if expand-results-p
474             (expand-all-results wc)
475             (collapse-all-results wc))
476           (#/reloadData (outline-view wc)))
477          (t
478           (error "Unknown checkbox ~s" checkbox)))))
479
480;;; For simple strings, it's easier to use the combo box's built-in
481;;; list than it is to mess around with a data source.
482
483(defun update-combo-box (combo-box string)
484  (check-type string ns:ns-string)
485  (unless (#/isEqualToString: string #@"")
486    (#/removeItemWithObjectValue: combo-box string)
487    (#/insertItemWithObjectValue:atIndex: combo-box string 0)
488    (when (> (#/numberOfItems combo-box) *search-files-history-limit*)
489      (#/removeItemAtIndex: combo-box *search-files-history-limit*))))
490
491(objc:defmethod (#/updateFindString: :void) ((wc search-files-window-controller)
492                                             sender)
493  (let ((value (#/stringValue sender)))
494    (setf (find-string-value wc) value)
495    (update-combo-box sender value)))
496
497(objc:defmethod (#/updateFolderString: :void) ((wc search-files-window-controller) sender)
498  (setf (folder-string-value wc) (#/stringValue sender))
499  (update-combo-box sender (folder-string-value wc)))
500
501(objc:defmethod (#/updateFileNameString: :void) ((wc search-files-window-controller) sender)
502  (setf (file-name-string-value wc) (#/stringValue sender))
503  (update-combo-box sender (file-name-string-value wc)))
504
505(objc:defmethod #/init ((self search-files-window-controller))
506  (prog1
507      (#/initWithWindowNibName: self #@"SearchFiles")
508    (#/setShouldCascadeWindows: self nil)))
509
510(defloadvar *search-files-cascade-point* (ns:make-ns-point 0 0))
511
512(objc:defmethod (#/windowDidLoad :void) ((wc search-files-window-controller))
513  ;; Cascade window from the top left point of the topmost search files window.
514  (flet ((good-window-p (w)
515           (and (not (eql w (#/window wc)))
516                (eql (#/class (#/windowController w))
517                     (find-class 'search-files-window-controller)))))
518    (let* ((dialogs (remove-if-not #'good-window-p (gui::windows)))
519           (top-dialog (car dialogs)))
520      (if top-dialog
521        (ns:with-ns-point (zp 0 0)
522          (setq *search-files-cascade-point*
523                (#/cascadeTopLeftFromPoint: top-dialog zp))))))
524  (#/cascadeTopLeftFromPoint: (#/window wc) *search-files-cascade-point*))
525
526(defun set-search-files-pattern (wc pattern)
527  (let ((string (#/autorelease (%make-nsstring pattern))))
528    (with-slots (find-combo-box) wc
529      (#/setStringValue: find-combo-box string)
530      (#/updateFindString: wc find-combo-box))))
531
532(defun set-search-files-dir (wc dir)
533  (let ((nsdir (#/autorelease (%make-nsstring dir))))
534    (with-slots (folder-combo-box) wc
535      (#/setStringValue: folder-combo-box nsdir)
536      (#/updateFolderString: wc folder-combo-box))))
537
538(defun set-search-files-default-dir (wc)
539  (let* ((w (first-window-satisfying-predicate #'window-pathname))
540         (path (and w (window-pathname w)))
541         (dir (if path
542                (namestring (ccl::back-translate-pathname (directory-namestring path)))
543                "ccl:")))
544    (set-search-files-dir wc dir)))
545
546(objc:defmethod (#/awakeFromNib :void) ((wc search-files-window-controller))
547  (#/setStringValue: (status-field wc) #@"")
548  (with-slots (outline-view search-data-source) wc
549    (#/setTarget: outline-view search-data-source)
550    (#/setDoubleAction: outline-view (@selector #/editLine:))
551    (setf search-data-source (#/new grep-results-data-source))
552    (#/setDelegate: outline-view search-data-source)
553    (#/setDataSource: outline-view search-data-source))
554  (setf (find-string-value wc) #@"")
555  (setf (folder-string-value wc) #@"")
556  (with-slots (file-name-combo-box) wc
557    (#/setStringValue: file-name-combo-box #@"*.lisp")
558    (#/updateFileNameString: wc file-name-combo-box)))
559
560(defun ns-string-equal (ns1 ns2)
561  (and (typep ns1 'ns:ns-string)
562       (typep ns2 'ns:ns-string)
563       (#/isEqualToString: ns1 ns2)))
564
565(defmethod get-full-dir-string ((str string))
566  ;make sure it has a trailing slash
567  (let* ((ret (ccl:native-translated-namestring str))
568         (len (length ret)))
569    (cond ((eql len 0) "./")
570          ((eql #\/ (char ret (1- len))) ret)
571          (t (concatenate 'string ret "/")))))
572
573
574;;; nil host is considered valid
575(defmethod valid-host-p ((ob t))
576  nil)
577
578(defmethod valid-host-p ((str string))
579  (let ((colon-pos (position #\: str)))
580    (or (not colon-pos)
581        (ccl::logical-host-p (subseq str 0 colon-pos)))))
582
583(defmethod valid-host-p ((p pathname))
584  (ccl::logical-host-p (pathname-host p)))
585
586(defmethod get-full-dir-string ((nsstring ns:ns-string))
587  (get-full-dir-string (lisp-string-from-nsstring nsstring)))
588
589(objc:defmethod (#/doSearch: :void) ((wc search-files-window-controller) sender)
590  (declare (ignore sender))
591  (set-results-string wc #@"Searching...")
592  (#/setEnabled: (search-button wc) nil)
593  (#/performSelectorOnMainThread:withObject:waitUntilDone:
594   (progress-indicator wc) (@selector #/stopAnimation:) nil t)
595  (process-run-function
596   'do-search
597   (lambda ()
598     (let ((result-status #@"Done"))
599       (#/performSelectorOnMainThread:withObject:waitUntilDone:
600        (progress-indicator wc) (@selector #/startAnimation:) nil t)
601       (unwind-protect
602            (let* ((pattern (lisp-string-from-nsstring (find-string-value wc)))
603                   (folder (get-full-dir-string (folder-string-value wc)))
604                   (file-pattern (lisp-string-from-nsstring (file-name-string-value wc)))
605                   (lines (run-search-files-grep folder file-pattern pattern
606                                                     :recursive (recursive-p wc)
607                                                     :case-sensitive (case-sensitive-p wc)
608                                                     :regex (regex-p wc)))
609                   (results (generate-grep-results lines))
610                   (tree-node (%tree-node-for-grep-results results)))
611              (setf result-status
612                    (if results
613                        (#/autorelease
614                         (%make-nsstring
615                          (format nil "~D line~:P matched in ~D file~:P"
616                                  (reduce #'+ results
617                                          :key #'grep-result-match-count)
618                                  (length results))))
619                        #@"No matches"))
620              (setf (new-results wc) tree-node))
621         (progn
622           (#/performSelectorOnMainThread:withObject:waitUntilDone:
623            wc
624            (@selector #/updateResults:)
625            +null-ptr+
626            t)
627           (set-results-string wc result-status)
628           (#/setTitle: (#/window wc)
629                        (#/autorelease
630                         (%make-nsstring (format nil "Search Files: ~a"
631                                                 (lisp-string-from-nsstring (find-string-value wc))))))
632           (#/performSelectorOnMainThread:withObject:waitUntilDone:
633            (progress-indicator wc) (@selector #/stopAnimation:) nil t)
634           (#/setEnabled: (search-button wc) t)))))))
635
636(objc:defmethod (#/windowWillClose: :void) ((wc search-files-window-controller)
637                                            notification)
638  (declare (ignore notification))
639  (let* ((proc (grep-process wc)))
640    (when proc (process-kill proc))))
641
642(objc:defmethod (#/updateResults: :void) ((wc search-files-window-controller)
643                                          sender)
644  (declare (ignore sender))
645  (with-slots (search-data-source outline-view new-results expand-results-p) wc
646    (#/setRootNode: search-data-source new-results)
647    (#/release new-results)
648    (#/reloadData outline-view)
649    (when expand-results-p
650      (expand-all-results wc))))
651
652(defmethod expand-all-results ((wc search-files-window-controller))
653  (with-slots (outline-view) wc
654    (#/expandItem:expandChildren: outline-view +null-ptr+ t)
655    (#/reloadData outline-view)))
656
657(defmethod collapse-all-results ((wc search-files-window-controller))
658  (with-slots (outline-view) wc
659    (#/collapseItem:collapseChildren: outline-view +null-ptr+ t)
660    (#/reloadData outline-view)))
661
662(defun set-results-string (wc str)
663  (#/setStringValue: (status-field wc) str))
664
665;;; For choosing the right directory
666(objc:defmethod (#/doBrowse: :void) ((wc search-files-window-controller) sender)
667  (declare (ignore sender))
668  (let ((pathname (cocoa-choose-directory-dialog)))
669    (when pathname
670      (ccl::with-autoreleased-nsstring
671          (dir (native-translated-namestring pathname))
672        (with-slots (folder-combo-box) wc
673          (#/setStringValue: folder-combo-box dir)
674          (#/updateFolderString: wc folder-combo-box))))))
675
676;;; For jumping to a search result
677(objc:defmethod (#/editLine: :void) ((wc search-files-window-controller) outline-view)
678  (let ((selected-row (#/selectedRow outline-view)))
679    (when (plusp selected-row)
680      (let* ((item (#/itemAtRow: outline-view selected-row))
681             (node-data (#/representedObject item))
682             (url (#/URL node-data))
683             (line-number (#/lineNumber node-data)))
684        (cocoa-edit-grep-line (%get-cfstring (#/path url))
685                              (1- line-number))))))
Note: See TracBrowser for help on using the repository browser.