Changeset 6672
- Timestamp:
- Jun 3, 2007, 3:09:41 AM (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/ide-1.0/ccl/examples/cocoa-listener.lisp
r6621 r6672 21 21 ;;; Setup the server end of a pty pair. 22 22 (defun setup-server-pty (pty) 23 (set-tty-raw pty) 23 24 pty) 24 25 … … 29 30 ;; Has this been true for the last few years (native threads) ? 30 31 ;(fd-set-flag pty #$O_NONBLOCK) 32 (set-tty-raw pty) 33 #+no 31 34 (disable-tty-local-modes pty (logior #$ECHO #$ECHOCTL #$ISIG)) 35 #+no 32 36 (disable-tty-output-modes pty #$ONLCR) 33 37 pty) … … 38 42 (defclass cocoa-listener-process (process) 39 43 ((input-stream :reader cocoa-listener-process-input-stream) 44 (output-stream :reader cocoa-listener-process-output-stream) 40 45 (backtrace-contexts :initform nil 41 :accessor cocoa-listener-process-backtrace-contexts))) 46 :accessor cocoa-listener-process-backtrace-contexts) 47 (window :reader cocoa-listener-process-window) 48 (buffer :initform nil :reader cocoa-listener-process-buffer))) 42 49 43 50 44 (defun new-cocoa-listener-process (procname input-fd output-fd peer-fd )51 (defun new-cocoa-listener-process (procname input-fd output-fd peer-fd window buffer) 45 52 (let* ((input-stream (make-selection-input-stream 46 53 input-fd … … 48 55 :elements-per-buffer (#_fpathconf 49 56 input-fd 50 #$_PC_MAX_INPUT))) 57 #$_PC_MAX_INPUT) 58 :encoding :utf-8)) 59 (output-stream (make-fd-stream output-fd :direction :output 60 :sharing :lock 61 :elements-per-buffer 62 (#_fpathconf 63 output-fd 64 #$_PC_MAX_INPUT) 65 :encoding :utf-8)) 51 66 (proc 52 67 (make-mcl-listener-process 53 68 procname 54 69 input-stream 55 (make-fd-stream output-fd :direction :output 56 :sharing :lock 57 :elements-per-buffer 58 (#_fpathconf 59 output-fd 60 #$_PC_MAX_INPUT)) 70 output-stream 61 71 #'(lambda ()` 62 72 (let* ((buf (find *current-process* hi:*buffer-list* … … 76 86 :class 'cocoa-listener-process))) 77 87 (setf (slot-value proc 'input-stream) input-stream) 88 (setf (slot-value proc 'output-stream) output-stream) 89 (setf (slot-value proc 'window) window) 90 (setf (slot-value proc 'buffer) buffer) 78 91 proc)) 79 92 … … 84 97 ((filehandle :foreign-type :id) ;Filehandle for I/O 85 98 (clientfd :foreign-type :int) ;Client (listener)'s side of pty 99 (nextra :foreign-type :int) ;count of untranslated bytes remaining 100 (translatebuf :foreign-type :address) ;buffer for utf8 translation 101 (bufsize :foreign-type :int) ;size of translatebuf 86 102 ) 87 103 (:metaclass ns:+ns-object) … … 107 123 (setf (slot-value new 'filehandle) fh) 108 124 (setf (slot-value new 'clientfd) (setup-client-pty client)) 125 (let* ((bufsize #$BUFSIZ) 126 (buffer (#_malloc bufsize))) 127 (setf (slot-value new 'translatebuf) buffer 128 (slot-value new 'bufsize) bufsize 129 (slot-value new 'nextra) 0)) 109 130 (#/addObserver:selector:name:object: 110 131 (#/defaultCenter ns:ns-notification-center) … … 118 139 (objc:defmethod (#/gotData: :void) ((self hemlock-listener-window-controller) 119 140 notification) 120 #+debug (#_NSLog #@"gotData: !") 121 (with-slots (filehandle) self 141 (with-slots (filehandle nextra translatebuf bufsize) self 122 142 (let* ((data (#/objectForKey: (#/userInfo notification) 123 143 #&NSFileHandleNotificationDataItem)) 124 144 (document (#/document self)) 145 (encoding (load-time-value (get-character-encoding :utf-8))) 125 146 (data-length (#/length data)) 126 147 (buffer (hemlock-document-buffer document)) 127 (string (%str-from-ptr (#/bytes data) data-length)) 148 (n nextra) 149 (cursize bufsize) 150 (need (+ n data-length)) 151 (xlate translatebuf) 128 152 (fh filehandle)) 129 (enqueue-buffer-operation 130 buffer 131 #'(lambda () 132 (hemlock::append-buffer-output buffer string))) 133 (#/readInBackgroundAndNotify fh)))) 153 (when (> need cursize) 154 (let* ((new (#_malloc need))) 155 (dotimes (i n) (setf (%get-unsigned-byte new i) 156 (%get-unsigned-byte xlate i))) 157 (#_free xlate) 158 (setq xlate new translatebuf new bufsize need))) 159 #+debug (#_NSLog #@"got %d bytes of data" :int data-length) 160 (with-macptrs ((target (%inc-ptr xlate n))) 161 (#/getBytes:range: data target (ns:make-ns-range 0 data-length))) 162 (let* ((total (+ n data-length))) 163 (multiple-value-bind (nchars noctets-used) 164 (funcall (character-encoding-length-of-memory-encoding-function encoding) 165 xlate 166 total 167 0) 168 (let* ((string (make-string nchars))) 169 (funcall (character-encoding-memory-decode-function encoding) 170 xlate 171 noctets-used 172 0 173 string) 174 (unless (zerop (setq n (- total noctets-used))) 175 ;; By definition, the number of untranslated octets 176 ;; can't be more than 3. 177 (dotimes (i n) 178 (setf (%get-unsigned-byte xlate i) 179 (%get-unsigned-byte xlate (+ noctets-used i))))) 180 (setq nextra n) 181 (hi::enqueue-buffer-operation 182 buffer 183 #'(lambda () 184 (unwind-protect 185 (progn 186 (hi::buffer-document-begin-editing buffer) 187 (hemlock::append-buffer-output buffer string)) 188 (hi::buffer-document-end-editing buffer)))) 189 (#/readInBackgroundAndNotify fh))))))) 134 190 135 191 … … 171 227 (objc:defmethod #/topListener ((self +hemlock-listener-document)) 172 228 (let* ((all-documents (#/orderedDocuments *NSApp*))) 173 (dotimes (i (#/count all-documents) (%null-ptr))229 (dotimes (i (#/count all-documents) +null-ptr+) 174 230 (let* ((doc (#/objectAtIndex: all-documents i))) 175 231 (when (eql (#/class doc) self) … … 185 241 (values nil t)))) 186 242 243 (defun hi::top-listener-output-stream () 244 (let* ((doc (#/topListener hemlock-listener-document))) 245 (unless (%null-ptr-p doc) 246 (let* ((buffer (hemlock-document-buffer doc)) 247 (process (if buffer (hi::buffer-process buffer)))) 248 (when (typep process 'cocoa-listener-process) 249 (cocoa-listener-process-output-stream process)))))) 250 187 251 188 252 … … 242 306 (let* ((tty (slot-value controller 'clientfd)) 243 307 (peer-tty (#/fileDescriptor (slot-value controller 'filehandle)))) 244 (new-cocoa-listener-process listener-name tty tty peer-tty )))308 (new-cocoa-listener-process listener-name tty tty peer-tty window (hemlock-document-buffer self)))) 245 309 controller)) 246 310 … … 264 328 (when context 265 329 (#/showWindow: (backtrace-controller-for-context context) +null-ptr+)))))) 330 331 (objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender) 332 (declare (ignore sender)) 333 (let* ((buffer (hemlock-document-buffer self)) 334 (process (if buffer (hi::buffer-process buffer)))) 335 (when (typep process 'cocoa-listener-process) 336 (let* ((context (listener-backtrace-context process))) 337 (when context 338 (hi::send-string-to-listener-process process ":go 339 ")))))) 340 341 266 342 267 343 ;;; Menu item action validation. It'd be nice if we could distribute this a … … 312 388 (shortest-package-name package)))) 313 389 390 ;;; This is basically used to provide INPUT to the listener process, by 391 ;;; writing to an fd which is conntected to that process's standard 392 ;;; input. 314 393 (defmethod hi::send-string-to-listener-process ((process cocoa-listener-process) 315 394 string &key path package) 316 (let* ((selection (make-input-selection :package package 317 :source-file path 318 :string-stream 319 (make-string-input-stream string)))) 320 (enqueue-input-selection (cocoa-listener-process-input-stream process) selection))) 395 (let* ((fd (selection-input-stream-peer-fd (cocoa-listener-process-input-stream process)))) 396 (%stack-block ((buf 512)) 397 (let* ((nout 0)) 398 (labels ((flush () 399 (when (> nout 0) 400 (fd-write fd buf nout) 401 (setq nout 0))) 402 (out-raw-char (ch) 403 (when (= nout 512) 404 (flush)) 405 (let* ((code (char-code ch))) 406 (if (> code 255) 407 (setq code (char-code #\Sub))) 408 (setf (%get-unsigned-byte buf nout) code) 409 (incf nout))) 410 (out-ch (ch) 411 (when (or (eql ch #\^v) 412 (eql ch #\^p) 413 (eql ch #\newline) 414 (eql ch #\^q)) 415 (out-raw-char #\^q)) 416 (out-raw-char ch)) 417 (out-string (s) 418 (dotimes (i (length s)) 419 (out-ch (char s i))))) 420 (out-raw-char #\^p) 421 (when package (out-string package)) 422 (out-raw-char #\newline) 423 (out-raw-char #\^v) 424 (when path (out-string path)) 425 (out-raw-char #\newline) 426 (out-string string) 427 (flush)))))) 321 428 322 429 … … 340 447 app selection))) 341 448 (if (typep target-listener 'cocoa-listener-process) 342 (enqueue-input-selection (cocoa-listener-process-input-stream 343 target-listener) 344 selection)))) 449 (destructuring-bind (package path string) selection 450 (hi::send-string-to-listener-process target-listener string :package package :path path))))) 345 451 346 452
Note:
See TracChangeset
for help on using the changeset viewer.
