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

Last change on this file since 13711 was 12629, checked in by gb, 11 years ago

Use Courier font by default on Windows/Cocotron?. (It seems to be
a bitmap font and we're better able to get accurate metrics for it
than for vector fonts.)

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