Index: /trunk/source/cocoa-ide/console-window.lisp
===================================================================
--- /trunk/source/cocoa-ide/console-window.lisp	(revision 8457)
+++ /trunk/source/cocoa-ide/console-window.lisp	(revision 8457)
@@ -0,0 +1,150 @@
+;;;-*-Mode: LISP; Package: GUI -*-
+;;;
+;;;   Copyright (C) 2008 Clozure Associates
+
+(in-package "GUI")
+
+
+(defclass console-window (typeout-window)
+  ((syslog-in :foreign-type :id :accessor syslog-in)
+   (syslog-out :foreign-type :id :accessor syslog-out)
+   (nextra :foreign-type :int)
+   (translatebuf :foreign-type :address)
+   (bufsize :foreign-type :int))
+  (:metaclass ns:+ns-object))
+
+
+;;; Insert/append a string to the console-window's text view,
+;;; activating the window if necessary.
+
+(objc:defmethod (#/insertString: :void) ((self console-window) string)
+  (with-slots ((tv typeout-view)) self
+    (#/makeKeyAndOrderFront: self +null-ptr+)
+    (#/insertString: (typeout-view-text-view tv) string)))    
+
+
+;;; Process a chunkful of data
+(objc:defmethod (#/processData: :void) ((self console-window) data)
+  (with-slots (syslog-in syslog-out nextra translatebuf bufsize) self
+    (let* ((encoding (load-time-value (get-character-encoding :utf-8)))
+	   (data-length (#/length data))
+           (n nextra)
+           (cursize bufsize)
+           (need (+ n data-length))
+           (xlate translatebuf))
+      (#/writeData: syslog-out data)
+      (when (> need cursize)
+        (let* ((new (#_malloc need)))
+          (dotimes (i n) (setf (%get-unsigned-byte new i)
+                               (%get-unsigned-byte xlate i)))
+          (#_free xlate)
+          (setq xlate new translatebuf new bufsize need)))
+      #+debug (#_NSLog #@"got %d bytes of data" :int data-length)
+      (with-macptrs ((target (%inc-ptr xlate n)))
+        (#/getBytes:range: data target (ns:make-ns-range 0 data-length)))
+      (let* ((total (+ n data-length))
+             (noctets-used (nth-value 1
+                                      (funcall (ccl::character-encoding-length-of-memory-encoding-function encoding)
+                                               xlate
+                                               total
+                                               0)))
+             (string (make-instance ns:ns-string
+                                    :with-bytes xlate
+                                    :length noctets-used
+                                    :encoding #$NSUTF8StringEncoding)))
+         (unless (zerop (setq n (- total noctets-used)))
+              ;; By definition, the number of untranslated octets
+              ;; can't be more than 3.
+              (dotimes (i n)
+                (setf (%get-unsigned-byte xlate i)
+                      (%get-unsigned-byte xlate (+ noctets-used i)))))
+            (setq nextra n)
+            (#/insertString: self string)))))
+
+;;; We want to be able to capture and display process-level
+;;; output to file descriptors 1 and 2, including messages
+;;; logged via #_NSLog/#_CFLog and variants.  Logging messages
+;;; may only be echoed to fd 2 if that fd is open to a file
+;;; (rather than to a socket/pty/pipe/...).  Unless/until
+;;; the the file has data written to it, reading from
+;;; it will return EOF, and waiting via mechanisms like
+;;; #_poll/#_select/#/readInBackgroundAndNotify will indicate
+;;; that the file can be read without blocking.  True, but
+;;; we'd rather not see it as being constantly at EOF ...
+;;; So, we have a timer-driven method wake up every second
+;;; or so, and see if there's actually any unread data
+;;; to process.
+
+(objc:defmethod (#/checkForData: :void) ((self console-window) timer)
+  (declare (ignorable timer))
+  (let* ((in (syslog-in self)))
+    (loop
+      (let* ((data (#/availableData in))
+             (n (#/length data)))
+        (declare (fixnum n))
+        (if (zerop n)
+          (return)
+          (#/processData: self data))))))
+
+;;; Open file descriptor to a temporary file.  The write-fd will be
+;;; open for reading and writing and the file will have mode #o600
+;;; (readable/ writable by owner, not accessible to others.)  Unlink
+;;; the file as soon as it's opened, to help exposing its contents
+;;; (and to ensure that the file gets deleted when the application
+;;; quits.)
+(defun open-logging-fds ()
+  (with-cstrs ((template "/tmp/logfileXXXXXX"))
+    (let* ((write-fd (#_mkstemp template)))
+      (when (>= write-fd 0)
+        (let* ((read-fd (#_open template #$O_RDONLY)))
+          (#_unlink template)
+          (values write-fd read-fd))))))
+
+
+
+(objc:defmethod #/redirectStandardOutput ((self console-window))
+  (with-slots (syslog-out syslog-in) self
+    (multiple-value-bind (write-fd read-fd) (open-logging-fds)
+      (when write-fd
+        (setq syslog-out
+              (make-instance 'ns:ns-file-handle :with-file-descriptor (#_dup 1)
+                             :close-on-dealloc t))
+        (let* ((log-fh (make-instance 'ns:ns-file-handle
+                                      :with-file-descriptor read-fd
+                                      :close-on-dealloc t)))
+          (setq syslog-in log-fh)
+          (let* ((bufsize #$BUFSIZ)
+                 (buffer (#_malloc bufsize)))
+            (setf (slot-value self 'translatebuf) buffer
+                  (slot-value self 'bufsize) bufsize
+                  (slot-value self 'nextra) 0))
+          (#_dup2 write-fd 1)
+          (#_dup2 write-fd 2)
+          (#/scheduledTimerWithTimeInterval:target:selector:userInfo:repeats:
+           ns:ns-timer
+           1.0d0
+           self
+           (@selector #/checkForData:)
+           +null-ptr+
+           t)))))
+  self)
+
+(objc:defmethod #/init ((self console-window))
+  (#/release self)
+  (flet ((path-inode (path)
+           (nth-value 4 (ccl::%stat path)))
+         (fd-inode (fd)
+           (nth-value 4 (ccl::%fstat fd))))
+    (cond ((and (eql (fd-inode 0) (path-inode "/dev/null"))
+                (eql (fd-inode 1) (fd-inode 2)))
+           (let* ((win (#/typeoutWindowWithTitle: (find-class 'console-window) #@"Console")))
+             (#/redirectStandardOutput win)
+             (let* ((tv (typeout-view-text-view (typeout-window-typeout-view win))))
+               (#/setTypingAttributes: tv
+                                       (create-text-attributes
+                                        :font (default-font :name "Monaco" :size 10)
+                                        :color (#/redColor ns:ns-color))))
+             (#/setFrameOrigin: win (ns:make-ns-point 20 20))
+             win))
+          (t +null-ptr+))))
+