source: trunk/source/cocoa-ide/cocoa-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").

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.6 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2002-2007 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18(in-package "GUI")
19
20(eval-when (:compile-toplevel :load-toplevel :execute)
21  (def-cocoa-default *default-font-name* :string "Courier" "Name of font to use in editor windows")
22  (def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT")
23  (def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters"))
24
25(defun init-cocoa-application ()
26  (with-autorelease-pool
27      (#/standardUserDefaults ns:ns-user-defaults)
28      (let* ((bundle (open-main-bundle))
29             (dict (#/infoDictionary  bundle))
30             (classname (#/objectForKey: dict #@"NSPrincipalClass"))
31             (mainnibname (#/objectForKey: dict  #@"NSMainNibFile"))
32             (progname (#/objectForKey: dict #@"CFBundleName")))
33        (if (%null-ptr-p classname)
34          (error "problems loading bundle: can't determine class name"))
35        (if (%null-ptr-p mainnibname)
36          (error "problems loading bundle: can't determine main nib name"))
37        (unless (%null-ptr-p progname)
38          (#/setProcessName: (#/processInfo ns:ns-process-info) progname))
39        (let* ((appclass (#_NSClassFromString classname))
40               (app (#/sharedApplication appclass)))
41          (#/loadNibNamed:owner: ns:ns-bundle mainnibname  app)
42          app))))
43
44
45
46#+apple-objc
47(defun trace-dps-events (flag)
48  (external-call "__DPSSetEventsTraced"
49                 :unsigned-byte (if flag #$YES #$NO)
50                 :void))
51
52(defclass appkit-process (process) ())
53
54;;; Interrupt the AppKit event process, by enqueing an event (if the
55;;; application event loop seems to be running.)  It's possible that
56;;; the event loop will stop after the calling thread checks; in that
57;;; case, the application's probably already in the process of
58;;; exiting, and isn't that different from the case where asynchronous
59;;; interrupts are used.
60(defmethod process-interrupt ((process appkit-process) function &rest args)
61  (if (eq process *current-process*)
62    (apply function args)
63    (if (and *NSApp* (#/isRunning *NSApp*))
64      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
65      (call-next-method))))
66
67(defparameter *debug-in-event-process* t)
68
69(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.")
70
71(defmethod ccl::process-debug-condition ((process appkit-process) condition frame-pointer)
72  "Better than nothing.  Not much better."
73  (when *debug-in-event-process*
74    (let* ((c (if (typep condition 'ccl::ns-lisp-exception)
75                (ccl::ns-lisp-exception-condition condition)
76                condition)))
77      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
78        (push c *event-process-reported-conditions*)
79        (catch 'need-a-catch-frame-for-backtrace
80          (let* ((*debug-in-event-process* nil)
81                 (context (ccl::new-backtrace-info nil
82                                                   frame-pointer
83                                                   (if ccl::*backtrace-contexts*
84                                                       (or (ccl::child-frame
85                                                            (ccl::bt.youngest (car ccl::*backtrace-contexts*))
86                                                            nil)
87                                                           (ccl::last-frame-ptr))
88                                                       (ccl::last-frame-ptr))
89                                                   (ccl::%current-tcr)
90                                                   condition
91                                                   (ccl::%current-frame-ptr)
92                                                   #+ppc-target ccl::*fake-stack-frames*
93                                                   #+x86-target (ccl::%current-frame-ptr)
94                                                   (ccl::db-link)
95                                                   (1+ ccl::*break-level*)))
96                 (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*))) 
97            (format t "~%~%*** Error in event process: ~a~%~%" condition)
98            (print-call-history :context context :detailed-p t :count 20 :origin frame-pointer)
99            (format t "~%~%~%")
100            (force-output t)
101            ))))))
102
103
104(defloadvar *default-ns-application-proxy-class-name*
105    "LispApplicationDelegate")
106
107
108#+apple-objc
109(defun enable-foreground ()
110  (rlet ((psn :<P>rocess<S>erial<N>umber))
111    (#_GetCurrentProcess psn)
112    (#_TransformProcessType psn #$kProcessTransformToForegroundApplication)
113    (eql 0 (#_SetFrontProcess psn))))
114
115#+nil
116(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
117  (declare (ignore sender))
118  (#/show (#/sharedPanel lisp-preferences-panel)))
119
120(objc:defmethod (#/toggleConsole: :void) ((self lisp-application) sender)
121  (let* ((console (console self)))
122    (unless (%null-ptr-p console)
123      (mark-console-output-available console nil)
124      (if (setf (console-window-hidden-by-user console) (#/isVisible console))
125        (#/orderOut: console sender)
126        (#/orderFront: console sender)))))
127
128(objc:defmethod (#/validateMenuItem: :<BOOL>) ((self lisp-application)
129                                               item)
130  (let* ((action (#/action item)))
131    (cond ((eql action (@selector #/toggleConsole:))
132           (let* ((console (console self)))
133             (unless (%null-ptr-p console)
134               (if (#/isVisible console)
135                 (#/setTitle: item #@"Hide System Console")
136                 (#/setTitle: item #@"Show System Console"))
137               t)))
138          (t (call-next-method item)))))
139
140(defmethod ccl::process-exit-application ((process appkit-process) thunk)
141  (when (eq process ccl::*initial-process*)
142    (%set-toplevel thunk)
143    (#/terminate: *NSApp* +null-ptr+)))
144
145(defun run-event-loop ()
146  (%set-toplevel nil)
147  (change-class *cocoa-event-process* 'appkit-process)
148  (event-loop))
149
150(defun stop-event-loop ()
151  (#/stop: *nsapp* +null-ptr+))
152
153(defun event-loop (&optional end-test)
154  (let* ((app *NSApp*)
155         (ccl::*break-on-errors* nil))
156    (loop
157      (handler-case (let* ((*event-process-reported-conditions* nil))
158                      (if end-test
159                        (#/run app)
160                        #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
161                                               #&NSDefaultRunLoopMode
162                                               (#/distantFuture ns:ns-date))|#
163                        (#/run app)))
164        (error (c) (nslog-condition c)))
165      #+GZ (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
166      (when (or (and end-test (funcall end-test))
167                (and ccl::*quitting* (not (#/isRunning app))))
168        (return)))))
169
170(defun start-cocoa-application (&key
171                                (application-proxy-class-name
172                                 *default-ns-application-proxy-class-name*))
173 
174  (flet ((cocoa-startup ()
175           ;; Start up a thread to run periodic tasks.
176           (process-run-function "housekeeping" #'ccl::housekeeping-loop)
177           (with-autorelease-pool
178             (enable-foreground)
179             (or *NSApp* (setq *NSApp* (init-cocoa-application)))
180             (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
181               (unless (%null-ptr-p icon)
182                 (#/setApplicationIconImage: *NSApp* icon)))
183             (setf (ccl::application-ui-object *application*) *NSApp*)
184             (when application-proxy-class-name
185               (let* ((classptr (ccl::%objc-class-classptr
186                                 (ccl::load-objc-class-descriptor application-proxy-class-name)))
187                      (instance (#/init (#/alloc classptr))))
188
189                 (#/setDelegate: *NSApp* instance))))
190           (run-event-loop)))
191    (process-interrupt *cocoa-event-process* #'(lambda ()
192                                                 (%set-toplevel 
193                                                  #'cocoa-startup)
194                                                 (toplevel)))))
195
196(defparameter *font-attribute-names*
197  '((:bold . #.#$NSBoldFontMask)
198    (:italic . #.#$NSItalicFontMask)
199    (:small-caps . #.#$NSSmallCapsFontMask)))
200
201
202;;; The NSFont method #/isFixedPitch has returned random answers
203;;; in many cases for the last few OSX releases.  Try to return
204;;; a reasonable answer, by checking to see if the width of the
205;;; advancement for the #\i glyph matches that of the advancement
206;;; of the #\m glyph.
207
208(defun is-fixed-pitch-font (font)
209  (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i")))
210     (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m")))))
211
212;;; Try to find the specified font.  If it doesn't exist (or isn't
213;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
214(defun default-font (&key (name *default-font-name*)
215                          (size *default-font-size*)
216                          (attributes ()))
217                               
218  (setq size (cgfloat size))
219  (with-cstrs ((name name))
220    (with-autorelease-pool
221        (rletz ((matrix (:array :<CGF>loat 6)))
222          (setf (paref matrix (:* :<CGF>loat) 0) size
223                (paref matrix (:* :<CGF>loat) 3) size)
224          (let* ((fontname (#/stringWithCString: ns:ns-string name))
225                 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
226                 
227                 (implemented-attributes ()))
228            (if (or (%null-ptr-p font)
229                    (and 
230                     (not (is-fixed-pitch-font font))))
231              (setq font (#/userFixedPitchFontOfSize: ns:ns-font size)))
232            (when attributes
233              (dolist (attr-name attributes)
234                (let* ((pair (assoc attr-name *font-attribute-names*))
235                       (newfont))
236                  (when pair
237                    (setq newfont
238                          (#/convertFont:toHaveTrait:
239                           (#/sharedFontManager ns:ns-font-manager) font (cdr pair)))
240                    (unless (eql font newfont)
241                      (setq font newfont)
242                      (push attr-name implemented-attributes))))))
243            (values (#/retain font) implemented-attributes))))))
244
245
246;;; Create a paragraph style, mostly so that we can set tabs reasonably.
247(defun create-paragraph-style (font line-break-mode)
248  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
249         (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
250    (#/setLineBreakMode: p
251                         (ecase line-break-mode
252                           (:char #$NSLineBreakByCharWrapping)
253                           (:word #$NSLineBreakByWordWrapping)
254                           ;; This doesn't seem to work too well.
255                           ((nil) #$NSLineBreakByClipping)))
256    ;; Clear existing tab stops.
257    (#/setTabStops: p (#/array ns:ns-array))
258    ;; And set the "default tab interval".
259    (#/setDefaultTabInterval: p (cgfloat (* *tab-width* charwidth)))
260    p))
261   
262(defun create-text-attributes (&key (font (default-font))
263                                    (line-break-mode :char)
264                                    (color nil)
265                                    (obliqueness nil)
266                                    (stroke-width nil))
267  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
268    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode)
269                         #&NSParagraphStyleAttributeName)
270    (#/setObject:forKey: dict font #&NSFontAttributeName)
271    (when color
272      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
273    (when stroke-width
274      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
275                           #&NSStrokeWidthAttributeName))
276    (when obliqueness
277      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
278                           #&NSObliquenessAttributeName))
279    dict))
280
281
282(defun get-cocoa-window-flag (w flagname)
283  (case flagname
284    (:accepts-mouse-moved-events
285     (#/acceptsMouseMovedEvents w))
286    (:cursor-rects-enabled
287     (#/areCursorRectsEnabled w))
288    (:auto-display
289     (#/isAutodisplay w))))
290
291
292
293(defun (setf get-cocoa-window-flag) (value w flagname)
294  (case flagname
295    (:accepts-mouse-moved-events
296     (#/setAcceptsMouseMovedEvents: w value))
297    (:auto-display
298     (#/setAutodisplay: w value))))
299
300
301
302(defun activate-window (w)
303  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
304  (#/makeKeyAndOrderFront: w nil))
305
306(defun set-window-title (window title)
307  (#/setTitle: window (if title
308                        (if (typep title 'ns:ns-string)
309                          title
310                          (%make-nsstring title))
311                        #@"") ))
312
313(defun new-cocoa-window (&key
314                         (class (find-class 'ns:ns-window))
315                         (title nil)
316                         (x 200.0)
317                         (y 200.0)
318                         (height 200.0)
319                         (width 500.0)
320                         (closable t)
321                         (iconifyable t)
322                         (metal nil)
323                         (expandable t)
324                         (backing :buffered)
325                         (defer t)
326                         (accepts-mouse-moved-events nil)
327                         (auto-display t)
328                         (activate t))
329  (ns:with-ns-rect (frame x y width height)
330    (let* ((stylemask
331            (logior #$NSTitledWindowMask
332                    (if closable #$NSClosableWindowMask 0)
333                    (if iconifyable #$NSMiniaturizableWindowMask 0)
334                    (if expandable #$NSResizableWindowMask 0)
335                    (if metal #$NSTexturedBackgroundWindowMask 0)))
336           (backing-type
337            (ecase backing
338              ((t :retained) #$NSBackingStoreRetained)
339              ((nil :nonretained) #$NSBackingStoreNonretained)
340              (:buffered #$NSBackingStoreBuffered)))
341           (w (make-instance
342               class
343               :with-content-rect frame
344               :style-mask stylemask
345               :backing backing-type
346               :defer defer)))
347      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
348            accepts-mouse-moved-events
349            (get-cocoa-window-flag w :auto-display)
350            auto-display)
351      (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
352      (when activate (activate-window w))
353      (when title (set-window-title w title))
354      w)))
355
356
357
358
Note: See TracBrowser for help on using the repository browser.