source: trunk/ccl/examples/cocoa-window.lisp @ 840

Last change on this file since 840 was 840, checked in by gb, 17 years ago

defer window creation

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2002-2003 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 "CCL")                      ; for now.
19
20(eval-when (:compile-toplevel :load-toplevel :execute)
21  (require "OBJC-SUPPORT")
22  (require "COCOA-DEFAULTS")
23  (require "COCOA-PREFS"))
24
25(eval-when (:compile-toplevel :execute)
26  (use-interface-dir #+apple-objc  :cocoa #+gnu-objc :gnustep))
27
28
29(defun init-cocoa-application ()
30  (with-autorelease-pool
31      (let* ((bundle (open-main-bundle))
32             (dict (send bundle 'info-dictionary))
33             (classname (send dict :object-for-key #@"NSPrincipalClass"))
34             (mainnibname (send dict :object-for-key  #@"NSMainNibFile"))
35             (progname (send dict :object-for-key #@"CFBundleName")))
36        (if (%null-ptr-p classname)
37          (error "problems loading bundle: can't determine class name"))
38        (if (%null-ptr-p mainnibname)
39          (error "problems loading bundle: can't determine main nib name"))
40        (unless (%null-ptr-p progname)
41          (send (send (@class ns-process-info) 'process-info)
42                :set-process-name progname))
43        (let* ((appclass (#_NSClassFromString classname))
44               (app (send appclass 'shared-application)))
45          (send (@class ns-bundle)
46                :load-nib-named mainnibname
47                :owner app)
48          app))))
49
50
51
52#+apple-objc
53(defun trace-dps-events (flag)
54  (external-call "__DPSSetEventsTraced"
55                 :unsigned-byte (if flag #$YES #$NO)
56                 :void))
57
58(defvar *appkit-process-interrupt-ids* (make-id-map))
59(defun register-appkit-process-interrupt (thunk)
60  (assign-id-map-id *appkit-process-interrupt-ids* thunk))
61(defun appkit-interrupt-function (id)
62  (id-map-free-object *appkit-process-interrupt-ids* id))
63
64(defclass appkit-process (process) ())
65
66(defconstant process-interrupt-event-subtype 17)
67
68
69
70
71(defclass lisp-application (ns:ns-application)
72    ((termp :foreign-type :<BOOL>))
73  (:metaclass ns:+ns-object))
74
75
76(define-objc-method ((:void :post-event-at-start e) ns:ns-application)
77  (send self :post-event e :at-start t))
78
79;;; Interrupt the AppKit event process, by enqueing an event (if the
80;;; application event loop seems to be running.)  It's possible that
81;;; the event loop will stop after the calling thread checks; in that
82;;; case, the application's probably already in the process of
83;;; exiting, and isn't that different from the case where asynchronous
84;;; interrupts are used.  An attribute of the event is used to identify
85;;; the thunk which the event handler needs to funcall.
86(defmethod process-interrupt ((process appkit-process) function &rest args)
87  (if (eq process *current-process*)
88    (apply function args)
89    (if (or (not *NSApp*) (not (send *NSApp* 'is-running)))
90      (call-next-method)
91      (let* ((e (send (@class ns-event)
92                      :other-event-with-type #$NSApplicationDefined
93                      :location (ns-make-point 0.0e0 0.0e0)
94                      :modifier-flags 0
95                      :timestamp 0.0d0
96                      :window-number 0
97                      :context (%null-ptr)
98                      :subtype process-interrupt-event-subtype
99                      :data1 (register-appkit-process-interrupt
100                              #'(lambda () (apply function args)))
101                      :data2 0)))
102        (send e 'retain)
103        (send *NSApp*
104              :perform-selector-on-main-thread (@selector
105                                                "postEventAtStart:")
106              :with-object e
107              :wait-until-done t)))))
108
109#+apple-objc
110(define-objc-method ("_shouldTerminate" lisp-application)
111  (:<BOOL>)
112  (with-slots (termp) self
113      (setq termp (objc-message-send-super (super) "_shouldTerminate" :<BOOL>))))
114
115(define-objc-method ((:<BOOL> termp) lisp-application)
116  (with-slots (termp) self
117      termp))
118
119(defloadvar *default-ns-application-proxy-class-name*
120    "LispApplicationDelegate")
121
122#+apple-objc
123(defun enable-foreground ()
124  (%stack-block ((psn 8))
125    (external-call "_GetCurrentProcess" :address psn)
126    (external-call "_CPSEnableForegroundOperation" :address psn)
127    (eql 0 (external-call "_SetFrontProcess" :address psn :signed-halfword))))
128
129;;; I'm not sure if there's another way to recognize events whose
130;;; type is #$NSApplicationDefined.
131(define-objc-method ((:void :send-event e)
132                     lisp-application)
133  (if (and (eql (send e 'type) #$NSApplicationDefined)
134           (eql (send e 'subtype) process-interrupt-event-subtype))
135    ;;; The thunk to funcall is identified by the value
136    ;;; of the event's data1 attribute.
137    (funcall (appkit-interrupt-function (send e 'data1)))
138    (send-super :send-event e)))
139
140;;; This is a reverse-engineered version of most of -[NSApplication terminate],
141;;; split off this way because we don't necessarily want to just do
142;;  (#_exit 0) when we've shut down the Cocoa UI.
143#+apple-objc
144(define-objc-method ((:void shutdown)
145                     lisp-application)
146  (unless (eql (pref self :<NSA>pplication._app<F>lags._app<D>ying) #$YES)
147    (if (eql #$NO (external-call "__runningOnAppKitThread" :<BOOL>))
148      (send self
149            :perform-selector-on-main-thread (@selector "shutdown")
150            :with-object (%null-ptr)
151            :wait-until-done nil)
152      (progn
153        (setf (pref self :<NSA>pplication._app<F>lags._app<D>ying) #$YES)
154        (send (send (@class ns-notification-center) 'default-center)
155              :post-notification-name #@"NSApplicationWillTerminateNotification"
156              :object self)
157        ;; Remove self as the observer of all notifications (the
158        ;; precise set of notifications for which it's registered
159        ;; may vary from release to release
160        (send (send (@class ns-notification-center) 'default-center)
161              :remove-observer self
162              :name (%null-ptr)
163              :object (%null-ptr))
164        (objc-message-send (@class ns-menu) "_saveTornOffMenus" :void)
165        (send (send (@class ns-user-defaults) 'standard-user-defaults)
166              'synchronize)
167        (objc-message-send (@class ns-pasteboard) 
168                           "_provideAllPromisedData" :void)
169        (objc-message-send (send (@class ns-help-manager) 'shared-help-manager)
170                           "_cleanupHelpForQuit" :void)
171        ;; See what happens when you muck around in Things You Shouldn't
172        ;; Know About ?
173        (let* ((addr (or (foreign-symbol-address
174                          "__NSKeyboardUIHotKeysUnregister")
175                         (foreign-symbol-address
176                          "__NSKeyboardUIHotKeysCleanup"))))
177          (if addr (ff-call addr :void)))
178        (send (the ns-application self) :stop (%null-ptr))))))
179
180(define-objc-method ((:void :terminate sender)
181                     lisp-application)
182  (declare (ignore sender))
183  (quit))
184
185(define-objc-method ((:void :show-preferences sender) lisp-application)
186  (declare (ignore sender))
187  (send (send (find-class 'preferences-panel) 'shared-panel) 'show))
188
189
190(defun nslog-condition (c)
191  (let* ((rep (format nil "~a" c)))
192    (with-cstrs ((str rep))
193      (with-nsstr (nsstr str (length rep))
194        (#_NSLog #@"Error in event loop: %@" :address nsstr)))))
195
196
197#+apple-objc
198(defmethod process-verify-quit ((process appkit-process))
199  (let* ((app *NSApp*))
200    (or
201     (null app)
202     (not (send app 'is-running))
203     (eql (pref app :<NSA>pplication._app<F>lags._app<D>ying) #$YES)
204     (eql (pref app
205                :<NSA>pplication._app<F>lags._dont<S>end<S>hould<T>erminate)
206          #$YES)
207     (progn
208       (send
209        app
210        :perform-selector-on-main-thread (@selector "_shouldTerminate")
211        :with-object (%null-ptr)
212        :wait-until-done t)
213       (send app 'termp)))))
214
215#+apple-objc
216(defmethod process-exit-application ((process appkit-process) thunk)
217  (when (eq process *initial-process*)
218    (prepare-to-quit)
219    (%set-toplevel thunk)
220    (send (the lisp-application *NSApp*) 'shutdown)
221    ))
222
223(defun run-event-loop ()
224  (%set-toplevel nil)
225  (let* ((app *NSApp*))
226    (loop
227        (handler-case (send (the ns-application app) 'run)
228          (error (c) (nslog-condition c)))
229        (unless (send app 'is-running)
230          (return)))
231    ;; This is a little funky (OK, it's a -lot- funky.) The
232    ;; -[NSApplication _deallocHardCore:] method wants an autorelease
233    ;; pool to be established when it's called, but one of the things
234    ;; that it does is to release all autorelease pools.  So, we create
235    ;; one, but don't worry about freeing it ...
236    #+apple-objc
237    (progn
238      (create-autorelease-pool)
239      (objc-message-send app "_deallocHardCore:" :<BOOL> #$YES :void))))
240
241
242(change-class *cocoa-event-process* 'appkit-process)
243
244(defun start-cocoa-application (&key
245                                (application-proxy-class-name
246                                 *default-ns-application-proxy-class-name*))
247 
248  (flet ((cocoa-startup ()
249           ;; Start up a thread to run periodic tasks.
250           ;; Under Linux/GNUstep, some of these might have to run in
251           ;; the main thread (because of PID/thread conflation.)
252           (process-run-function "housekeeping"
253                                 #'(lambda ()
254                                     (loop
255                                         (%nanosleep *periodic-task-seconds*
256                                                     *periodic-task-nanoseconds*)
257                                         (housekeeping))))
258           
259           (with-autorelease-pool
260               (enable-foreground)
261               (or *NSApp* (setq *NSApp* (init-cocoa-application)))
262               (send *NSApp* :set-application-icon-image
263                     (send (@class ns-image) :image-Named #@"NSApplicationIcon"))
264               (setf (application-ui-object *application*) *NSApp*)
265
266               (when application-proxy-class-name
267                 (let* ((classptr (%objc-class-classptr
268                                   (load-objc-class-descriptor application-proxy-class-name))))
269                   (send *NSApp* :set-delegate
270                         (send (send classptr 'alloc) 'init)))))
271           (run-event-loop)))
272    (process-interrupt *cocoa-event-process* #'(lambda ()
273                                                 (%set-toplevel 
274                                                  #'cocoa-startup)
275                                                 (toplevel)))))
276
277(def-cocoa-default *default-font-name* :string "Courier" "Name of font to use in editor windows")
278(def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT")
279
280(defparameter *font-attribute-names*
281  '((:bold . #.#$NSBoldFontMask)
282    (:italic . #.#$NSItalicFontMask)
283    (:small-caps . #.#$NSSmallCapsFontMask)))
284   
285;;; Try to find the specified font.  If it doesn't exist (or isn't
286;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
287(defun default-font (&key (name *default-font-name*)
288                          (size *default-font-size*)
289                          (attributes ()))
290                               
291  (setq size (float size 0.0f0))
292  (with-cstrs ((name name))
293    (with-autorelease-pool
294        (rletz ((matrix (:array :float 6)))
295          (setf (%get-single-float matrix 0) size
296                (%get-single-float matrix 12) size)
297          (let* ((fontname (send (@class ns-string) :string-with-c-string name))
298                 (font (send (@class ns-font)
299                                  :font-with-name fontname :matrix matrix))
300                 (implemented-attributes ()))
301            (if (or (%null-ptr-p font)
302                    (and 
303                     (not (send font 'is-fixed-pitch))
304                     (not (eql #$YES (objc-message-send font "_isFakeFixedPitch" :<BOOL>)))))
305              (setq font (send (@class ns-font)
306                               :user-fixed-pitch-font-of-size size)))
307            (when attributes
308              (dolist (attr-name attributes)
309                (let* ((pair (assoc attr-name *font-attribute-names*))
310                       (newfont))
311                  (when pair
312                    (setq newfont
313                          (send
314                           (send (@class "NSFontManager") 'shared-font-manager)
315                           :convert-font font
316                           :to-have-trait (cdr pair)))
317                    (unless (eql font newfont)
318                      (setq font newfont)
319                      (push attr-name implemented-attributes))))))
320            (values font implemented-attributes))))))
321
322(def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters" (integer 1 32))
323
324;;; Create a paragraph style, mostly so that we can set tabs reasonably.
325(defun create-paragraph-style (font line-break-mode)
326  (let* ((p (make-objc-instance 'ns-mutable-paragraph-style))
327         (charwidth (send (send font 'screen-font)
328                          :width-of-string #@" ")))
329    (send p
330          :set-line-break-mode
331          (ecase line-break-mode
332            (:char #$NSLineBreakByCharWrapping)
333            (:word #$NSLineBreakByWordWrapping)
334            ;; This doesn't seem to work too well.
335            ((nil) #$NSLineBreakByClipping)))
336    ;; Clear existing tab stops.
337    (send p :set-tab-stops (send (@class ns-array) 'array))
338    (do* ((i 1 (1+ i)))
339         ((= i 100) p)
340      (let* ((tabstop (make-objc-instance
341                       'ns-text-tab
342                       :with-type #$NSLeftTabStopType
343                       :location  (* (* i *tab-width*)
344                                        charwidth))))
345        (send p :add-tab-stop tabstop)
346        (send tabstop 'release)))))
347   
348(defun create-text-attributes (&key (font (default-font))
349                                    (line-break-mode :char)
350                                    (color nil)
351                                    (obliqueness nil)
352                                    (stroke-width nil))
353  (let* ((dict (make-objc-instance
354                'ns-mutable-dictionary
355                :with-capacity 5)))
356    (send dict 'retain)
357    (send dict
358          :set-object (create-paragraph-style font line-break-mode)
359          :for-key #?NSParagraphStyleAttributeName)
360    (send dict :set-object font :for-key #?NSFontAttributeName)
361    (when color
362      (send dict :set-object color :for-key #?NSForegroundColorAttributeName))
363    (when stroke-width
364      (send dict :set-object (make-objc-instance 'ns:ns-number
365                                                :with-float (float stroke-width))
366            :for-key #?NSStrokeWidthAttributeName))
367    (when obliqueness
368      (send dict :set-object (make-objc-instance 'ns:ns-number
369                                                :with-float (float obliqueness))
370            :for-key #?NSObliquenessAttributeName))
371    dict))
372
373
374(defun get-cocoa-window-flag (w flagname)
375  (case flagname
376    (:accepts-mouse-moved-events
377     (send w 'accepts-mouse-moved-events))
378    (:cursor-rects-enabled
379     (send w 'are-cursor-rects-enabled))
380    (:auto-display
381     (send w 'is-autodisplay))))
382
383
384
385(defun (setf get-cocoa-window-flag) (value w flagname)
386  (case flagname
387    (:accepts-mouse-moved-events
388     (send w :set-accepts-mouse-moved-events value))
389    (:auto-display
390     (send w :set-autodisplay value))))
391
392
393
394(defun activate-window (w)
395  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
396  (send w :make-key-and-order-front nil))
397
398(defun new-cocoa-window (&key
399                         (class (find-class 'ns:ns-window))
400                         (title nil)
401                         (x 200.0)
402                         (y 200.0)
403                         (height 200.0)
404                         (width 500.0)
405                         (closable t)
406                         (iconifyable t)
407                         (metal t)
408                         (expandable t)
409                         (backing :buffered)
410                         (defer t)
411                         (accepts-mouse-moved-events nil)
412                         (auto-display t)
413                         (activate t))
414  (rlet ((frame :<NSR>ect :origin.x (float x) :origin.y (float y) :size.width (float width) :size.height (float height)))
415    (let* ((stylemask
416            (logior #$NSTitledWindowMask
417                    (if closable #$NSClosableWindowMask 0)
418                    (if iconifyable #$NSMiniaturizableWindowMask 0)
419                    (if expandable #$NSResizableWindowMask 0)
420                    (if metal #$NSTexturedBackgroundWindowMask 0)))
421           (backing-type
422            (ecase backing
423              ((t :retained) #$NSBackingStoreRetained)
424              ((nil :nonretained) #$NSBackingStoreNonretained)
425              (:buffered #$NSBackingStoreBuffered)))
426           (w (make-instance
427               class
428               :with-content-rect frame
429               :style-mask stylemask
430               :backing backing-type
431               :defer defer)))
432      (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
433            accepts-mouse-moved-events
434            (get-cocoa-window-flag w :auto-display)
435            auto-display)
436      (when activate (activate-window w))
437      (when title (send w :set-title (%make-nsstring title)))
438      w)))
439
440
441
442
Note: See TracBrowser for help on using the repository browser.