Ticket #447: easygui-miniviews9.lisp

File easygui-miniviews9.lisp, 6.9 KB (added by Arthur, 11 years ago)

Lisp code file, Easygui package, normal in CCL1.2, error in CCL1.3

Line 
1(in-package :easygui)
2
3#|
4This file contains CCL Easygui code demonstrating different behaviour between CCL v1.2 and CCL v1.3
5The essence seems to me - AWSC, arthur.cater@ucd.ie - to be that when Cocoa #/performClose:
6calls upon #/windowShouldClose: for the delegate of a instance of a subclassed window, the callout
7is unsupported by something in CCL v1.3.  It works fine in CCL v1.2. The problem was first spotted
8when testing on a darwinx8664 machine, but that turns out to be a red herring. On Powerbook G4,
9with OS 10.5.6, with cocoa-application required in both cases, there is a difference between
10CCL1.2/CCL1.3. The deftype for ccl::@metaclass moves the problem from being reported as to do with
11PARSE-UNKNOWN-TYPE to
12    ? About to test with window with no close button
13    Test successful!
14    About to test with window having a close button
15    > Error: value #<OBJC:OBJC-CLASS COCOA-WINDOW-DELEGATE (#x1F9260)> is not of the expected type OBJC:OBJC-METACLASS.
16    > While executing: CCL::CHECK-NS-EXCEPTION, in process Listener(6).
17    > Type :POP to abort, :R for a list of available restarts.
18    > Type :? for other options.
19    1 > :b
20     (F0300B30) : 0 (CHECK-NS-EXCEPTION #<A Foreign Pointer [stack-allocated] (:* #) #x3E4D650>) 336
21     (F0300B40) : 1 (FUNCALL #'#<(:INTERNAL CCL::SEND-UNAMBIGUOUS-MESSAGE (SHARED-INITIALIZE :AFTER (CCL::OBJC-DISPATCH-FUNCTION T)))> NIL) 380
22     (F0300B60) : 3 (FUNCALL #'#<(:INTERNAL CCL::SEND-UNAMBIGUOUS-MESSAGE (SHARED-INITIALIZE :AFTER (CCL::OBJC-DISPATCH-FUNCTION T)))> #<COCOA-WINDOW <CocoaWindow: 0x1bf200> (#x1BF200)> #<A Null Foreign Pointer>) 588
23     (F0300B80) : 5 (FUNCALL #'#<#<STANDARD-METHOD PERFORM-CLOSE (WINDOW)>> #<WINDOW #x8942EFE>) 136
24     (F0300BA0) : 7 (TEST T) 84
25     <snip>
26The final lines of the file contain an evl-when form for testing, all you need do is open in
27Hemlock, select all, execute.
28
29The earlier parts of the code augment or modify bits of EasyGui:
30- explicit conversion of window title string to ns-string
31- cut some irrelevant stuff
32- define new classes for cocoa-windows and delegate objects
33- attach delegate to new window when created
34- define objc methods for performClose: and windowShouldClose:
35|#
36
37(setf *debug-cocoa-calls* nil)
38
39(declaim (optimize (speed 0) (space 0) (compilation-speed 0) (safety 3) (debug 3)))
40
41(deftype ccl::@metaclass (x)
42    (declare (ignorable x))
43    'objc:objc-metaclass)
44
45(defmethod (setf view-text) (new-text (view view-text-via-title-mixin))
46  (dcc (#/setTitle: (cocoa-ref view) (ccl::%make-nsstring new-text)))
47  new-text)
48
49(defmethod initialize-view :after ((view view-text-mixin))
50  (when (slot-boundp view 'text)
51    (setf (view-text view) (slot-value view 'text))))
52
53(defclass content-view-mixin ()
54  ((content-view)))
55
56(defclass view (easy-cocoa-object)
57     ((position :initarg :position :reader view-position)
58      (size :initarg :size :reader view-size)
59      (frame-inited-p :initform nil)))
60
61(defclass contained-view (view)
62  ())
63
64(defmethod initialize-view :after ((view content-view-mixin))
65  (unless (slot-boundp view 'content-view)
66    (let ((containee (make-instance 'contained-view
67                       :cocoa-ref (dcc (#/contentView (cocoa-ref view))))))
68      (setf (slot-value view 'content-view) containee))))
69
70(defclass window (content-view-mixin view-text-via-title-mixin view)
71     ((text :initarg :title :initform "Anonymous Window" :reader window-title)
72      (closable-p :initarg :closable-p :initform t :reader window-closable-p)
73      (style :initarg :window-style :initform #$NSTitledWindowMask)))
74
75(defclass cocoa-window (ns:ns-window)
76  ((easygui-window :reader easygui-window-of))
77  (:metaclass ns:+ns-object))
78
79(defclass cocoa-window-delegate (ns:ns-object)
80  ()
81  (:metaclass ns:+ns-object))
82
83(defmethod shared-initialize :around ((view view) new-slots &rest initargs)
84  (declare (ignore new-slots initargs))
85  (call-next-method)
86  (running-on-main-thread ()
87    (initialize-view view)))
88
89(defmethod initialize-view ((view view))
90  "Initializes the view ...
91Also ...."
92  (when (slot-boundp view 'ref)
93    (return-from initialize-view nil))
94  (let ((ns-view-class (cdr (assoc (class-name (class-of view))
95                                   *view-class-to-ns-class-map*
96                                   :test #'subtypep)))
97        cocoaview)
98    (if ns-view-class
99      (setf cocoaview
100            (cond
101              ((and (slot-boundp view 'position)
102                    (slot-boundp view 'size))
103               (setf (slot-value view 'frame-inited-p) t)
104               (make-instance ns-view-class
105                  :with-frame (with-slots (position size) view
106                                 (ns-rect-from-points position size))))
107              (t (make-instance ns-view-class)))
108            (cocoa-ref view) cocoaview)
109      (cerror "Continue with cocoa-ref unset" "No view class found for type ~a" (class-of view)))))
110
111(defmethod view-content-rect ((view view))
112  (with-slots (position size) view
113    (let* ((height (if (slot-boundp view 'size) (point-y size) *window-size-default-y*))
114           (stated (if (slot-boundp view 'position) (point-y position) *window-position-default-y*))
115           (bottom stated))
116      (ns:make-ns-rect
117       (if (slot-boundp view 'position) (point-x position) *window-position-default-x*)
118       bottom
119       (if (slot-boundp view 'size) (point-x size) *window-size-default-x*)
120       height))))
121
122(defmethod initialize-view ((win window))
123  "Initialize size, title, flags."
124  (with-slots (style) win
125     (let* ((content-rect (view-content-rect win))
126            (style-mask (logior 
127                         #$NSTitledWindowMask
128                         (flag-mask :closable-p    (window-closable-p win))
129                         style))
130            (c-win
131             (make-instance 'cocoa-window
132               :with-content-rect content-rect
133               :style-mask style-mask
134               :backing #$NSBackingStoreBuffered ; TODO?
135               :defer nil))
136            (delegate (make-instance 'cocoa-window-delegate)))
137       (dcc (#/setDelegate: c-win delegate))
138       (setf (cocoa-ref win) c-win)
139       (setf (slot-value c-win 'easygui-window) win)
140       c-win)))
141
142(defmethod perform-close ((w window))
143"This generic is intended to allow applications to mimic the user clicking a window's
144close button."
145  (dcc (#/performClose: (cocoa-ref w)  ccl:+null-ptr+)))
146
147(objc:define-objc-method ((:<BOOL> :window-should-close (:id sender)) cocoa-window-delegate)
148  (declare (ignorable sender))  ; The cocoa-window has been set up as its own delegate. Naughty?
149  #$YES)
150
151(defvar *w)
152
153(defun test (closable)
154  (setf *w (make-instance 'window :closable-p closable))
155  (sleep 2)
156  (perform-close *w))
157
158(eval-when (:load-toplevel :execute)
159  (format t "About to test with window with no close button~%")
160  (test nil)
161  (format t "Test successful!~%")
162  (format t "About to test with window having a close button~%")
163  (test t)
164  (format nil "Test successful!~% I get this far with CCLv1.2 but not with CCLv1.3.~%"))