chiark / gitweb /
Added CAIRO-REGION
[clg] / gdk / gdk.lisp
CommitLineData
112ac1d3 1;; Common Lisp bindings for GTK+ v2.x
90c5d56b 2;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
560af5c5 3;;
112ac1d3 4;; Permission is hereby granted, free of charge, to any person obtaining
5;; a copy of this software and associated documentation files (the
6;; "Software"), to deal in the Software without restriction, including
7;; without limitation the rights to use, copy, modify, merge, publish,
8;; distribute, sublicense, and/or sell copies of the Software, and to
9;; permit persons to whom the Software is furnished to do so, subject to
10;; the following conditions:
560af5c5 11;;
112ac1d3 12;; The above copyright notice and this permission notice shall be
13;; included in all copies or substantial portions of the Software.
560af5c5 14;;
112ac1d3 15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
1c66c45f 23;; $Id: gdk.lisp,v 1.44 2007-09-07 07:36:26 espen Exp $
560af5c5 24
25
26(in-package "GDK")
27
13b24566 28;;; Initialization
29
30(defbinding (gdk-init "gdk_parse_args") () nil
31 "Initializes the library without opening the display."
32 (nil null)
33 (nil null))
560af5c5 34
560af5c5 35
13b24566 36
a02fc41f 37;;; Display
13b24566 38
dc220076 39#-debug-ref-counting
40(defmethod print-object ((display display) stream)
41 (if (and (proxy-valid-p display) (slot-boundp display 'name))
42 (print-unreadable-object (display stream :type t :identity nil)
43 (format stream "~S at 0x~X"
44 (display-name display) (pointer-address (foreign-location display))))
45 (call-next-method)))
46
13b24566 47(defbinding %display-open () display
48 (display-name (or null string)))
49
f5c99598 50(defvar *display-aliases* ())
51
52(defun display-add-alias (display alias)
53 (unless (rassoc display *display-aliases*)
54 (signal-connect display 'closed
55 #'(lambda (is-error-p)
56 (declare (ignore is-error-p))
57 (setq *display-aliases*
58 (delete-if #'(lambda (mapping)
59 (eq (cdr mapping) display))
60 *display-aliases*))))
61 (push (cons alias display) *display-aliases*)))
62
63
64(defun display-open (&optional name)
dc220076 65 (let ((display (or
f5c99598 66 (%display-open name)
67 (error "Opening display failed: ~A" name))))
13b24566 68 (unless (display-get-default)
69 (display-set-default display))
f5c99598 70 (when (and (stringp name) (not (string= name (display-name display))))
71 (display-add-alias display name))
13b24566 72 display))
73
a02fc41f 74(defbinding %display-get-n-screens () int
75 (display display))
76
77(defbinding %display-get-screen () screen
78 (display display)
79 (screen-num int))
80
81(defun display-screens (&optional (display (display-get-default)))
82 (loop
83 for i from 0 below (%display-get-n-screens display)
84 collect (%display-get-screen display i)))
85
86(defbinding display-get-default-screen
87 (&optional (display (display-get-default))) screen
88 (display display))
89
90(defbinding display-beep (&optional (display (display-get-default))) nil
91 (display display))
92
93(defbinding display-sync (&optional (display (display-get-default))) nil
94 (display display))
95
96(defbinding display-flush (&optional (display (display-get-default))) nil
97 (display display))
98
99(defbinding display-close (&optional (display (display-get-default))) nil
f5c99598 100 ((ensure-display display t) display))
a02fc41f 101
e99a089d 102(defbinding flush () nil)
103
a02fc41f 104(defbinding display-get-event
105 (&optional (display (display-get-default))) event
106 (display display))
107
108(defbinding display-peek-event
109 (&optional (display (display-get-default))) event
110 (display display))
111
112(defbinding display-put-event
113 (event &optional (display (display-get-default))) event
114 (display display)
115 (event event))
116
13b24566 117(defbinding (display-connection-number "clg_gdk_connection_number")
118 (&optional (display (display-get-default))) int
119 (display display))
120
f5c99598 121(defun find-display (name &optional (error-p t))
122 (or
123 (find name (list-displays) :key #'display-name :test #'string=)
124 (cdr (assoc name *display-aliases* :test #'string=))
125 (when error-p
126 (error "No such display: ~A" name))))
127
128;; This will not detect connections to the same server that use
129;; different hostnames
130(defun %find-similar-display (display)
131 (find (display-name display) (delete display (list-displays))
132 :key #'display-name :test #'string=))
dc220076 133
f5c99598 134(defun ensure-display (display &optional existing-only-p)
dc220076 135 (etypecase display
136 (null (display-get-default))
137 (display display)
f5c99598 138 (string (or
139 (find-display display existing-only-p)
140 (let* ((new (display-open display))
141 (existing (%find-similar-display new)))
142 (if existing
143 (progn
144 (display-add-alias existing display)
145 (display-close new)
146 existing)
147 new))))))
13b24566 148
a02fc41f 149
150;;; Display manager
151
152(defbinding display-get-default () display)
153
a02fc41f 154(defbinding (display-set-default "gdk_display_manager_set_default_display")
155 (display) nil
156 ((display-manager) display-manager)
157 (display display))
158
dc220076 159(defbinding (list-displays "gdk_display_manager_list_displays") ()
160 (gslist (static display))
161 ((display-manager) display-manager))
162
163;; The only purpose of exporting this is to make it possible for
164;; applications to connect to the display-opened signal
165(defbinding (display-manager "gdk_display_manager_get") () display-manager)
166
167(defbinding display-get-core-pointer
168 (&optional (display (display-get-default))) device
169 (display display))
170
f5c99598 171(defmacro with-default-display ((display) &body body)
172 (let ((saved-display (make-symbol "SAVED-DISPLAY"))
173 (current-display (make-symbol "CURRENT-DISPLAY")))
174 `(let* ((,current-display ,display)
175 (,saved-display (when ,current-display
176 (prog1
177 (display-get-default)
178 (display-set-default (ensure-display ,current-display))))))
179 (unwind-protect
180 (progn ,@body)
181 (when ,saved-display
182 (display-set-default ,saved-display))))))
183
a02fc41f 184
3a64da99 185;;; Primitive graphics structures (points, rectangles and regions)
186
187(defbinding %rectangle-intersect () boolean
188 (src1 rectangle)
189 (src2 rectangle)
190 (dest rectangle))
191
192(defun rectangle-intersect (src1 src2 &optional (dest (make-instance 'rectangle)))
193 "Calculates the intersection of two rectangles. It is allowed for DEST to be the same as either SRC1 or SRC2. DEST is returned if the to rectangles intersect, otherwise NIL"
194 (when (%rectangle-intersect src1 src2 dest)
195 dest))
196
197(defbinding rectangle-union (src1 src2 &optional (dest (make-instance 'rectangle))) nil
198 "Calculates the union of two rectangles. The union of rectangles SRC1 and SRC2 is the smallest rectangle which includes both SRC1 and SRC2 within it. It is allowed for DEST to be the same as either SRC1 or SRC2."
199 (src1 rectangle)
200 (src2 rectangle)
201 (dest rectangle :in/return))
202
203(defun ensure-rectangle (rectangle)
204 (etypecase rectangle
205 (rectangle rectangle)
206 (vector (make-instance 'rectangle
207 :x (aref rectangle 0) :y (aref rectangle 1)
208 :width (aref rectangle 2) :height (aref rectangle 3)))))
209
210
211(defbinding %region-new () pointer)
212
213(defbinding %region-polygon () pointer
214 (points (vector (inlined point)))
215 (n-points int)
216 (fill-rule fill-rule))
217
218(defbinding %region-rectangle () pointer
219 (rectangle rectangle))
220
221(defbinding %region-copy () pointer
222 (location pointer))
223
224(defbinding %region-destroy () nil
225 (location pointer))
226
227(defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
3a64da99 228 (cond
229 ((and rectangle polygon)
230 (error "Only one of the keyword arguments :RECTANGLE and :POLYGON can be specified"))
231 (rectangle (%region-rectangle (ensure-rectangle rectangle)))
232 (polygon (%region-polygon polygon (length polygon) fill-rule))
233 ((%region-new))))
234
235(defun ensure-region (region)
236 (etypecase region
237 (region region)
238 ((or rectangle vector)
e071d7ed 239 (make-instance 'region :rectangle (ensure-rectangle region)))
240 (list
241 (make-instance 'region :polygon region))))
3a64da99 242
243(defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
244 (region region)
245 (rectangle rectangle :in/return))
246
247(defbinding %region-get-rectangles () nil
248 (region region)
249 (rectangles pointer :out)
250 (n-rectangles int :out))
251
252(defun region-get-rectangles (region)
253 "Obtains the area covered by the region as a list of rectangles."
254 (multiple-value-bind (location length) (%region-get-rectangles region)
255 (prog1
e071d7ed 256 (map-c-vector 'list #'identity location '(inlined rectangle) length :get)
3a64da99 257 (deallocate-memory location))))
258
259(defbinding region-empty-p () boolean
260 (region region))
261
262(defbinding region-equal-p () boolean
263 (region1 region)
264 (region2 region))
265
266(defbinding region-point-in-p () boolean
267 (region region)
268 (x int)
269 (y int))
270
271(defbinding region-rect-in (region rectangle) overlap-type
272 (region region)
273 ((ensure-rectangle rectangle) rectangle))
274
275(defbinding region-offset () nil
276 (region region)
277 (dx int)
278 (dy int))
279
280(defbinding region-shrink () nil
281 (region region)
282 (dx int)
283 (dy int))
284
285(defbinding region-intersect (source1 source2) nil
e4143920 286 ((ensure-region source1) region :in/return)
3a64da99 287 ((ensure-region source2) region))
288
289(defbinding region-union (source1 source2) nil
e4143920 290 ((ensure-region source1) region :in/return)
3a64da99 291 ((ensure-region source2) region))
292
293(defbinding region-subtract (source1 source2) nil
e4143920 294 ((ensure-region source1) region :in/return)
3a64da99 295 ((ensure-region source2) region))
296
297(defbinding region-xor (source1 source2) nil
e4143920 298 ((ensure-region source1) region :in/return)
3a64da99 299 ((ensure-region source2) region))
300
a02fc41f 301
13b24566 302;;; Events
560af5c5 303
8bb8ead0 304(defbinding (events-pending-p "gdk_events_pending") () boolean)
560af5c5 305
8bb8ead0 306(defbinding event-get () event)
560af5c5 307
8bb8ead0 308(defbinding event-peek () event)
560af5c5 309
8bb8ead0 310(defbinding event-get-graphics-expose () event
560af5c5 311 (window window))
312
8bb8ead0 313(defbinding event-put () event
560af5c5 314 (event event))
315
8bb8ead0 316;(defbinding event-handler-set () ...)
560af5c5 317
8bb8ead0 318(defbinding set-show-events () nil
560af5c5 319 (show-events boolean))
320
8bb8ead0 321(defbinding get-show-events () boolean)
560af5c5 322
560af5c5 323
a02fc41f 324;;; Miscellaneous functions
560af5c5 325
9b61d89d 326(defbinding screen-width () int
327 (screen screen))
328
329(defbinding screen-height () int
330 (screen screen))
331
332(defbinding screen-width-mm () int
333 (screen screen))
334
335(defbinding screen-height-mm () int
336 (screen screen))
560af5c5 337
560af5c5 338
a02fc41f 339(defbinding pointer-grab
340 (window &key owner-events events confine-to cursor time) grab-status
560af5c5 341 (window window)
342 (owner-events boolean)
a02fc41f 343 (events event-mask)
560af5c5 344 (confine-to (or null window))
345 (cursor (or null cursor))
580820d8 346 ((or time 0) (unsigned 32)))
560af5c5 347
a02fc41f 348(defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
580820d8 349 (&optional time (display (display-get-default))) nil
a02fc41f 350 (display display)
580820d8 351 ((or time 0) (unsigned 32)))
560af5c5 352
a02fc41f 353(defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
90c5d56b 354 (&optional (display (display-get-default))) boolean
355 (display display))
a02fc41f 356
357(defbinding keyboard-grab (window &key owner-events time) grab-status
560af5c5 358 (window window)
359 (owner-events boolean)
580820d8 360 ((or time 0) (unsigned 32)))
560af5c5 361
a02fc41f 362(defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
580820d8 363 (&optional time (display (display-get-default))) nil
a02fc41f 364 (display display)
580820d8 365 ((or time 0) (unsigned 32)))
560af5c5 366
560af5c5 367
560af5c5 368
628fd576 369(defbinding atom-intern (atom-name &optional only-if-exists) atom
370 ((string atom-name) string)
371 (only-if-exists boolean))
372
373(defbinding atom-name () string
374 (atom atom))
375
560af5c5 376
377
378;;; Visuals
379
8bb8ead0 380(defbinding visual-get-best-depth () int)
560af5c5 381
8bb8ead0 382(defbinding visual-get-best-type () visual-type)
560af5c5 383
8bb8ead0 384(defbinding visual-get-system () visual)
560af5c5 385
386
8bb8ead0 387(defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
560af5c5 388
8bb8ead0 389(defbinding %visual-get-best-with-depth () visual
560af5c5 390 (depth int))
391
8bb8ead0 392(defbinding %visual-get-best-with-type () visual
560af5c5 393 (type visual-type))
394
8bb8ead0 395(defbinding %visual-get-best-with-both () visual
560af5c5 396 (depth int)
397 (type visual-type))
398
399(defun visual-get-best (&key depth type)
400 (cond
401 ((and depth type) (%visual-get-best-with-both depth type))
402 (depth (%visual-get-best-with-depth depth))
403 (type (%visual-get-best-with-type type))
404 (t (%visual-get-best-with-nothing))))
405
8bb8ead0 406;(defbinding query-depths ..)
560af5c5 407
8bb8ead0 408;(defbinding query-visual-types ..)
560af5c5 409
8bb8ead0 410(defbinding list-visuals () (glist visual))
560af5c5 411
412
413;;; Windows
414
8bb8ead0 415(defbinding window-destroy () nil
560af5c5 416 (window window))
417
8f30d7da 418(defbinding window-at-pointer () window
419 (x int :out)
420 (y int :out))
560af5c5 421
8bb8ead0 422(defbinding window-show () nil
560af5c5 423 (window window))
424
8f30d7da 425(defbinding window-show-unraised () nil
426 (window window))
427
8bb8ead0 428(defbinding window-hide () nil
560af5c5 429 (window window))
430
8f30d7da 431(defbinding window-is-visible-p () boolean
432 (window window))
433
434(defbinding window-is-viewable-p () boolean
435 (window window))
436
8bb8ead0 437(defbinding window-withdraw () nil
560af5c5 438 (window window))
439
8f30d7da 440(defbinding window-iconify () nil
441 (window window))
442
443(defbinding window-deiconify () nil
444 (window window))
445
446(defbinding window-stick () nil
447 (window window))
448
449(defbinding window-unstick () nil
450 (window window))
451
452(defbinding window-maximize () nil
453 (window window))
454
455(defbinding window-unmaximize () nil
456 (window window))
457
458(defbinding window-fullscreen () nil
459 (window window))
460
461(defbinding window-unfullscreen () nil
462 (window window))
463
464(defbinding window-set-keep-above () nil
465 (window window)
466 (setting boolean))
467
468(defbinding window-set-keep-below () nil
469 (window window)
470 (setting boolean))
471
8bb8ead0 472(defbinding window-move () nil
560af5c5 473 (window window)
474 (x int)
475 (y int))
476
8bb8ead0 477(defbinding window-resize () nil
560af5c5 478 (window window)
479 (width int)
480 (height int))
481
8bb8ead0 482(defbinding window-move-resize () nil
560af5c5 483 (window window)
484 (x int)
485 (y int)
486 (width int)
487 (height int))
488
8f30d7da 489(defbinding window-scroll () nil
490 (window window)
491 (dx int)
492 (dy int))
493
e071d7ed 494#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
495(defbinding window-move-region (window region dx dy) nil
496 (window window)
497 ((ensure-region region) region)
498 (dx int)
499 (dy int))
500
8bb8ead0 501(defbinding window-reparent () nil
560af5c5 502 (window window)
503 (new-parent window)
504 (x int)
505 (y int))
506
8bb8ead0 507(defbinding window-clear () nil
560af5c5 508 (window window))
509
8f30d7da 510(defbinding %window-clear-area () nil
560af5c5 511 (window window)
512 (x int) (y int) (width int) (height int))
513
8f30d7da 514(defbinding %window-clear-area-e () nil
560af5c5 515 (window window)
516 (x int) (y int) (width int) (height int))
517
518(defun window-clear-area (window x y width height &optional expose)
519 (if expose
8f30d7da 520 (%window-clear-area-e window x y width height)
521 (%window-clear-area window x y width height)))
560af5c5 522
8bb8ead0 523(defbinding window-raise () nil
560af5c5 524 (window window))
525
8bb8ead0 526(defbinding window-lower () nil
560af5c5 527 (window window))
528
8f30d7da 529(defbinding window-focus () nil
530 (window window)
531 (timestamp unsigned-int))
532
533(defbinding window-register-dnd () nil
534 (window window))
535
536(defbinding window-begin-resize-drag () nil
537 (window window)
538 (edge window-edge)
539 (button int)
540 (root-x int)
541 (root-y int)
542 (timestamp unsigned-int))
543
544(defbinding window-begin-move-drag () nil
545 (window window)
546 (button int)
547 (root-x int)
548 (root-y int)
549 (timestamp unsigned-int))
550
3a64da99 551;; Probably not needed
552;; (defbinding window-constrain-size () nil ..
553
554(defbinding window-begin-paint-region (window region) nil
555 (window window)
556 ((ensure-region region) region))
557
558(defbinding window-end-paint () nil
559 (window window))
8f30d7da 560
3a64da99 561(defmacro with-window-paint ((window region) &body body)
562 `(progn
563 (window-begin-paint-region ,window ,region)
564 (unwind-protect
565 (progn ,@body)
566 (window-end-paint ,window))))
567
568;; TODO: create wrapper function and use gdk_window_invalidate_maybe_recurse
569;; if last arg is a function
570(defbinding window-invalidate-region (window region invalidate-children-p) nil
571 (window window)
572 ((ensure-region region) region)
573 (invalidate-children-p boolean))
574
575(defbinding window-get-update-area () region
576 (window window))
577
578(defbinding window-freeze-updates () nil
579 (window window))
580
581(defbinding window-thaw-updates () nil
582 (window window))
583
584(defbinding window-process-all-updates () nil)
585
586(defbinding window-process-updates () nil
587 (window window)
588 (update-children-p boolean))
589
590(defbinding window-set-debug-updates () nil
591 (enable-p boolean))
592
593(defbinding window-enable-synchronized-configure () nil
594 (window window))
595
596(defbinding window-configure-finished () nil
597 (window window))
598
599;; Deprecated, use gobject user data mechanism
8f30d7da 600(defbinding window-set-user-data () nil
601 (window window)
602 (user-data pointer))
560af5c5 603
8bb8ead0 604(defbinding window-set-override-redirect () nil
560af5c5 605 (window window)
3a64da99 606 (override-redirect-p boolean))
560af5c5 607
3a64da99 608(defbinding window-set-accept-focus () nil
609 (window window)
610 (accept-focus-p boolean))
560af5c5 611
3a64da99 612(defbinding window-set-focus-on-map () nil
613 (window window)
614 (focus-on-map-p boolean))
615
616;; Added if needed
617; (defbinding window-add-filter () nil
8bb8ead0 618; (defbinding window-remove-filter () nil
560af5c5 619
3a64da99 620;; New code should use window-shape-combine
8bb8ead0 621(defbinding window-shape-combine-mask () nil
560af5c5 622 (window window)
623 (shape-mask bitmap)
624 (offset-x int)
625 (offset-y int))
626
3a64da99 627(defbinding %window-shape-combine-region () nil
628 (window window)
629 (region (or null region))
630 (offset-x int)
631 (offset-y int))
632
633(defun window-shape-combine (window shape offset-x offset-y)
634 (etypecase shape
e071d7ed 635 (null (%window-shape-combine-region window nil 0 0))
3a64da99 636 (region (%window-shape-combine-region window shape offset-x offset-y))
e071d7ed 637 (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
3a64da99 638
8bb8ead0 639(defbinding window-set-child-shapes () nil
560af5c5 640 (window window))
641
8bb8ead0 642(defbinding window-merge-child-shapes () nil
560af5c5 643 (window window))
644
3a64da99 645#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
646(progn
647 (defbinding %window-input-shape-combine-mask () nil
648 (window window)
649 (shape-mask bitmap)
650 (x int)
651 (y int))
652
653 (defbinding %window-input-shape-combine-region () nil
654 (window window)
655 (region (or null region))
656 (x int)
657 (y int))
658
659 (defun window-input-shape-combine (window shape x y)
660 (etypecase shape
e071d7ed 661 (null (%window-input-shape-combine-region window nil 0 0))
662 (region (%window-input-shape-combine-region window shape x y))
663 (bitmap (%window-input-shape-combine-mask window shape x y))))
3a64da99 664
665 (defbinding window-set-child-input-shapes () nil
666 (window window))
667
668 (defbinding window-merge-child-input-shapes () nil
669 (window window)))
560af5c5 670
8bb8ead0 671(defbinding window-set-static-gravities () boolean
560af5c5 672 (window window)
3a64da99 673 (use-static-p boolean))
674
675(defbinding window-set-title () nil
676 (window window)
677 (title string))
560af5c5 678
3a64da99 679(defbinding window-set-background () nil
680 (window window)
681 (color color))
682
683(defbinding window-set-back-pixmap (window pixmap &optional parent-relative-p) nil
684 (window window)
685 (pixmap (or null pixmap))
686 (parent-relative-p boolean))
560af5c5 687
8bb8ead0 688(defbinding window-set-cursor () nil
560af5c5 689 (window window)
8f30d7da 690 (cursor (or null cursor)))
560af5c5 691
3a64da99 692(defbinding window-get-geometry () nil
693 (window window)
694 (x int :out)
695 (y int :out)
696 (width int :out)
697 (height int :out)
698 (depth int :out))
699
700;(defbinding window-set-geometry-hints () nil
701
f71dc283 702(defbinding window-set-icon-list () nil
3a64da99 703 (window window)
704 (icons (glist pixbufs)))
705
706(defbinding window-set-skip-taskbar-hint () nil
707 (window window)
708 (skip-taskbar-p boolean))
709
710(defbinding window-set-skip-pager-hint () nil
711 (window window)
712 (skip-pager-p boolean))
713
714#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
715(defbinding window-set-urgency-hint () nil
716 (window window)
717 (urgent-p boolean))
718
719(defbinding window-get-position () nil
720 (window window)
721 (x int :out)
722 (y int :out))
723
724(defbinding window-get-root-origin () nil
725 (window window)
726 (x int :out)
727 (y int :out))
728
729(defbinding window-get-frame-extents (window &optional (extents (make-instance 'rect))) nil
730 (window window)
731 (extents rectangle :in/return))
732
733(defbinding window-get-origin () nil ; this may not work as
734 (window window) ; an int is actually returned
735 (x int :out)
736 (y int :out))
737
8bb8ead0 738(defbinding window-get-pointer () window
560af5c5 739 (window window)
740 (x int :out)
741 (y int :out)
742 (mask modifier-type :out))
743
3a64da99 744;(defbinding window-set-icon () nil
745
746(defbinding window-set-icon-name () nil
747 (window window)
748 (icon-name string))
749
750(defbinding window-set-transient-for () nil
751 (window window)
752 (parent window))
753
754(defbinding window-set-role () nil
755 (window window)
756 (role string))
757
758(defbinding %window-get-decorations () boolean
759 (window window)
760 (decorations wm-decoration :out))
761
762(defun %window-decorations-getter (window)
763 (nth-value 1 (%window-get-decorations window)))
764
765(defun %window-decorations-boundp (window)
766 (%window-get-decorations window))
767
8f30d7da 768(defbinding %window-get-toplevels () (glist window))
769
770(defun window-get-toplevels (&optional screen)
771 (if screen
772 (error "Not implemented")
773 (%window-get-toplevels)))
774
bc9997e8 775(defbinding %get-default-root-window () window)
560af5c5 776
3d5e4e39 777(defun get-root-window (&optional display)
bc9997e8 778 (if display
779 (error "Not implemented")
780 (%get-default-root-window)))
560af5c5 781
782
8f30d7da 783
784;;; Drag and Drop
785
786;; Destination side
787
788(defbinding drag-status () nil
789 (context drag-context)
790 (action drag-action)
791 (time (unsigned 32)))
792
793
794
795
796
797
560af5c5 798;;
799
8bb8ead0 800(defbinding rgb-init () nil)
560af5c5 801
802
803
804
805;;; Cursor
806
25d755bb 807(defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
8bc1cf79 808 (x 0) (y 0) (display (display-get-default)))
25d755bb 809 (etypecase source
810 (keyword (%cursor-new-for-display display source))
811 (pixbuf (%cursor-new-from-pixbuf display source x y))
812 (pixmap (%cursor-new-from-pixmap source mask
813 (or fg (ensure-color #(0.0 0.0 0.0)))
814 (or bg (ensure-color #(1.0 1.0 1.0))) x y))
815 (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
816
817(defun ensure-cursor (cursor &rest args)
818 (if (typep cursor 'cursor)
819 cursor
bc21ee32 820 (apply #'make-instance 'cursor :source cursor args)))
8f30d7da 821
822(defbinding %cursor-new-for-display () pointer
823 (display display)
560af5c5 824 (cursor-type cursor-type))
825
8f30d7da 826(defbinding %cursor-new-from-pixmap () pointer
560af5c5 827 (source pixmap)
828 (mask bitmap)
829 (foreground color)
830 (background color)
831 (x int) (y int))
832
8f30d7da 833(defbinding %cursor-new-from-pixbuf () pointer
834 (display display)
835 (pixbuf pixbuf)
836 (x int) (y int))
837
8bb8ead0 838(defbinding %cursor-ref () pointer
9adccb27 839 (location pointer))
560af5c5 840
8bb8ead0 841(defbinding %cursor-unref () nil
9adccb27 842 (location pointer))
843
560af5c5 844
560af5c5 845;;; Pixmaps
bc9997e8 846
358bbd90 847(defbinding %pixmap-new () pointer
848 (window (or null window))
560af5c5 849 (width int)
850 (height int)
358bbd90 851 (depth int))
852
853(defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
854 (%pixmap-new window width height depth))
855
856(defun pixmap-new (width height depth &key window)
857 (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
858 (make-instance 'pixmap :width width :height height :depth depth :window window))
859
8bb8ead0 860(defbinding %pixmap-colormap-create-from-xpm () pixmap
560af5c5 861 (window (or null window))
862 (colormap (or null colormap))
863 (mask bitmap :out)
864 (color (or null color))
90c5d56b 865 (filename pathname))
560af5c5 866
8bb8ead0 867(defbinding %pixmap-colormap-create-from-xpm-d () pixmap
560af5c5 868 (window (or null window))
869 (colormap (or null colormap))
870 (mask bitmap :out)
871 (color (or null color))
2a189a9e 872 (data (vector string)))
560af5c5 873
358bbd90 874;; Deprecated, use pixbufs instead
bb110f5f 875(defun pixmap-create (source &key color window colormap)
876 (let ((window
877 (if (not (or window colormap))
878 (get-root-window)
879 window)))
880 (multiple-value-bind (pixmap mask)
2a189a9e 881 (etypecase source
bb110f5f 882 ((or string pathname)
90c5d56b 883 (%pixmap-colormap-create-from-xpm window colormap color source))
2a189a9e 884 ((vector string)
885 (%pixmap-colormap-create-from-xpm-d window colormap color source)))
bb110f5f 886 (values pixmap mask))))
bc9997e8 887
560af5c5 888
560af5c5 889;;; Color
890
358bbd90 891(defbinding colormap-get-system () colormap)
892
5e12e92b 893(defbinding %color-copy () pointer
894 (location pointer))
895
896(defmethod allocate-foreign ((color color) &rest initargs)
897 (declare (ignore color initargs))
898 ;; Color structs are allocated as memory chunks by gdk, and since
899 ;; there is no gdk_color_new we have to use this hack to get a new
900 ;; color chunk
90c5d56b 901 (with-memory (location #.(foreign-size (find-class 'color)))
5e12e92b 902 (%color-copy location)))
903
560af5c5 904(defun %scale-value (value)
905 (etypecase value
906 (integer value)
907 (float (truncate (* value 65535)))))
908
90c5d56b 909(defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
560af5c5 910 (call-next-method)
911 (with-slots ((%red red) (%green green) (%blue blue)) color
912 (setf
1ebfd3a6 913 %red (%scale-value red)
914 %green (%scale-value green)
915 %blue (%scale-value blue))))
560af5c5 916
e7f1852f 917(defbinding %color-parse () boolean
5e12e92b 918 (spec string)
90c5d56b 919 (color color :in/return))
5e12e92b 920
e7f1852f 921(defun color-parse (spec &optional (color (make-instance 'color)))
922 (multiple-value-bind (succeeded-p color) (%color-parse spec color)
923 (if succeeded-p
924 color
925 (error "Parsing color specification ~S failed." spec))))
926
560af5c5 927(defun ensure-color (color)
928 (etypecase color
929 (null nil)
930 (color color)
e7f1852f 931 (string (color-parse color))
1ebfd3a6 932 (vector
5e12e92b 933 (make-instance 'color
e7f1852f 934 :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
935
560af5c5 936
937
358bbd90 938;;; Drawable -- all the draw- functions are deprecated and will be
90c5d56b 939;;; removed, use cairo for drawing instead.
8f30d7da 940
941(defbinding drawable-get-size () nil
942 (drawable drawable)
943 (width int :out)
944 (height int :out))
945
946(defbinding (drawable-width "gdk_drawable_get_size") () nil
947 (drawable drawable)
948 (width int :out)
949 (nil null))
950
951(defbinding (drawable-height "gdk_drawable_get_size") () nil
952 (drawable drawable)
953 (nil null)
954 (height int :out))
955
956;; (defbinding drawable-get-clip-region () region
957;; (drawable drawable))
958
959;; (defbinding drawable-get-visible-region () region
960;; (drawable drawable))
961
962(defbinding draw-point () nil
963 (drawable drawable) (gc gc)
964 (x int) (y int))
965
966(defbinding %draw-points () nil
967 (drawable drawable) (gc gc)
968 (points pointer)
969 (n-points int))
970
8f30d7da 971(defbinding draw-line () nil
972 (drawable drawable) (gc gc)
973 (x1 int) (y1 int)
974 (x2 int) (y2 int))
975
8f30d7da 976(defbinding draw-pixbuf
977 (drawable gc pixbuf src-x src-y dest-x dest-y &optional
978 width height (dither :none) (x-dither 0) (y-dither 0)) nil
979 (drawable drawable) (gc (or null gc))
980 (pixbuf pixbuf)
981 (src-x int) (src-y int)
982 (dest-x int) (dest-y int)
983 ((or width -1) int) ((or height -1) int)
984 (dither rgb-dither)
985 (x-dither int) (y-dither int))
986
8bb8ead0 987(defbinding draw-rectangle () nil
8f30d7da 988 (drawable drawable) (gc gc)
989 (filled boolean)
990 (x int) (y int)
991 (width int) (height int))
992
993(defbinding draw-arc () nil
994 (drawable drawable) (gc gc)
995 (filled boolean)
996 (x int) (y int)
997 (width int) (height int)
998 (angle1 int) (angle2 int))
999
8f30d7da 1000(defbinding %draw-layout () nil
1001 (drawable drawable) (gc gc)
1002 (font pango:font)
1003 (x int) (y int)
1004 (layout pango:layout))
1005
1006(defbinding %draw-layout-with-colors () nil
1007 (drawable drawable) (gc gc)
1008 (font pango:font)
1009 (x int) (y int)
1010 (layout pango:layout)
1011 (foreground (or null color))
1012 (background (or null color)))
1013
1014(defun draw-layout (drawable gc font x y layout &optional foreground background)
1015 (if (or foreground background)
1016 (%draw-layout-with-colors drawable gc font x y layout foreground background)
1017 (%draw-layout drawable gc font x y layout)))
1018
1019(defbinding draw-drawable
1020 (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
1021 (drawable drawable) (gc gc)
1022 (src drawable)
1023 (src-x int) (src-y int)
1024 (dest-x int) (dest-y int)
1025 ((or width -1) int) ((or height -1) int))
1026
1027(defbinding draw-image
1028 (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
1029 (drawable drawable) (gc gc)
1030 (image image)
1031 (src-x int) (src-y int)
1032 (dest-x int) (dest-y int)
1033 ((or width -1) int) ((or height -1) int))
1034
1035(defbinding drawable-get-image () image
1036 (drawable drawable)
1037 (x int) (y int)
1038 (width int) (height int))
1039
1040(defbinding drawable-copy-to-image
1041 (drawable src-x src-y width height &optional image dest-x dest-y) image
1042 (drawable drawable)
1043 (image (or null image))
1044 (src-x int) (src-y int)
1045 ((if image dest-x 0) int)
1046 ((if image dest-y 0) int)
1047 (width int) (height int))
560af5c5 1048
1049
1050;;; Key values
1051
8bb8ead0 1052(defbinding keyval-name () string
560af5c5 1053 (keyval unsigned-int))
1054
e4251a29 1055(defbinding %keyval-from-name () unsigned-int
560af5c5 1056 (name string))
1057
e4251a29 1058(defun keyval-from-name (name)
1059 "Returns the keysym value for the given key name or NIL if it is not a valid name."
1060 (let ((keyval (%keyval-from-name name)))
1061 (unless (zerop keyval)
1062 keyval)))
1063
8bb8ead0 1064(defbinding keyval-to-upper () unsigned-int
560af5c5 1065 (keyval unsigned-int))
1066
628fd576 1067(defbinding keyval-to-lower () unsigned-int
560af5c5 1068 (keyval unsigned-int))
1069
8bb8ead0 1070(defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
560af5c5 1071 (keyval unsigned-int))
1072
8bb8ead0 1073(defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
560af5c5 1074 (keyval unsigned-int))
1075
7be9fc0c 1076;;; Cairo interaction
1077
90c5d56b 1078#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
7be9fc0c 1079(progn
1080 (defbinding cairo-create () cairo:context
1081 (drawable drawable))
1082
5fba7ba0 1083 (defmacro with-cairo-context ((cr drawable) &body body)
1084 `(let ((,cr (cairo-create ,drawable)))
1085 (unwind-protect
1086 (progn ,@body)
90c5d56b 1087 (invalidate-instance ,cr t))))
5fba7ba0 1088
7be9fc0c 1089 (defbinding cairo-set-source-color () nil
1090 (cr cairo:context)
1091 (color color))
1092
1093 (defbinding cairo-set-source-pixbuf () nil
1094 (cr cairo:context)
1095 (pixbuf pixbuf)
1096 (x double-float)
1097 (y double-float))
1098
1099 (defbinding cairo-rectangle () nil
1100 (cr cairo:context)
1101 (rectangle rectangle))
1102
1c66c45f 1103 (defbinding cairo-region () nil
1104 (cr cairo:context)
1105 (region region))
aadaf8fb 1106
68cbedb7 1107 (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window
1108 (surface cairo:surface))
7be9fc0c 1109)
18b84c80 1110
1111
90c5d56b 1112
18b84c80 1113;;; Multi-threading support
1114
e99a089d 1115#+sb-thread
18b84c80 1116(progn
50eec23a 1117 (defvar *global-lock* nil)
e99a089d 1118
1119 (defun %global-lock-p ()
1120 (eq (car (sb-thread:mutex-value *global-lock*)) sb-thread:*current-thread*))
1121
1122 (defun threads-enter ()
50eec23a 1123 (when *global-lock*
1124 (if (%global-lock-p)
1125 (incf (cdr (sb-thread:mutex-value *global-lock*)))
1126 (sb-thread:get-mutex *global-lock* (cons sb-thread:*current-thread* 0)))))
e99a089d 1127
1128 (defun threads-leave (&optional flush-p)
50eec23a 1129 (when *global-lock*
1130 (assert (%global-lock-p))
1131 (cond
1132 ((zerop (cdr (sb-thread:mutex-value *global-lock*)))
1133 (when flush-p
1134 (flush))
1135 (sb-thread:release-mutex *global-lock*))
1136 (t (decf (cdr (sb-thread:mutex-value *global-lock*)))))))
18b84c80 1137
1138 (define-callback %enter-fn nil ()
1139 (threads-enter))
1140
1141 (define-callback %leave-fn nil ()
1142 (threads-leave))
1143
50eec23a 1144 (defbinding %threads-set-lock-functions (&optional) nil
18b84c80 1145 (%enter-fn callback)
1146 (%leave-fn callback))
1147
50eec23a 1148 (defun threads-init ()
1149 (%threads-set-lock-functions)
1150 (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock")))
1151
18b84c80 1152 (defmacro with-global-lock (&body body)
1153 `(progn
1154 (threads-enter)
1155 (unwind-protect
e99a089d 1156 (progn ,@body)
1157 (threads-leave t))))
1158
1159 (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1160 (timeout-add interval
1161 #'(lambda ()
1162 (with-global-lock (funcall function)))
1163 priority))
1164
47b77d70 1165 (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
e99a089d 1166 (idle-add
1167 #'(lambda ()
1168 (with-global-lock (funcall function)))
1169 priority)))
1170
1171
1172#-sb-thread
1173(progn
1174 (defmacro with-global-lock (&body body)
1175 `(progn ,@body))
1176
1177 (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
1178 (timeout-add interval function priority))
1179
73b01400 1180 (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
e99a089d 1181 (idle-add function priority)))
1182
1183