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))) |
---|