source: trunk/ccl/examples/cocoa-listener.lisp @ 866

Last change on this file since 866 was 866, checked in by gb, 17 years ago

Use (THE ...) to help the bridge resolve some messages.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.4 KB
Line 
1;;-*- Mode: LISP; Package: CCL -*-
2
3(in-package "CCL")
4
5(eval-when (:compile-toplevel :load-toplevel :execute)
6  (require "COCOA-EDITOR")
7  (require "PTY"))
8
9(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters")
10(def-cocoa-default *listener-columns* :int 80 "Initial height of listener windows, in characters")
11
12(def-cocoa-default hi::*listener-output-style* :int 0 "Text style index for listener output")
13
14(def-cocoa-default hi::*listener-input-style* :int 1 "Text style index for listener output")
15
16(def-cocoa-default *listener-background-red-component* :float 0.90f0 "Red component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
17(def-cocoa-default *listener-background-green-component* :float 0.90f0 "Green component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
18(def-cocoa-default *listener-background-blue-component* :float 0.90f0 "Blue component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
19(def-cocoa-default *listener-background-alpha-component* :float 1.0f0 "Red component of editor background color.  Should be a float between 0.0 and 1.0, inclusive.")
20
21;;; Setup the server end of a pty pair.
22(defun setup-server-pty (pty)
23  pty)
24
25;;; Setup the client end of a pty pair.
26(defun setup-client-pty (pty)
27  ;; Since the same (Unix) process will be reading from and writing
28  ;; to the pty, it's critical that we make the pty non-blocking.
29  (fd-set-flag pty #$O_NONBLOCK)
30  (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG))
31  pty)
32
33
34(defloadvar *cocoa-listener-count* 0)
35
36(defclass cocoa-listener-process (process)
37    ((input-stream :reader cocoa-listener-process-input-stream)
38     (backtrace-contexts :initform nil
39                         :accessor cocoa-listener-process-backtrace-contexts)))
40 
41
42(defun new-cocoa-listener-process (procname input-fd output-fd peer-fd)
43  (let* ((input-stream (make-selection-input-stream
44                        input-fd
45                        :peer-fd peer-fd
46                        :elements-per-buffer (#_fpathconf
47                                              input-fd
48                                              #$_PC_MAX_INPUT)))
49         (proc
50          (make-mcl-listener-process 
51           procname
52           input-stream
53           (make-fd-stream output-fd :direction :output
54                           :elements-per-buffer
55                           (#_fpathconf
56                            output-fd
57                            #$_PC_MAX_INPUT))
58           #'(lambda ()`
59               (let* ((buf (find *current-process* hi:*buffer-list*
60                                 :key #'hi::buffer-process))
61                      (doc (if buf (hi::buffer-document buf))))
62                 (when doc
63                   (setf (hi::buffer-process buf) nil)
64                   (send doc
65                         :perform-selector-on-main-thread (@selector "close")
66                         :with-object (%null-ptr)
67                         :wait-until-done nil))))
68           :initial-function
69           #'(lambda ()
70               (setq *listener-autorelease-pool* (create-autorelease-pool))
71               (listener-function))
72           :class 'cocoa-listener-process)))
73    (setf (slot-value proc 'input-stream) input-stream)
74    proc))
75         
76
77
78
79(defclass hemlock-listener-window-controller (hemlock-editor-window-controller)
80    ((filehandle :foreign-type :id)     ;Filehandle for I/O
81     (clientfd :foreign-type :int)      ;Client (listener)'s side of pty
82     )
83  (:metaclass ns:+ns-object)
84  )
85
86(define-objc-method ((:id :init-with-window w)
87                     hemlock-listener-window-controller)
88  (let* ((self (send-super :init-with-window w)))
89    (unless (%null-ptr-p self)
90      (multiple-value-bind (server client) (ignore-errors (open-pty-pair))
91        (when server
92          (let* ((fh (make-objc-instance
93                      'ns-file-handle
94                      :with-file-descriptor (setup-server-pty server)
95                      :close-on-dealloc t)))
96            (setf (slot-value self 'filehandle) fh)
97            (setf (slot-value self 'clientfd) (setup-client-pty client))
98            (send (send (@class ns-notification-center) 'default-center)
99                  :add-observer self
100                  :selector (@selector "gotData:")
101                  :name #?NSFileHandleReadCompletionNotification
102                  :object fh)
103            (send fh 'read-in-background-and-notify)))))
104    self))
105
106(define-objc-method ((:void :got-data notification)
107                     hemlock-listener-window-controller)
108  (with-slots (filehandle) self
109    (let* ((data (send (send notification 'user-info)
110                       :object-for-key #?NSFileHandleNotificationDataItem))
111           (document (send self 'document))
112           (data-length (send (the ns:ns-data data) 'length))
113           (buffer (hemlock-document-buffer document))
114           (string (make-string data-length))
115           (fh filehandle))
116      (%copy-ptr-to-ivector (send data 'bytes) 0 string 0 data-length)
117      (enqueue-buffer-operation
118       buffer
119       #'(lambda ()
120           (hemlock::append-buffer-output buffer string)))
121      (send fh 'read-in-background-and-notify))))
122             
123
124
125(define-objc-method ((:void dealloc) hemlock-listener-window-controller)
126  (send (send (@class ns-notification-center) 'default-center)
127        :remove-observer self)
128  (send-super 'dealloc))
129
130
131
132;;; The HemlockListenerDocument class.
133
134
135(defclass hemlock-listener-document (hemlock-editor-document)
136    ()
137  (:metaclass ns:+ns-object))
138
139(defmethod textview-background-color ((doc hemlock-listener-document))
140  (send (find-class 'ns:ns-color)
141        :color-with-calibrated-red *listener-background-red-component*
142        :green *listener-background-green-component*
143        :blue *listener-background-blue-component*
144        :alpha *listener-background-alpha-component*))
145
146
147(defun hemlock::listener-document-send-string (document string)
148  (let* ((controller (send (send document 'window-controllers)
149                          :object-at-index 0))
150         (filehandle (slot-value controller 'filehandle))
151         (len (length string))
152         (data (send (make-objc-instance 'ns-mutable-data
153                                         :with-length len) 'autorelease))
154         (bytes (send data 'mutable-bytes)))
155    (%copy-ivector-to-ptr string 0 bytes 0 len)
156    (send filehandle :write-data data)
157    (send filehandle 'synchronize-file)))
158
159
160(define-objc-class-method ((:id top-listener) hemlock-listener-document)
161  (let* ((all-documents (send *NSApp* 'ordered-Documents)))
162    (dotimes (i (send all-documents 'count) (%null-ptr))
163      (let* ((doc (send all-documents :object-at-index i)))
164        (when (eql (send doc 'class) self)
165          (return doc))))))
166
167(defun symbol-value-in-top-listener-process (symbol)
168  (let* ((listenerdoc (send (@class hemlock-listener-document) 'top-listener))
169         (buffer (unless (%null-ptr-p listenerdoc)
170                   (hemlock-document-buffer listenerdoc)))
171         (process (if buffer (hi::buffer-process buffer))))
172     (if process
173       (ignore-errors (symbol-value-in-process symbol process))
174       (values nil t))))
175 
176
177
178(define-objc-method ((:<BOOL> is-document-edited) hemlock-listener-document)
179  nil)
180
181
182(define-objc-method ((:id init)
183                     hemlock-listener-document)
184  (let* ((doc (send-super 'init)))
185    (unless (%null-ptr-p doc)
186      (let* ((listener-name (if (eql 1 (incf *cocoa-listener-count*))
187                            "Listener"
188                            (format nil
189                                    "Listener-~d" *cocoa-listener-count*)))
190             (buffer (hemlock-document-buffer doc)))
191        (send doc :set-file-name  (%make-nsstring listener-name))
192        (setf (hi::buffer-pathname buffer) nil
193              (hi::buffer-minor-mode buffer "Listener") t
194              (hi::buffer-name buffer) listener-name)
195        (hi::sub-set-buffer-modeline-fields buffer hemlock::*listener-modeline-fields*)))
196    doc))
197
198(def-cocoa-default *initial-listener-x-pos* :float 400.0f0 "X position of upper-left corner of initial listener")
199
200(def-cocoa-default *initial-listener-y-pos* :float 400.0f0 "Y position of upper-left corner of initial listener")
201
202(defloadvar *next-listener-x-pos* nil) ; set after defaults initialized
203(defloadvar *next-listener-y-pos* nil) ; likewise
204
205(define-objc-method ((:void make-window-controllers) hemlock-listener-document)
206  (let* ((textstorage (slot-value self 'textstorage))
207         (window (%hemlock-frame-for-textstorage
208                                    textstorage
209                                    *listener-columns*
210                                    *listener-rows*
211                                    t
212                                    (textview-background-color self)))
213         (controller (make-objc-instance
214                      'hemlock-listener-window-controller
215                      :with-window window))
216         (listener-name (hi::buffer-name (hemlock-document-buffer self))))
217    (send self :add-window-controller controller)
218    (send controller 'release)
219    (slet ((current-point (ns-make-point (or *next-listener-x-pos*
220                                             *initial-listener-x-pos*)
221                                         (or *next-listener-y-pos*
222                                             *initial-listener-y-pos*))))
223      (slet ((new-point (send window
224                              :cascade-top-left-from-point current-point)))
225        (setf *next-listener-x-pos* (pref new-point :<NSP>oint.x)
226              *next-listener-y-pos* (pref new-point :<NSP>oint.y))))
227    (setf (hi::buffer-process (hemlock-document-buffer self))
228          (let* ((tty (slot-value controller 'clientfd))
229                 (peer-tty (send (slot-value controller 'filehandle)
230                                 'file-descriptor)))
231            (new-cocoa-listener-process listener-name tty tty peer-tty)))
232    controller))
233
234;;; Action methods
235(define-objc-method ((:void :interrupt sender) hemlock-listener-document)
236  (declare (ignore sender))
237  (let* ((buffer (hemlock-document-buffer self))
238         (process (if buffer (hi::buffer-process buffer))))
239    (when (typep process 'cocoa-listener-process)
240      (ccl::force-break-in-listener process))))
241
242(defmethod listener-backtrace-context ((proc cocoa-listener-process))
243  (car (cocoa-listener-process-backtrace-contexts proc)))
244
245(define-objc-method ((:void :backtrace sender) hemlock-listener-document)
246  (declare (ignore sender))
247  (let* ((buffer (hemlock-document-buffer self))
248         (process (if buffer (hi::buffer-process buffer))))
249    (when (typep process 'cocoa-listener-process)
250      (let* ((context (listener-backtrace-context process)))
251        (when context
252          (send (backtrace-controller-for-context context)
253                :show-window (%null-ptr)))))))
254
255;;; Menu item action validation.  It'd be nice if we could distribute this a
256;;; bit better, so that this method didn't have to change whenever a new
257;;; action was implemented in this class.  For now, we have to do so.
258
259(defmethod document-validate-menu-item ((doc hemlock-listener-document) item)
260  ;; Return two values: the first is true if the second is definitive.
261  ;; So far, all actions demand that there be an underlying process, so
262  ;; check for that first.
263  (let* ((buffer (hemlock-document-buffer doc))
264         (process (if buffer (hi::buffer-process buffer))))
265    (if (typep process 'cocoa-listener-process)
266      (let* ((action (send item 'action)))
267        (cond
268          ((eql action (@selector "interrupt:")) (values t t))
269          ((eql action (@selector "backtrace:"))
270           (values t
271                   (not (null (listener-backtrace-context process)))))))
272      (values nil nil))))
273
274(define-objc-method ((:<BOOL> :validate-menu-item item)
275                     hemlock-listener-document)
276  (multiple-value-bind (have-opinion opinion)
277      (document-validate-menu-item self item)
278    (if have-opinion
279      opinion
280      (send-super :validate-menu-item item))))
281
282(defun shortest-package-name (package)
283  (let* ((name (package-name package))
284         (len (length name)))
285    (dolist (nick (package-nicknames package) name)
286      (let* ((nicklen (length nick)))
287        (if (< nicklen len)
288          (setq name nick len nicklen))))))
289
290(defmethod ui-object-note-package ((app ns:ns-application) package)
291  (with-autorelease-pool
292      (process-interrupt *cocoa-event-process*
293                         #'(lambda (proc name)
294                             (dolist (buf hi::*buffer-list*)
295                               (when (eq proc (hi::buffer-process buf))
296                                 (setf (hi::variable-value 'hemlock::current-package :buffer buf) name))))
297                         *current-process*
298                         (shortest-package-name package))))
299
300(defmethod hi::send-string-to-listener-process ((process cocoa-listener-process)
301                                                string &key path package)
302  (let* ((selection (make-input-selection :package package
303                                          :source-file path
304                                          :string-stream
305                                          (make-string-input-stream string))))
306    (enqueue-input-selection (cocoa-listener-process-input-stream process) selection)))
307
308
309(defun hemlock::evaluate-input-selection (selection)
310  (application-ui-operation *application* :eval-selection selection))
311                           
312(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application)
313                                                    selection)
314  (declare (ignore selection))
315  (let* ((top-listener-document (send (find-class 'hemlock-listener-document)
316                                      'top-listener)))
317    (if top-listener-document
318      (let* ((buffer (hemlock-document-buffer top-listener-document)))
319        (if buffer
320          (let* ((proc (hi::buffer-process buffer)))
321            (if (typep proc 'cocoa-listener-process)
322              proc)))))))
323
324(defmethod ui-object-eval-selection ((app ns:ns-application)
325                                     selection)
326  (let* ((target-listener (ui-object-choose-listener-for-selection
327                           app selection)))
328    (if (typep target-listener 'cocoa-listener-process)
329      (enqueue-input-selection (cocoa-listener-process-input-stream
330                                target-listener)
331                               selection))))
332 
333
334
335
336
337       
338 
Note: See TracBrowser for help on using the repository browser.