source: trunk/source/cocoa-ide/console-window.lisp @ 9772

Last change on this file since 9772 was 9772, checked in by gz, 14 years ago

Ticket #301: make the console window be hidden by default. Show a
diamond in its menu item if there is anything new to see since it was
last shown. Rename the menu item Show/Hide? System Console
(added "System").

File size: 6.8 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2008 Clozure Associates
4
5(in-package "GUI")
6
7
8(defclass console-window (typeout-window)
9  ((syslog-in :foreign-type :id :accessor syslog-in)
10   (syslog-out :foreign-type :id :accessor syslog-out)
11   (nextra :foreign-type :int)
12   (translatebuf :foreign-type :address)
13   (bufsize :foreign-type :int)
14   (hidden-by-user :initform t :accessor console-window-hidden-by-user))
15  (:metaclass ns:+ns-object))
16
17(defconstant $system-console-menu-item-tag 1)
18
19
20;;; Insert/append a string to the console-window's text view,
21;;; activating the window if necessary.
22
23(objc:defmethod (#/insertString: :void) ((self console-window) string)
24  (with-slots ((tv typeout-view)) self
25    (if (console-window-hidden-by-user self)
26      (mark-console-output-available self t)
27      (#/makeKeyAndOrderFront: self +null-ptr+))
28    (#/insertString: (typeout-view-text-view tv) string)))
29
30(defmethod mark-console-output-available ((self console-window) available-p)
31  (let* ((menu (#/windowsMenu *nsapp*))
32         (menu-ref (ccl::external-call "__NSGetCarbonMenu" :address menu :address))
33         (index (#/indexOfItemWithTag: menu $system-console-menu-item-tag)))
34    (when (< index 0)
35      (setq index (#/indexOfItemWithTitle: menu #@"Show System Console")))
36    (when (> index 0)
37      (ccl::external-call "_SetItemMark" :id menu-ref :integer (1+ index)
38                          :integer (if available-p #$diamondMark 0)))))
39
40;;; Process a chunkful of data
41(objc:defmethod (#/processData: :void) ((self console-window) data)
42  (with-slots (syslog-in syslog-out nextra translatebuf bufsize) self
43    (let* ((encoding (load-time-value (get-character-encoding :utf-8)))
44           (data-length (#/length data))
45           (n nextra)
46           (cursize bufsize)
47           (need (+ n data-length))
48           (xlate translatebuf))
49      (#/writeData: syslog-out data)
50      (when (> need cursize)
51        (let* ((new (#_malloc need)))
52          (dotimes (i n) (setf (%get-unsigned-byte new i)
53                               (%get-unsigned-byte xlate i)))
54          (#_free xlate)
55          (setq xlate new translatebuf new bufsize need)))
56      #+debug (#_NSLog #@"got %d bytes of data" :int data-length)
57      (with-macptrs ((target (%inc-ptr xlate n)))
58        (#/getBytes:range: data target (ns:make-ns-range 0 data-length)))
59      (let* ((total (+ n data-length))
60             (noctets-used (nth-value 1
61                                      (funcall (ccl::character-encoding-length-of-memory-encoding-function encoding)
62                                               xlate
63                                               total
64                                               0)))
65             (string (make-instance ns:ns-string
66                                    :with-bytes xlate
67                                    :length noctets-used
68                                    :encoding #$NSUTF8StringEncoding)))
69         (unless (zerop (setq n (- total noctets-used)))
70              ;; By definition, the number of untranslated octets
71              ;; can't be more than 3.
72              (dotimes (i n)
73                (setf (%get-unsigned-byte xlate i)
74                      (%get-unsigned-byte xlate (+ noctets-used i)))))
75            (setq nextra n)
76            (#/insertString: self string)))))
77
78;;; We want to be able to capture and display process-level
79;;; output to file descriptors 1 and 2, including messages
80;;; logged via #_NSLog/#_CFLog and variants.  Logging messages
81;;; may only be echoed to fd 2 if that fd is open to a file
82;;; (rather than to a socket/pty/pipe/...).  Unless/until
83;;; the the file has data written to it, reading from
84;;; it will return EOF, and waiting via mechanisms like
85;;; #_poll/#_select/#/readInBackgroundAndNotify will indicate
86;;; that the file can be read without blocking.  True, but
87;;; we'd rather not see it as being constantly at EOF ...
88;;; So, we have a timer-driven method wake up every second
89;;; or so, and see if there's actually any unread data
90;;; to process.
91
92(objc:defmethod (#/checkForData: :void) ((self console-window) timer)
93  (declare (ignorable timer))
94  (let* ((in (syslog-in self)))
95    (loop
96      (let* ((data (#/availableData in))
97             (n (#/length data)))
98        (declare (fixnum n))
99        (if (zerop n)
100          (return)
101          (#/processData: self data))))))
102
103;;; Open file descriptor to a temporary file.  The write-fd will be
104;;; open for reading and writing and the file will have mode #o600
105;;; (readable/ writable by owner, not accessible to others.)  Unlink
106;;; the file as soon as it's opened, to help exposing its contents
107;;; (and to ensure that the file gets deleted when the application
108;;; quits.)
109(defun open-logging-fds ()
110  (with-cstrs ((template "/tmp/logfileXXXXXX"))
111    (let* ((write-fd (#_mkstemp template)))
112      (when (>= write-fd 0)
113        (let* ((read-fd (#_open template #$O_RDONLY)))
114          (#_unlink template)
115          (values write-fd read-fd))))))
116
117
118
119(objc:defmethod #/redirectStandardOutput ((self console-window))
120  (with-slots (syslog-out syslog-in) self
121    (multiple-value-bind (write-fd read-fd) (open-logging-fds)
122      (when write-fd
123        (setq syslog-out
124              (make-instance 'ns:ns-file-handle :with-file-descriptor (#_dup 1)
125                             :close-on-dealloc t))
126        (let* ((log-fh (make-instance 'ns:ns-file-handle
127                                      :with-file-descriptor read-fd
128                                      :close-on-dealloc t)))
129          (setq syslog-in log-fh)
130          (let* ((bufsize #$BUFSIZ)
131                 (buffer (#_malloc bufsize)))
132            (setf (slot-value self 'translatebuf) buffer
133                  (slot-value self 'bufsize) bufsize
134                  (slot-value self 'nextra) 0))
135          (#_dup2 write-fd 1)
136          (#_dup2 write-fd 2)
137          (#/scheduledTimerWithTimeInterval:target:selector:userInfo:repeats:
138           ns:ns-timer
139           1.0d0
140           self
141           (@selector #/checkForData:)
142           +null-ptr+
143           t)))))
144  self)
145
146(objc:defmethod #/init ((self console-window))
147  (#/release self)
148  (flet ((path-inode (path)
149           (nth-value 4 (ccl::%stat path)))
150         (fd-inode (fd)
151           (nth-value 4 (ccl::%fstat fd))))
152    (cond ((and (eql (fd-inode 0) (path-inode "/dev/null"))
153                (eql (fd-inode 1) (fd-inode 2)))
154           (let* ((win (#/typeoutWindowWithTitle: (find-class 'console-window) #@"Console")))
155             (#/redirectStandardOutput win)
156             (let* ((tv (typeout-view-text-view (typeout-window-typeout-view win))))
157               (#/setTypingAttributes: tv
158                                       (create-text-attributes
159                                        :font (default-font :name "Monaco" :size 10)
160                                        :color (#/redColor ns:ns-color))))
161             (#/setFrameOrigin: win (ns:make-ns-point 20 20))
162             win))
163          (t +null-ptr+))))
164
Note: See TracBrowser for help on using the repository browser.