source: trunk/ccl/cocoa-ide/cocoa-grep.lisp @ 7124

Last change on this file since 7124 was 7124, checked in by gb, 14 years ago

Tell grep not to complain about inaccesible files; it might return an
exit status of 2 if it finds such files, so treat that as "success" for
now (ticket:98).

File size: 4.4 KB
Line 
1; -*- Mode: Lisp; Package: CCL; -*-
2
3(in-package "CCL")
4
5(defvar *grep-program* "grep")
6
7(defclass cocoa-edit-grep-line-request (ns:ns-object)
8  ((file-id :foreign-type :int)
9   (line-num :foreign-type :int))
10  (:metaclass ns:+ns-object))
11
12(objc:defmethod #/initWithFile:line:
13                ((self cocoa-edit-grep-line-request) (file :int) (line :int))
14  (#/init self)
15  (setf (slot-value self 'file-id) file
16        (slot-value self 'line-num) line)
17  self)
18
19(objc:defmethod (#/editGrepLine: :void)
20    ((self hemlock-document-controller) request)
21  (let* ((file (id-map-free-object *edit-definition-id-map* (slot-value request 'file-id)))
22         (line-num (slot-value request 'line-num))
23         (namestring (native-translated-namestring file))
24         (url (#/initFileURLWithPath:
25               (#/alloc ns:ns-url)
26               (%make-nsstring namestring)))
27         (document (#/openDocumentWithContentsOfURL:display:error:
28                    self
29                    url
30                    nil
31                    +null-ptr+)))
32    (unless (%null-ptr-p document)
33      (when (= (#/count (#/windowControllers document)) 0)
34        (#/makeWindowControllers document))
35      (let* ((buffer (hemlock-document-buffer document))
36             (hi::*current-buffer* buffer)
37             (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
38        (edit-grep-line-in-buffer line-num))
39      (#/updateHemlockSelection (slot-value document 'textstorage))
40      (#/showWindows document))))
41
42(defun edit-grep-line-in-buffer (line-num)
43  (let ((point (hi::current-point-collapsing-selection)))
44    (hi::buffer-start point)
45    (unless (hi::line-offset point line-num)
46      (hi::buffer-end point))))
47
48(defun request-edit-grep-line (line)
49  (let* ((pos1 (position #\: line))
50         (pos2 (and pos1 (position #\: line :start (1+ pos1))))
51         (num (and pos2 (ignore-errors
52                         (parse-integer line :start (1+ pos1) :end pos2
53                                        :junk-allowed nil))))
54         (file (and num (subseq line 0 pos1))))
55    (when file
56      (let* ((request (make-instance 'cocoa-edit-grep-line-request
57                                     :with-file (assign-id-map-id *edit-definition-id-map* file)
58                                     :line num)))
59        (#/performSelectorOnMainThread:withObject:waitUntilDone:
60         (#/sharedDocumentController ns:ns-document-controller)
61         (@selector #/editGrepLine:)
62         request
63         t)))))
64
65(defun split-grep-lines (output)
66  (loop with end = (length output)
67    for start = 0 then (1+ pos)
68    as pos = (or (position #\Newline output :start start :end end) end)
69    when (< start pos) collect (subseq output start pos)
70    while (< pos end)))
71
72(defun grep (pattern directory &key ignore-case (include "*.lisp") (exclude "*~.lisp"))
73  (with-output-to-string (stream)
74    (let* ((proc (run-program *grep-program*
75                              (nconc (and include (list "--include" include))
76                                     (and exclude (list "--exclude" exclude))
77                                     (and ignore-case (list "--ignore-case"))
78                                     (list "--recursive"
79                                           "--with-filename"
80                                           "--line-number"
81                                           "--no-messages"
82                                           "-e" pattern
83                                           (native-untranslated-namestring directory)))
84                              :input nil
85                              :output stream)))
86      (multiple-value-bind (status exit-code) (external-process-status proc)
87        (let ((output (get-output-stream-string stream)))
88          (if (and (eq :exited status) (or (= exit-code 0) (= exit-code 2)))
89              (make-instance 'sequence-window-controller
90                             :sequence (split-grep-lines output)
91                             :result-callback #'request-edit-grep-line
92                             :display #'princ
93                             :title (format nil "~a in ~a" pattern directory))
94              (hi:editor-error "Error in grep status ~s code ~s: ~a" status exit-code output)))))))
95
96
97(hi:defhvar "Grep Directory"
98  "The directory searched by \"Grep\".  NIL means to use the directory of the buffer."
99  :value nil)
100
101(hi:defcommand "Grep" (p)
102  "Prompts for a pattern and invokes grep, searching recursively through .lisp
103   files in \"Grep Directory\".
104   With an argument, prompts for a directory to search, and sets \"Grep Directory\"
105   for the next time."
106  ""
107  (let* ((default (make-pathname :name :unspecific
108                                 :type :unspecific
109                                 :defaults (or (hi:value hemlock::grep-directory)
110                                               (hi:buffer-pathname hi::*current-buffer*)
111                                               "ccl:")))
112         (directory (if p
113                        (setf (hi:value hemlock::grep-directory)
114                              (hi:prompt-for-file :must-exist t
115                                                  :default default
116                                                  :default-string (namestring default)
117                                                  :prompt "Directory: "))
118                        default))
119         (pattern (hi:prompt-for-string
120                   :prompt "Pattern: "
121                   :help "Pattern to search for")))
122    (grep pattern directory)))
Note: See TracBrowser for help on using the repository browser.