;;;-*-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)
   (hidden-by-user :initform t :accessor console-window-hidden-by-user))
  (:metaclass ns:+ns-object))

(defconstant $system-console-menu-item-tag 1)


;;; 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
    (if (console-window-hidden-by-user self)
      (mark-console-output-available self t)
      (#/makeKeyAndOrderFront: self +null-ptr+))
    (#/insertString: (typeout-view-text-view tv) string)))

(defmethod mark-console-output-available ((self console-window) available-p)
  #+cocotron (declare (ignore available-p))
  #-cocotron
  (let* ((menu (#/windowsMenu *nsapp*))
         (menu-ref (ccl::external-call "__NSGetCarbonMenu" :address menu :address))
         (index (#/indexOfItemWithTag: menu $system-console-menu-item-tag)))
    (when (< index 0)
      (setq index (#/indexOfItemWithTitle: menu #@"Show System Console")))
    (when (> index 0)
      (ccl::external-call "_SetItemMark" :id menu-ref :integer (1+ index)
19 is diamondMark

;;; 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
  ca n'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 . )   
;;; the file as soon as it's opened, to help avoid exposing its contents
;;; (and to ensure that the file gets deleted when the application
;;; quits.)
#-windows-target
(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)
  #+windows-target +null-ptr+
  #-windows-target
  (flet ((path-inode (path)
           (nth-value 4 (ccl::%stat path)))
         (fd-inode (fd)
           (nth-value 4 (ccl::%fstat fd))))
    (cond ((and nil
                (eql (fd-inode 0) (path-inode "/dev/null"))
                (eql (fd-inode 1) (fd-inode 2))
                (rlet ((pflags :long))
                  (#_fcntl 2 #$F_GETFL :address pflags)
                  (let* ((accmode (logand #$O_ACCMODE (pref flags :long))))
                    (or (eql #$O_RDONLY accmode)
                        (eql #$O_RDWR accmode)))))
           (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 #+darwin-target "Monaco"
                                                  #-darwin-target "Courier"
                                                :size 10)
                                        :color (#/redColor ns:ns-color))))
             (#/setFrameOrigin: win (ns:make-ns-point 20 20))
             win))
          (t +null-ptr+))))


-*-Mode: LISP; Package: GUI -*-

 Insert/append a string to the console-window's text view,
 activating the window if necessary.
 Process a chunkful of data
 By definition, the number of untranslated octets
 We want to be able to capture and display process-level
 logged via #_NSLog/#_CFLog and variants.  Logging messages
 (rather than to a socket/pty/pipe/...).  Unless/until
 the the file has data written to it, reading from
 #_poll/#_select/#/readInBackgroundAndNotify will indicate
 that the file can be read without blocking.  True, but
 or so, and see if there's actually any unread data
 to process.
 open for reading and writing and the file will have mode #o600
 the file as soon as it's opened, to help avoid exposing its contents
 (and to ensure that the file gets deleted when the application
 quits.)
    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)
   (hidden-by-user :initform t :accessor console-window-hidden-by-user))
  (:metaclass ns:+ns-object))

(defconstant $system-console-menu-item-tag 1)



(objc:defmethod (#/insertString: :void) ((self console-window) string)
  (with-slots ((tv typeout-view)) self
    (if (console-window-hidden-by-user self)
      (mark-console-output-available self t)
      (#/makeKeyAndOrderFront: self +null-ptr+))
    (#/insertString: (typeout-view-text-view tv) string)))

(defmethod mark-console-output-available ((self console-window) available-p)
  #+cocotron (declare (ignore available-p))
  #-cocotron
  (let* ((menu (#/windowsMenu *nsapp*))
         (menu-ref (ccl::external-call "__NSGetCarbonMenu" :address menu :address))
         (index (#/indexOfItemWithTag: menu $system-console-menu-item-tag)))
    (when (< index 0)
      (setq index (#/indexOfItemWithTitle: menu #@"Show System Console")))
    (when (> index 0)
      (ccl::external-call "_SetItemMark" :id menu-ref :integer (1+ index)
19 is diamondMark

(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)))
  ca n'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)))))

  output to file descriptors 1 and 2 , including messages
  may only be echoed to fd 2 if that fd is open to a file
  it will return EOF , and waiting via mechanisms like
  we 'd rather not see it as being constantly at EOF ...
  So , we have a timer - driven method wake up every second

(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
  ( readable/ writable by owner , not accessible to others . )   
#-windows-target
(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)
  #+windows-target +null-ptr+
  #-windows-target
  (flet ((path-inode (path)
           (nth-value 4 (ccl::%stat path)))
         (fd-inode (fd)
           (nth-value 4 (ccl::%fstat fd))))
    (cond ((and nil
                (eql (fd-inode 0) (path-inode "/dev/null"))
                (eql (fd-inode 1) (fd-inode 2))
                (rlet ((pflags :long))
                  (#_fcntl 2 #$F_GETFL :address pflags)
                  (let* ((accmode (logand #$O_ACCMODE (pref flags :long))))
                    (or (eql #$O_RDONLY accmode)
                        (eql #$O_RDWR accmode)))))
           (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 #+darwin-target "Monaco"
                                                  #-darwin-target "Courier"
                                                :size 10)
                                        :color (#/redColor ns:ns-color))))
             (#/setFrameOrigin: win (ns:make-ns-point 20 20))
             win))
          (t +null-ptr+))))

