/[gtk-cffi]/gtk-cffi/gtk/widget.lisp
ViewVC logotype

Contents of /gtk-cffi/gtk/widget.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Mon Dec 31 13:33:38 2012 UTC (15 months, 2 weeks ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.18: +4 -4 lines
Backed to CFFI 10.7 (was version from git)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; widget.lisp --- Wrapper for GtkWidget
4 ;;;
5 ;;; Copyright (C) 2007, Roman Klochkov <kalimehtar@mail.ru>
6 ;;;
7
8 (in-package :gtk-cffi)
9
10 (defclass widget (g-object buildable)
11 ((%style-properties :accessor %style-properties
12 :initform nil :allocation :class)))
13
14 (defcfun gtk-widget-new :pointer (g-type g-type) (null :pointer))
15
16 (defmethod gconstructor ((wideget widget)
17 &key type &allow-other-keys)
18 (gtk-widget-new type (null-pointer)))
19
20 (defcstruct* requisition
21 "GtkRequisition"
22 (width :int)
23 (height :int))
24
25 (defcfun gtk-requisition-new :pointer)
26
27 (defmethod new-struct ((class (eql 'requisition)))
28 (gtk-requisition-new))
29
30 (defcfun gtk-requisition-free :void (requisition pobject))
31
32 (defmethod free-struct ((class (eql 'requisition)) value)
33 (gtk-requisition-free value))
34
35
36 (defcstruct* allocation
37 "GtkAllocation"
38 (x :int) (y :int)
39 (width :int) (height :int))
40
41
42 (defcfun gtk-widget-show :boolean (widget pobject))
43 (defcfun gtk-widget-show-all :boolean (widget pobject))
44 (defcfun gtk-widget-show-now :boolean (widget pobject))
45
46 (defgeneric show (widget &key all now)
47 (:documentation "gtk_widget_show[_now|_all] ALL and NOW are booleans")
48 (:method ((widget widget) &key (all t) now)
49 (funcall (cond
50 (now #'gtk-widget-show-now)
51 (all #'gtk-widget-show-all)
52 (t #'gtk-widget-show)) widget)))
53
54
55 (defcfun gtk-widget-draw :void (widget pobject) (context :pointer))
56
57 (defgeneric draw (widget &optional context)
58 (:documentation "context is cl-cairo2 context")
59 (:method ((widget widget) &optional (context cl-cairo2:*context*))
60 (cl-cairo2::with-context-pointer (context cntx-pointer)
61 (gtk-widget-draw widget cntx-pointer))))
62
63 (defcfun gtk-widget-queue-draw-area :void
64 (widget pobject) (x :int) (y :int) (width :int) (height :int))
65 (defcfun gtk-widget-queue-draw-region :void (widget pobject) (region pobject))
66 (defcfun gtk-widget-queue-draw :void (widget pobject))
67
68 (defgeneric queue-draw (widget &key area region)
69 (:method ((widget widget) &key area region)
70 (cond
71 (area (apply #'gtk-widget-queue-draw-area widget area))
72 (region (gtk-widget-queue-draw-region widget region))
73 (t (gtk-widget-queue-draw widget)))))
74
75 (defcfun gtk-widget-queue-resize :void (widget pobject))
76 (defcfun gtk-widget-queue-resize-no-redraw :void (widget pobject))
77
78 (defgeneric queue-resize (widget &key no-redraw)
79 (:method ((widget widget) &key no-redraw)
80 (if no-redraw
81 (gtk-widget-queue-resize-no-redraw widget)
82 (gtk-widget-queue-resize widget))))
83
84 (defcfun gtk-widget-get-size-request :void
85 (widget pobject) (width :pointer) (height :pointer))
86
87 (defgeneric size-request (widget)
88 (:method ((widget widget))
89 "returns (width height)"
90 (with-foreign-outs-list ((width :int) (height :int)) :ignore
91 (gtk-widget-get-size-request widget width height))))
92
93 (defcfun gtk-widget-set-size-request
94 :void (widget pobject) (w :int) (h :int))
95
96 (defgeneric (setf size-request) (coords widget)
97 (:method (coords (widget widget))
98 "coords = (width height)"
99 (gtk-widget-set-size-request widget
100 (first coords)
101 (second coords))))
102 (save-setter widget size-request)
103
104 (defcfun gtk-widget-intersect :boolean
105 (src1 pobject) (src2 (struct rectangle)) (dest (struct rectangle :out t)))
106
107 (defmethod intersect ((rect1 widget) (rect2 rectangle))
108 (let ((dest (make-instance 'rectangle)))
109 (when (gtk-widget-intersect rect1 rect2 dest)
110 dest)))
111
112
113 (defcenum align :fill :start :end :center)
114
115 (defbitfield widget-flags
116 (:toplevel 16)
117 :no-window :realized :mapped :visible :sensitive
118 :parent-sensitive :can-focus :set-focus :can-default :has-default
119 :has-grab :rc-style :composite-child :no-reparent :app-paintable
120 :recieves-default :double-buffered :no-show-all)
121
122 (defslots widget
123 name :string
124 direction text-direction
125 default-direction text-direction
126 parent-window pobject
127 parent pobject
128 child-visible :boolean
129 tooltip-markup g-lib-string
130 tooltip-text g-lib-string
131 tooltip-window pobject
132 has-tooltip :boolean
133 can-default :boolean
134 can-focus :boolean
135 double-buffered :boolean
136 has-window :boolean
137 visible :boolean
138 receives-default :boolean
139 mapped :boolean
140 realized :boolean
141 no-show-all :boolean
142 sensitive :boolean
143 events event-mask
144 visual pobject
145 composite-name g-lib-string
146 halign align
147 valign align
148 margin-left :int
149 margin-right :int
150 margin-top :int
151 margin-bottom :int
152 hexpand :boolean
153 hexpand-set :boolean
154 vexpand :boolean
155 vexpand-set :boolean
156 window pobject
157 support-multidevice :boolean
158 app-paintable :boolean)
159
160 (defgtkfuns widget
161 (activate :boolean)
162 (hide :boolean)
163 (size-allocate :void (allocation (struct allocation)))
164 (add-accelerator :void
165 (accel-signal :string) (accel-group pobject) (accel-key key)
166 (accel-mods modifier-type) (accel-flags accel-flags))
167 (remove-accelerator :boolean
168 (accel-group pobject) (accel-key key)
169 (accel-mods modifier-type))
170 (list-accel-closures g-list)
171 (can-activate-accel :boolean (signal-id :uint))
172 ((widget-event . event) :boolean (event :pointer))
173 (send-expose :int (event :pointer))
174 (send-focus-change :boolean (event :pointer))
175 (reparent :void (new-parent pobject))
176 (is-focus :boolean)
177 (grab-focus :void)
178 (grab-default :void)
179 (override-color :void (state state-flags) (color prgba))
180 (override-background-color :void (state state-flags) (color prgba))
181 (override-symbolic-color :void (name :string) (color prgba))
182 (:get style-context pobject)
183 (override-font :void (font pango-cffi:font))
184 (:set (widget-accel-path . accel-path) :string
185 (accel-group pobject))
186 (destroy :void)
187 (render-icon-pixbuf pobject (stock-id :string) (size icon-size))
188 (add-events :void (events event-mask))
189 (:get device-events event-mask (device pobject))
190 (add-device-events :void (device pobject) (events event-mask))
191 (:get device-enabled :boolean (device pobject))
192 (:get toplevel pobject)
193 (:get ancestor pobject (widget-type g-type))
194 (is-ancestor :boolean (ancestor pobject))
195 ;; region should be cairo_region_t, but it is not realized in cl-cairo2 yet
196 (shape-combine-region :void (region pobject))
197 (input-shape-combine-region :void (region pobject))
198 (:get path (object widget-path))
199 (is-composited :boolean)
200 (override-cursor :void (cursor prgba) (secondary-cursor prgba))
201 (create-pango-context pobject)
202 (:get pango-context pobject)
203 (create-pango-layout pobject)
204 (:set redraw-on-allocate :boolean)
205 (mnemonic-activate :boolean &key (group-cycling :boolean))
206 (unparent :void)
207 ((widget-map . map) :void)
208 (unmap :void)
209 (realize :void)
210 (unrealize :void)
211 (:get accessible pobject)
212 (child-focus :boolean (direction direction-type))
213 (child-notify :void (child-property :string))
214 (freeze-child-notify :void)
215 (:get settings pobject)
216 (:get clipboard pobject (selection gatom))
217 (:get display pobject)
218 (:get root-window pobject)
219 (:get screen pobject)
220 (has-screen :boolean)
221 (thaw-child-notify :void)
222 (list-mnemonic-labels g-list-object)
223 (add-mnemonic-label :void (label pobject))
224 (remove-mnemonic-label :void (label pobject))
225 (error-bell :void)
226 (keynav-failed :boolean (direction direction-type))
227 (trigger-tooltip-query :void)
228 (:get allocated-width :int)
229 (:get allocated-height :int)
230 (is-sensitive :boolean)
231 (:get state-flags state-flags)
232 (has-default :boolean)
233 (has-focus :boolean)
234 (has-grab :boolean)
235 (is-drawable :boolean)
236 (is-toplevel :boolean)
237 (device-is-shadowed :boolean (device pobject))
238 (reset-style :void)
239 (queue-compute-expand :void)
240 (compute-expand :boolean (orientation orientation))
241 (:set-last device-events event-mask (device pobject))
242 (:set-last device-enabled :boolean (device pobject))
243 (:set allocation (struct allocation)))
244
245 (defcfun gtk-widget-get-allocation :void
246 (widget pobject) (allocation (struct allocation :out t)))
247
248 (defgeneric allocation (widget)
249 (:method ((widget widget))
250 (let ((res (make-instance 'allocation)))
251 (gtk-widget-get-allocation widget res)
252 res)))
253
254 (setf (documentation 'clipboard 'function)
255 "SELECTION should be :PRIMARY or :CLIPOARD")
256
257 (defcfun ("gtk_widget_pop_composite_child" pop-composite-child) :void)
258 (defcfun ("gtk_widget_push_composite_child" push-composite-child) :void)
259
260 (defcfun gtk-widget-get-pointer :void
261 (widget pobject) (x :pointer) (y :pointer))
262
263 (defgeneric get-pointer (widget)
264 (:method ((widget widget))
265 (with-foreign-outs ((x :int) (y :int)) :ignore
266 (gtk-widget-get-pointer widget x y))))
267
268 (defcfun gtk-widget-translate-coordinates :boolean
269 (src-widget pobject) (dst-widget pobject) (src-x :int) (src-y :int)
270 (dst-x :pointer) (dst-y :pointer))
271
272 (defgeneric translate-coordinates (src-widget dst-widget src-x src-y)
273 (:method ((src-widget widget) (dst-widget widget) src-x src-y)
274 "Returns (values dst-x dst-y)"
275 (with-foreign-outs ((dst-x :int) (dst-y :int)) :if-success
276 (gtk-widget-translate-coordinates src-widget dst-widget
277 src-x src-y dst-x dst-y))))
278
279 (defcfun gtk-cairo-should-draw-window :boolean
280 (context :pointer) (gdk-window pobject))
281
282 (defgeneric cairo-should-draw-window (window &optional context)
283 (:documentation "WINDOW may be GdkWindow or GtkWidget")
284 (:method (window &optional (context cl-cairo2:*context*))
285 (cl-cairo2::with-context-pointer (context cntx-pointer)
286 (gtk-cairo-should-draw-window cntx-pointer window))))
287
288 (defmethod cairo-should-draw-window ((widget widget)
289 &optional (context cl-cairo2:*context*))
290 (cairo-should-draw-window (window widget) context))
291
292 (defcfun gtk-cairo-transform-to-window :void
293 (context :pointer) (widget pobject) (gdk-window pobject))
294
295 (defgeneric cairo-transform-to-window (widget window &optional context)
296 (:method ((widget widget) window &optional (context cl-cairo2:*context*))
297 (cl-cairo2::with-context-pointer (context cntx-pointer)
298 (gtk-cairo-transform-to-window cntx-pointer widget window))))
299
300 (defmethod cairo-transform-to-window ((widget widget) (window widget)
301 &optional (context cl-cairo2:*context*))
302 (cairo-transform-to-window widget (window window) context))
303
304 (defcfun gtk-widget-set-state-flags :void
305 (widget pobject) (flags state-flags) (clear :boolean))
306 (defcfun gtk-widget-unset-state-flags :void
307 (widget pobject) (flags state-flags))
308
309 (defgeneric (setf state-flags) (value widget &key type)
310 (:method (value (widget widget) &key type)
311 "If TYPE = :SET, only set bits, :UNSET -- unset bits,
312 otherwise set state = VALUE"
313 (case type
314 (:set (gtk-widget-set-state-flags widget value nil))
315 (:unset (gtk-widget-unset-state-flags widget value))
316 (t (gtk-widget-set-state-flags widget value t)))))
317
318 (defcfun gtk-widget-get-preferred-height :void
319 (widget pobject) (minimum :pointer) (natural :pointer))
320 (defcfun gtk-widget-get-preferred-height-for-width :void
321 (widget pobject) (width :int) (minimum :pointer) (natural :pointer))
322
323 (defgeneric preferred-height (widget &key for-width)
324 (:method ((widget widget) &key for-width)
325 "Returns (values minimum natural)"
326 (with-foreign-outs ((minimum :int) (natural :int)) :ignore
327 (if for-width
328 (gtk-widget-get-preferred-height-for-width widget
329 for-width minimum natural)
330 (gtk-widget-get-preferred-height widget minimum natural)))))
331
332 (defcfun gtk-widget-get-preferred-width :void
333 (widget pobject) (minimum :pointer) (natural :pointer))
334 (defcfun gtk-widget-get-preferred-width-for-height :void
335 (widget pobject) (height :int) (minimum :pointer) (natural :pointer))
336
337 (defgeneric preferred-width (widget &key for-height)
338 (:method ((widget widget) &key for-height)
339 "Returns (values minimum natural)"
340 (with-foreign-outs ((minimum :int) (natural :int)) :ignore
341 (if for-height
342 (gtk-widget-get-preferred-width-for-height widget
343 for-height minimum natural)
344 (gtk-widget-get-preferred-width widget minimum natural)))))
345
346 (defcenum size-request-mode
347 :height-for-width :width-for-height)
348
349 (defgtkgetter request-mode size-request-mode widget)
350
351 (defcfun gtk-widget-get-preferred-size :void
352 (widget pobject)
353 (minimum (struct requisition :out t))
354 (natural (struct requisition :out t)))
355
356 (defgeneric preferred-size (widget)
357 (:method ((widget widget))
358 "Returns (values minimum natural).
359 Minimum and natural are requisition objects."
360 (let ((minimum (make-instance 'requisition))
361 (natural (make-instance 'requisition)))
362 (gtk-widget-get-preferred-size widget minimum natural)
363 (values minimum natural))))
364
365 (defcstruct* requested-size
366 "GtkRequestedSize"
367 (data pobject)
368 (minimum-size :int)
369 (natural-size :int))
370
371 (defcfun gtk-distribute-natural-allocation :int
372 (extra-space :int) (n-requested-sizes :int)
373 (sizes (carray (struct requested-size))))
374
375 (defun distribute-natural-allocation (extra-space sizes)
376 "EXTRA-SPACE -- integer, extra space to redistribute among children.
377 SIZES -- {(widget minimum-size natural-size)}*"
378 (let ((sizes-struct
379 (mapcar (lambda (size)
380 (destructuring-bind (widget minimum-size natural-size) size
381 (let ((res (make-instance 'requested-size)))
382 (setf (data res) widget
383 (minimum-size res) minimum-size
384 (natural-size res) natural-size)
385 res)))
386 sizes)))
387 (gtk-distribute-natural-allocation extra-space (length sizes)
388 sizes-struct)))
389
390 (template (name with-type) ((color t)
391 (font nil)
392 (bg-pixmap nil))
393 `(progn
394 (defmethod ,name ((widget widget)
395 &key ,@(when with-type '(type)) (state :normal))
396 (,name (style-context widget) ,@(when with-type '(:type type))
397 :state state))
398
399 (defmethod (setf ,name) (value (widget widget)
400 &key ,@(when with-type '(type)) (state :normal))
401 (setf (,name (style-context widget) ,@(when with-type '(:type type))
402 :state state)
403 value))
404 (save-setter widget ,name)))
405
406 (init-slots widget)
407
408
409 (defclass widget-class (g-object-class)
410 ())
411
412 (defcstruct widget-class
413 (parent-class g-object-class-struct) ; :struct
414 (activate-signal :pointer)
415 (dispatch-child-properties-changed :pointer)
416 (destroy :pointer)
417 (show :pointer)
418 (show-all :pointer)
419 (hide :pointer)
420 (map :pointer)
421 (unmap :pointer)
422 (realize :pointer)
423 (unrealize :pointer)
424 (size-allocate :pointer)
425 (state-changed :pointer)
426 (state-flags-changed :pointer)
427 (parent-set :pointer)
428 (hierarchy-changed :pointer)
429 (style-set :pointer)
430 (direction-changed :pointer)
431 (grab-notify :pointer)
432 (child-notify :pointer)
433 (draw :pointer)
434 (get-request-mode :pointer)
435 (get-preferred-height :pointer)
436 (get-preferred-width-for-height :pointer)
437 (get-preferred-width :pointer)
438 (get-preferred-height-for-width :pointer)
439 (mnemonic-activate :pointer)
440 (grab-focus :pointer)
441 (focus :pointer)
442 (move-focus :pointer)
443 (keynav-failed :pointer)
444 (event :pointer)
445 (button-press-event :pointer)
446 (button-release-event :pointer)
447 (scroll-event :pointer)
448 (motion-notify-event :pointer)
449 (delete-event :pointer)
450 (destroy-event :pointer)
451 (key-press-event :pointer)
452 (key-release-event :pointer)
453 (enter-notify-event :pointer)
454 (leave-notify-event :pointer)
455 (configure-event :pointer)
456 (focus-in-event :pointer)
457 (focus-out-event :pointer)
458 (map-event :pointer)
459 (unmap-event :pointer)
460 (property-notify-event :pointer)
461 (selection-clear-event :pointer)
462 (selection-request-event :pointer)
463 (selection-notify-event :pointer)
464 (proximity-in-event :pointer)
465 (proximity-out-event :pointer)
466 (visibility-notify-event :pointer)
467 (window-state-event :pointer)
468 (damage-event :pointer)
469 (grab-broken-event :pointer)
470 (selection-get :pointer)
471 (selection-received :pointer)
472 (drag-begin :pointer)
473 (drag-end :pointer)
474 (drag-data-get :pointer)
475 (drag-data-delete :pointer)
476 (drag-leave :pointer)
477 (drag-motion :pointer)
478 (drag-drop :pointer)
479 (drag-data-received :pointer)
480 (drag-failed :pointer)
481 (popup-menu :pointer)
482 (show-help :pointer)
483 (get-accessible :pointer)
484 (screen-changed :pointer)
485 (can-activate-accel :pointer)
486 (composited-changed :pointer)
487 (query-tooltip :pointer)
488 (compute-expand :pointer)
489 (adjust-size-request :pointer)
490 (adjust-size-allocation :pointer)
491 (style-updated :pointer)
492 (gtk-reserved :pointer :count 8))
493
494 (defgtkfuns widget-class
495 (install-style-property :void (pspec pobject))
496 (install-style-property-parser :void (pspec pobject) (parser pfunction))
497 (find-style-property (object g-param-spec) (name :string)))
498
499
500 (defcfun gtk-widget-class-list-style-properties (garray (object g-param-spec))
501 (widget-class pobject) (n-properties :pointer))
502
503 (defgeneric list-style-properties (widget-class))
504 (defmethod list-style-properties ((widget-class widget-class))
505 (gtk-widget-class-list-style-properties widget-class *array-length*))
506
507 (g-object-cffi::generate-property-accessors
508 style-property widget
509 nil gtk-widget-style-get-property
510 style-property-type
511 widget-class find-style-property %style-properties)
512
513

  ViewVC Help
Powered by ViewVC 1.1.5