/[cl-carbon]/CL-Carbon/event.lisp
ViewVC logotype

Contents of /CL-Carbon/event.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri May 6 04:41:47 2005 UTC (8 years, 11 months ago) by dsteuber
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +37 -22 lines
Added code to hopefully delete the event handler so that the associated
object can be freed.  Also removed a slot from the cl-carbon:window class.
Objects should generally not know about their containers.
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: CL-CARBON -*-
2 ;;;; ***********************************************************************
3 ;;;; FILE IDENTIFICATION
4 ;;;;
5 ;;;; Name: event.lisp
6 ;;;; Project: CL-Carbon
7 ;;;; Purpose: Carbon Event Manager abstraction
8 ;;;; Programmer: David Steuber
9 ;;;; Date Started: 1/27/2005
10 ;;;;
11 ;;;; $Id: event.lisp,v 1.3 2005/05/06 04:41:47 dsteuber Exp $
12 ;;;; ***********************************************************************
13 ;;;;
14 ;;;; Copyright (c) 2005 by David Steuber
15 ;;;;
16 ;;;; Permission is hereby granted, free of charge, to any person obtaining
17 ;;;; a copy of this software and associated documentation files (the
18 ;;;; "Software"), to deal in the Software without restriction, including
19 ;;;; without limitation the rights to use, copy, modify, merge, publish,
20 ;;;; distribute, sublicense, and/or sell copies of the Software, and to
21 ;;;; permit persons to whom the Software is furnished to do so, subject to
22 ;;;; the following conditions:
23 ;;;;
24 ;;;; The above copyright notice and this permission notice shall be
25 ;;;; included in all copies or substantial portions of the Software.
26 ;;;;
27 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
28 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
29 ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
30 ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
31 ;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
32 ;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
33 ;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
34 ;;;;
35 ;;;; ***********************************************************************
36
37 (in-package :cl-carbon)
38
39 (defclass event-target ()
40 ((event-handler-callback :initform (ccl::%null-ptr))
41 (event-handler-ref :initform (ccl::%null-ptr)))
42 (:documentation "An object that receives Carbon events"))
43
44 (defstruct (event-type-spec
45 (:constructor make-event-type-spec (event-class event-kind))
46 (:conc-name ets-))
47 (event-class 0 :type (unsigned-byte 32))
48 (event-kind 0 :type (unsigned-byte 32)))
49
50 (defgeneric get-event-type-specs (event-target)
51 (:documentation "Returns a list of event-type-spec objects for installing the event handler."))
52
53 (defgeneric handle-event (target class kind next-handler event user-data)
54 (:documentation
55 "Handle Carbon events. Return T when the event is handled or NIL otherwise."))
56
57 (defmethod handle-event ((target event-target) class kind next-handler event user-data)
58 (declare (ignore class kind next-handler event user-data))
59 nil)
60
61 (defgeneric menu-command (event-target command)
62 (:documentation
63 "Handle menu commands. Return T when command is handled or NIL otherwise."))
64
65 (defmethod menu-command ((et event-target) command)
66 (declare (ignore command))
67 nil)
68
69 (defgeneric install-event-handler (event-target target event-type-specs)
70 (:documentation "Installs an event handler"))
71
72 (defmethod install-event-handler ((et event-target) target event-type-specs)
73 (let* ((num-specs (length event-type-specs))
74 (offset 0)
75 (event-specs (ccl::malloc (* num-specs (ccl::record-length :<e>vent<t>ype<s>pec)))))
76 (dolist (ets event-type-specs)
77 (setf (ccl::%get-unsigned-long event-specs offset) (ets-event-class ets))
78 (incf offset (ccl::record-length :unsigned))
79 (setf (ccl::%get-unsigned-long event-specs offset) (ets-event-kind ets))
80 (incf offset (ccl::record-length :unsigned)))
81 (rlet ((ehr :<e>vent<h>andler<r>ef))
82 (with-slots (event-handler-callback event-handler-ref) et
83 (let ((retval (#_InstallEventHandler target
84 (#_NewEventHandlerUPP (setf event-handler-callback
85 (make-event-target-callback et)))
86 num-specs
87 event-specs
88 (ccl::%null-ptr)
89 ehr)))
90 (ccl::free event-specs)
91 (setf event-handler-ref (ccl::%get-ptr ehr))
92 (debug-log "Installed event handler: ~S~%" event-handler-ref)
93 retval)))))
94
95 (defgeneric remove-event-handler (event-target)
96 (:documentation "Removes (uninstalls) an event handler"))
97
98 (defmethod remove-event-handler ((et event-target))
99 (with-slots (event-handler-callback event-handler-ref) et
100 (debug-log "Removing event handler: ~S~%" event-handler-ref)
101 (#_RemoveEventHandler event-handler-ref)
102 (delete-event-target-callback event-handler-callback)))
103
104 (defgeneric add-event-types-to-handler (event-target event-specs))
105
106 (defgeneric remove-event-types-from-handler (event-target event-specs))
107
108 (defmethod add-event-types-to-handler ((et event-target) event-specs)
109 (frob-event-types-for-handler (lambda (ehr count typespecs)
110 (#_AddEventTypesToHandler ehr count typespecs))
111 (slot-value et 'event-handler-ref)
112 event-specs))
113
114 (defmethod remove-event-types-from-handler ((et event-target) event-specs)
115 (frob-event-types-for-handler (lambda (ehr count typespecs)
116 (#_RemoveEventTypesFromHandler ehr count typespecs))
117 (slot-value et 'event-handler-ref)
118 event-specs))
119
120 (defun frob-event-types-for-handler (frob-fn event-handler-ref event-type-specs)
121 (let* ((num-specs (length event-type-specs))
122 (offset 0)
123 (event-specs (ccl::malloc (* num-specs (ccl::record-length :<e>vent<t>ype<s>pec)))))
124 (dolist (ets event-type-specs)
125 (setf (ccl::%get-unsigned-long event-specs offset) (ets-event-class ets))
126 (incf offset (ccl::record-length :unsigned))
127 (setf (ccl::%get-unsigned-long event-specs offset) (ets-event-kind ets))
128 (incf offset (ccl::record-length :unsigned)))
129 (let ((retval (funcall frob-fn event-handler-ref num-specs event-specs)))
130 (ccl::free event-specs)
131 retval)))
132
133 (defmethod handle-event ((et event-target)
134 (class (eql #$kEventClassCommand))
135 (kind (eql #$kEventCommandProcess))
136 next-handler event user-data)
137 (declare (ignore next-handler user-data))
138 (rlet ((command :<hic>ommand))
139 (#_GetEventParameter event #$kEventParamDirectObject #$typeHICommand
140 (ccl::%null-ptr) (ccl::record-length :<hic>ommand)
141 (ccl::%null-ptr) command)
142 (menu-command et (ccl::pref command :<hic>ommand.command<id>))))
143
144 (defun make-event-target-callback (et)
145 (let (fn-carbon-event-handler)
146 (declare (special fn-carbon-event-handler))
147 (ccl:defcallback fn-carbon-event-handler
148 (:<e>vent<h>andler<c>all<r>ef next-handler :<e>vent<r>ef event (:* t) user-data :<oss>tatus)
149 (let ((class (#_GetEventClass event))
150 (kind (#_GetEventKind event)))
151 (declare (dynamic-extent class kind))
152 (debug-log "Callback CARBON-EVENT-HANDLER: event-handler-ref = ~S; Class: '~A' Kind: ~A~%"
153 (slot-value et 'event-handler-ref) (int32-to-string class) kind)
154 (multiple-value-bind (r c)
155 (ignore-errors
156 (handle-event et class kind next-handler event user-data))
157 (declare (dynamic-extent r c))
158 (when c
159 (debug-log "Condition signaled from CARBON-EVENT-HANDLER: < ~A >~%" c))
160 (if r #$noErr #$eventNotHandledErr))))
161 fn-carbon-event-handler))
162
163 ;; this function is based on code that Gary Byers posted to openmcl-devel
164 (defun delete-event-target-callback (pointer)
165 (with-lock-grabbed (ccl::*callback-lock*)
166 (let ((index (dotimes (i (length ccl::%pascal-functions%))
167 (when (eql (ccl::pfe.routine-descriptor (svref ccl::%pascal-functions% i))
168 pointer)
169 (return i)))))
170 (when index
171 (let ((entry (svref ccl::%pascal-functions% index)))
172 (setf (svref ccl::%pascal-functions% index) nil)
173 (ccl::free (ccl::pfe.routine-descriptor entry))
174 t)))))
175

  ViewVC Help
Powered by ViewVC 1.1.5